slib-3b1/0000755001705200017500000000000010751734725010203 5ustar tbtbslib-3b1/alistab.scm0000644001705200017500000002474110343646422012327 0ustar tbtb;;; "alistab.scm" database tables using association lists (assoc) ; Copyright 1994, 1997 Aubrey Jaffer ; ;Permission to copy this software, to modify it, to redistribute it, ;to distribute modified versions, and to use it for any purpose is ;granted, subject to the following restrictions and understandings. ; ;1. Any copy made of this software must include this copyright notice ;in full. ; ;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; ;3. In conjunction with products arising from the use of this ;material, there shall be no use of my name in any advertising, ;promotional, or sales literature without prior written consent in ;each case. ;;; LLDB is (filename . alist-table) ;;; HANDLE is (#(table-name key-dim) . TABLE) ;;; TABLE is an alist of (Primary-key . ROW) ;;; ROW is a list of non-primary VALUEs (require 'common-list-functions) (require 'relational-database) ;for make-relational-system (require-if 'compiling 'sort) ;@ (define alist-table (let ((catalog-id 0) (resources '*base-resources*) (make-list-keyifier (lambda (prinum types) identity)) (make-keyifier-1 (lambda (type) list)) (make-key->list (lambda (prinum types) identity)) (make-key-extractor (lambda (primary-limit column-type-list index) (let ((i (+ -1 index))) (lambda (lst) (list-ref lst i)))))) (define keyify-1 (make-keyifier-1 'atom)) (define (make-base filename dim types) (list filename (list catalog-id) (list resources (list 'free-id 1)))) (define (open-base infile writable) (define (reader port) (cond ((eof-object? port) #f) ((not (eqv? #\; (read-char port))) #f) ((not (eqv? #\; (read-char port))) #f) (else (cons (and (not (input-port? infile)) infile) (read port))))) (cond ((input-port? infile) (reader infile)) ((file-exists? infile) (call-with-input-file infile reader)) (else #f))) (define (write-base lldb outfile) ((lambda (fun) (cond ((output-port? outfile) (fun outfile)) ((string? outfile) (call-with-output-file outfile fun)) (else #f))) (lambda (port) (display (string-append ";;; \"" outfile "\" SLIB " *slib-version* " alist-table database -*-scheme-*-") port) (newline port) (newline port) (display "(" port) (newline port) (for-each (lambda (table) (display " (" port) (write (car table) port) (newline port) (for-each (lambda (row) (display " " port) (write row port) (newline port)) (cdr table)) (display " )" port) (newline port)) (cdr lldb)) (display ")" port) (newline port) ; (require 'pretty-print) ; (pretty-print (cdr lldb) port) (set-car! lldb (if (string? outfile) outfile #f)) #t))) (define (sync-base lldb) (cond ((car lldb) (write-base lldb (car lldb)) #t) (else ;;; (display "sync-base: database filename not known") #f))) (define (close-base lldb) (cond ((car lldb) (write-base lldb (car lldb)) (set-cdr! lldb #f) (set-car! lldb #f) #t) ((cdr lldb) (set-cdr! lldb #f) (set-car! lldb #f) #t) (else ;;; (display "close-base: database not open") #f))) (define (make-table lldb dim types) (let ((free-hand (open-table lldb resources 1 '(atom integer)))) (and free-hand (let* ((row (assoc* (keyify-1 'free-id) (handle->alist free-hand))) (table-id #f)) (cond (row (set! table-id (cadr row)) (set-car! (cdr row) (+ 1 table-id)) (set-cdr! lldb (cons (list table-id) (cdr lldb))) table-id) (else #f)))))) (define (open-table lldb base-id dim types) (assoc base-id (cdr lldb))) (define (kill-table lldb base-id dim types) (define ckey (list base-id)) (let ((pair (assoc* ckey (cdr lldb)))) (and pair (set-cdr! lldb (delete-assoc ckey (cdr lldb)))) (and pair (not (assoc* ckey (cdr lldb)))))) (define handle->alist cdr) (define set-handle-alist! set-cdr!) (define (assoc* keys alist) (let ((pair (assoc (car keys) alist))) (cond ((not pair) #f) ((null? (cdr keys)) pair) (else (assoc* (cdr keys) (cdr pair)))))) (define (make-assoc* keys alist vals) (let ((pair (assoc (car keys) alist))) (cond ((not pair) (cons (cons (car keys) (if (null? (cdr keys)) vals (make-assoc* (cdr keys) '() vals))) alist)) (else (set-cdr! pair (if (null? (cdr keys)) vals (make-assoc* (cdr keys) (cdr pair) vals))) alist)))) (define (delete-assoc ckey alist) (cond ((null? ckey) '()) ((assoc (car ckey) alist) => (lambda (match) (let ((adl (delete-assoc (cdr ckey) (cdr match)))) (cond ((null? adl) (delete match alist)) (else (set-cdr! match adl) alist))))) (else alist))) (define (delete-assoc* ckey alist) (cond ((every not ckey) '()) ;includes the null case. ((not (car ckey)) (delete '() (map (lambda (fodder) (let ((adl (delete-assoc* (cdr ckey) (cdr fodder)))) (if (null? adl) '() (cons (car fodder) adl)))) alist))) ((procedure? (car ckey)) (delete '() (map (lambda (fodder) (if ((car ckey) (car fodder)) (let ((adl (delete-assoc* (cdr ckey) (cdr fodder)))) (if (null? adl) '() (cons (car fodder) adl))) fodder)) alist))) ((assoc (car ckey) alist) => (lambda (match) (let ((adl (delete-assoc* (cdr ckey) (cdr match)))) (cond ((null? adl) (delete match alist)) (else (set-cdr! match adl) alist))))) (else alist))) (define (assoc*-for-each proc bkey ckey alist) (cond ((null? ckey) (proc (reverse bkey))) ((not (car ckey)) (for-each (lambda (alist) (assoc*-for-each proc (cons (car alist) bkey) (cdr ckey) (cdr alist))) alist)) ((procedure? (car ckey)) (for-each (lambda (alist) (if ((car ckey) (car alist)) (assoc*-for-each proc (cons (car alist) bkey) (cdr ckey) (cdr alist)))) alist)) ((assoc (car ckey) alist) => (lambda (match) (assoc*-for-each proc (cons (car match) bkey) (cdr ckey) (cdr match)))))) (define (assoc*-map proc bkey ckey alist) (cond ((null? ckey) (list (proc (reverse bkey)))) ((not (car ckey)) (apply append (map (lambda (alist) (assoc*-map proc (cons (car alist) bkey) (cdr ckey) (cdr alist))) alist))) ((procedure? (car ckey)) (apply append (map (lambda (alist) (if ((car ckey) (car alist)) (assoc*-map proc (cons (car alist) bkey) (cdr ckey) (cdr alist)) '())) alist))) ((assoc (car ckey) alist) => (lambda (match) (assoc*-map proc (cons (car match) bkey) (cdr ckey) (cdr match)))) (else '()))) (define (sorted-assoc*-for-each proc bkey ckey alist) (cond ((null? ckey) (proc (reverse bkey))) ((not (car ckey)) (for-each (lambda (alist) (sorted-assoc*-for-each proc (cons (car alist) bkey) (cdr ckey) (cdr alist))) (alist-sort! alist))) ((procedure? (car ckey)) (sorted-assoc*-for-each proc bkey (cons #f (cdr ckey)) (remove-if-not (lambda (pair) ((car ckey) (car pair))) alist))) ((assoc (car ckey) alist) => (lambda (match) (sorted-assoc*-for-each proc (cons (car match) bkey) (cdr ckey) (cdr match)))))) (define (alist-sort! alist) (define (key->sortable k) (cond ((number? k) k) ((string? k) k) ((symbol? k) (symbol->string k)) ((vector? k) (map key->sortable (vector->list k))) (else (slib:error "unsortable key" k)))) ;; This routine assumes that the car of its operands are either ;; numbers or strings (or lists of those). (define (car-key-< x y) (key-< (car x) (car y))) (define (key-< x y) (cond ((and (number? x) (number? y)) (< x y)) ((number? x) #t) ((number? y) #f) ((string? x) (stringsortable (car p)) p)) alist) car-key-<))) (define (present? handle ckey) (assoc* ckey (handle->alist handle))) (define (make-putter prinum types) (lambda (handle ckey restcols) (set-handle-alist! handle (make-assoc* ckey (handle->alist handle) restcols)))) (define (make-getter prinum types) (lambda (handle ckey) (let ((row (assoc* ckey (handle->alist handle)))) (and row (cdr row))))) (define (for-each-key handle operation primary-limit column-type-list match-keys) (assoc*-for-each operation '() match-keys (handle->alist handle))) (define (map-key handle operation primary-limit column-type-list match-keys) (assoc*-map operation '() match-keys (handle->alist handle))) (define (ordered-for-each-key handle operation primary-limit column-type-list match-keys) (sorted-assoc*-for-each operation '() match-keys (handle->alist handle))) (define (supported-type? type) (case type ((atom ordinal integer boolean string symbol expression number) #t) (else #f))) (define (supported-key-type? type) (case type ((atom ordinal integer number symbol string) #t) (else #f))) ;;make-table open-table remover assoc* make-assoc* ;;(trace assoc*-for-each assoc*-map sorted-assoc*-for-each) (lambda (operation-name) (case operation-name ((make-base) make-base) ((open-base) open-base) ((write-base) write-base) ((sync-base) sync-base) ((close-base) close-base) ((catalog-id) catalog-id) ((make-table) make-table) ((open-table) open-table) ((kill-table) kill-table) ((make-keyifier-1) make-keyifier-1) ((make-list-keyifier) make-list-keyifier) ((make-key->list) make-key->list) ((make-key-extractor) make-key-extractor) ((supported-type?) supported-type?) ((supported-key-type?) supported-key-type?) ((present?) present?) ((make-putter) make-putter) ((make-getter) make-getter) ((delete) (lambda (handle ckey) (set-handle-alist! handle (delete-assoc ckey (handle->alist handle))))) ((delete*) (lambda (handle primary-limit column-type-list match-keys) (set-handle-alist! handle (delete-assoc* match-keys (handle->alist handle))))) ((for-each-key) for-each-key) ((map-key) map-key) ((ordered-for-each-key) ordered-for-each-key) (else #f))) )) (set! *base-table-implementations* (cons (list 'alist-table (make-relational-system alist-table)) *base-table-implementations*)) ;; #f (trace-all "/home/jaffer/slib/alistab.scm") (untrace alist-table) (set! *qp-width* 333) slib-3b1/alist.scm0000644001705200017500000001024110137477027012016 0ustar tbtb;;;"alist.scm", alist functions for Scheme. ;;;Copyright (C) 1992, 1993, 2003 Aubrey Jaffer ; ;Permission to copy this software, to modify it, to redistribute it, ;to distribute modified versions, and to use it for any purpose is ;granted, subject to the following restrictions and understandings. ; ;1. Any copy made of this software must include this copyright notice ;in full. ; ;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; ;3. In conjunction with products arising from the use of this ;material, there shall be no use of my name in any advertising, ;promotional, or sales literature without prior written consent in ;each case. ;;@code{(require 'alist)} ;;@ftindex alist ;; ;;Alist functions provide utilities for treating a list of key-value pairs ;;as an associative database. These functions take an equality predicate, ;;@var{pred}, as an argument. This predicate should be repeatable, ;;symmetric, and transitive. ;; ;;Alist functions can be used with a secondary index method such as hash ;;tables for improved performance. ;;@body ;;Returns an @dfn{association function} (like @code{assq}, @code{assv}, or ;;@code{assoc}) corresponding to @var{pred}. The returned function ;;returns a key-value pair whose key is @code{pred}-equal to its first ;;argument or @code{#f} if no key in the alist is @var{pred}-equal to the ;;first argument. (define (predicate->asso pred) (cond ((eq? eq? pred) assq) ((eq? = pred) assv) ((eq? eqv? pred) assv) ((eq? char=? pred) assv) ((eq? equal? pred) assoc) ((eq? string=? pred) assoc) (else (lambda (key alist) (let l ((al alist)) (cond ((null? al) #f) ((pred key (caar al)) (car al)) (else (l (cdr al))))))))) ;;@body ;;Returns a procedure of 2 arguments, @var{alist} and @var{key}, which ;;returns the value associated with @var{key} in @var{alist} or @code{#f} if ;;@var{key} does not appear in @var{alist}. (define (alist-inquirer pred) (let ((assofun (predicate->asso pred))) (lambda (alist key) (let ((pair (assofun key alist))) (and pair (cdr pair)))))) ;;@body ;;Returns a procedure of 3 arguments, @var{alist}, @var{key}, and ;;@var{value}, which returns an alist with @var{key} and @var{value} ;;associated. Any previous value associated with @var{key} will be ;;lost. This returned procedure may or may not have side effects on its ;;@var{alist} argument. An example of correct usage is: ;; ;;@lisp ;;(define put (alist-associator string-ci=?)) ;;(define alist '()) ;;(set! alist (put alist "Foo" 9)) ;;@end lisp (define (alist-associator pred) (let ((assofun (predicate->asso pred))) (lambda (alist key val) (let* ((pair (assofun key alist))) (cond (pair (set-cdr! pair val) alist) (else (cons (cons key val) alist))))))) ;;@body ;;Returns a procedure of 2 arguments, @var{alist} and @var{key}, which ;;returns an alist with an association whose @var{key} is key removed. ;;This returned procedure may or may not have side effects on its ;;@var{alist} argument. An example of correct usage is: ;; ;;@lisp ;;(define rem (alist-remover string-ci=?)) ;;(set! alist (rem alist "foo")) ;;@end lisp (define (alist-remover pred) (lambda (alist key) (cond ((null? alist) alist) ((pred key (caar alist)) (cdr alist)) ((null? (cdr alist)) alist) ((pred key (caadr alist)) (set-cdr! alist (cddr alist)) alist) (else (let l ((al (cdr alist))) (cond ((null? (cdr al)) alist) ((pred key (caadr al)) (set-cdr! al (cddr al)) alist) (else (l (cdr al))))))))) ;;@body ;;Returns a new association list formed by mapping @var{proc} over the ;;keys and values of @var{alist}. @var{proc} must be a function of 2 ;;arguments which returns the new value part. (define (alist-map proc alist) (map (lambda (pair) (cons (car pair) (proc (car pair) (cdr pair)))) alist)) ;;@body ;;Applies @var{proc} to each pair of keys and values of @var{alist}. ;;@var{proc} must be a function of 2 arguments. The returned value is ;;unspecified. (define (alist-for-each proc alist) (for-each (lambda (pair) (proc (car pair) (cdr pair))) alist)) slib-3b1/alist.txi0000644001705200017500000000433010747237373012047 0ustar tbtb@code{(require 'alist)} @ftindex alist Alist functions provide utilities for treating a list of key-value pairs as an associative database. These functions take an equality predicate, @var{pred}, as an argument. This predicate should be repeatable, symmetric, and transitive. Alist functions can be used with a secondary index method such as hash tables for improved performance. @defun predicate->asso pred Returns an @dfn{association function} (like @code{assq}, @code{assv}, or @cindex association function @code{assoc}) corresponding to @var{pred}. The returned function returns a key-value pair whose key is @code{pred}-equal to its first argument or @code{#f} if no key in the alist is @var{pred}-equal to the first argument. @end defun @defun alist-inquirer pred Returns a procedure of 2 arguments, @var{alist} and @var{key}, which returns the value associated with @var{key} in @var{alist} or @code{#f} if @var{key} does not appear in @var{alist}. @end defun @defun alist-associator pred Returns a procedure of 3 arguments, @var{alist}, @var{key}, and @var{value}, which returns an alist with @var{key} and @var{value} associated. Any previous value associated with @var{key} will be lost. This returned procedure may or may not have side effects on its @var{alist} argument. An example of correct usage is: @lisp (define put (alist-associator string-ci=?)) (define alist '()) (set! alist (put alist "Foo" 9)) @end lisp @end defun @defun alist-remover pred Returns a procedure of 2 arguments, @var{alist} and @var{key}, which returns an alist with an association whose @var{key} is key removed. This returned procedure may or may not have side effects on its @var{alist} argument. An example of correct usage is: @lisp (define rem (alist-remover string-ci=?)) (set! alist (rem alist "foo")) @end lisp @end defun @defun alist-map proc alist Returns a new association list formed by mapping @var{proc} over the keys and values of @var{alist}. @var{proc} must be a function of 2 arguments which returns the new value part. @end defun @defun alist-for-each proc alist Applies @var{proc} to each pair of keys and values of @var{alist}. @var{proc} must be a function of 2 arguments. The returned value is unspecified. @end defun slib-3b1/ANNOUNCE0000644001705200017500000001300710751452650011327 0ustar tbtbThis message announces the availability of Scheme Library release slib-3b1. SLIB is a portable Scheme library providing compatibiliy and utility functions for all standard Scheme implementations. SLIB supports Bigloo, Chez, ELK 3.0, GAMBIT 3.0, Guile, JScheme, MacScheme, MITScheme, PLT Scheme (DrScheme and MzScheme), Pocket Scheme, RScheme, scheme->C, Scheme48, SCM, SCM Mac, scsh, SISC, Stk, T3.1, umb-scheme, and VSCM. SLIB is free software. It has a Permissive-Non-Warranty license (http://swiss.csail.mit.edu/~jaffer/SLIB_COPYING.txt). Documentation and distributions in several formats are linked from SLIB's home page: http://swiss.csail.mit.edu/~jaffer/SLIB.html Links to distributions of SLIB and related softwares are at the end of this message. -=-=- slib-3b1 news: * Larceny (Scheme) is supported. From Ivan Shmakov: * scheme48.init (slib:os-strings): Fixed init for 1.7 (and 1.3). (defmacro:eval, defmacro:load): Fixed. From Rob Browning: * guile.init (implementation-vicinity): Just (%site-dir). (file-position, gentemp): module-replace! (library-vicinity): Try (%search-load-path "slib/guile.init"). From Aubrey Jaffer: * Logo and icon. * Added program-arguments to System-Interface section in Manual. * *.init: implementation-vicinity can be overridden by implementation-specific environment variable: MITSCHEME_IMPLEMENTATION_PATH VSCM_IMPLEMENTATION_PATH STK_IMPLEMENTATION_PATH RSCHEME_IMPLEMENTATION_PATH JSCHEME_IMPLEMENTATION_PATH GAMBIT_IMPLEMENTATION_PATH ELK_IMPLEMENTATION_PATH CHEZ_IMPLEMENTATION_PATH BIGLOO_IMPLEMENTATION_PATH GUILE_IMPLEMENTATION_PATH MZSCHEME_IMPLEMENTATION_PATH * FAQ, slib.spec, Makefile: Always put - between slib and version. * byte.scm: Rewritten based on uniform arrays. * random.scm (random): Err when passed negative number. * srfi-1.scm (lset<=): Fixed to use first argument. * transact.scm (word:lock!): Don't try to read file until after call-with-open-ports returns. (describe-file-lock): Handle case when file isn't locked. (windows:user-email-address): Much simplified; updated to Windows-XP from Windows-95. (describe-file-lock): Added diagnostic to current-error-port. * rdms.scm (open-table): Return #f for failure per documentation. * solid.scm (light:point, light:spot): Fixed. * prec.scm (prec:parse-delimited): First (recursive) clause was missing argument. * determ.scm (matrix:inverse, matrix->lists): Corrected documentation. * clrnamdb.scm, resenecolours.txt: Updated to Resene-2007. * slib.texi (Spectra): Clarified action of features cie1964, cie1931, and ciexyz. * glob.scm, slib.texi: Removed glob as alias for filename. * dirs.scm: Require 'filename instead of 'glob. * require.scm: Condition SRFI scan on srfi-0. * mklibcat.scm: Feature-name is srfi-0 (was srfi). * mbe.scm (macro:eval): defmacro:eval. (macro:load): defmacro:load. * defmacex.scm (defmacro:expand*): Use macroexpand instead of macroexpand-1 in preparation for macroexpand-1 deprecation. * slib.nsi: Added *.init files. * README (Implementation-specific Instructions): Updated. * scheme48.init (char-code-limit): 128; does ascii conversions. (1+, -1+): Removed; choked Scheme48-1.7. Added SRFIs as found in Scheme-48 release-notes. (scheme-implementation-version): Lose text after number. (program-arguments): Removed dummy definition. * scsh.init (program-arguments): Defined to command-line per http://practical-scheme.net/wiliki/schemexref.cgi?command-line (library-vicinity, implementation-vicinity): Find path once. * scheme2c.init, kawa.init, umbscheme.init (implementation-vicinity): find path once. * vscm.init (slib:features): Added macro. * RScheme.init (slib:features): Added defmacro. * mzscheme.init (slib:features): Added syntax-case. * guile.init, sisc.init (macro:load): slib:load-source. * umbscheme.init, pscheme.init (defmacro:eval, defmacro:load): Simplified. * kawa.init, mitscheme.init, bigloo.init, gambit.init, jscheme.init: (re)moved some comments. * Template.scm, t3.init, STk.init, macscheme.init, scheme2c.init, scsh.init, chez.init, elk.init (slib:features): Added defmacro. * guile.init ((ice-9 slib)): "ice-9/slib.scm" doesn't become valid (and shorter) until version guile-1.8.3. * mzscheme.init: Renamed from DrScheme.init. (slib:features): Added format. (slib:load-compiled): Handle SRFI requires. * Makefile (catalogs): Copy "mkpltcat.scm" to "mkimpcat.scm" in mzscheme's implementation-vicinity. (mkfiles): Added "mkpltcat.scm". * mkpltcat.scm: "mkimpcat.scm" for mzscheme which adds all supported SRFIs to the catalog. * Makefile (ciefiles): Separated from Scheme sourcefiles. (test): Unmaintained target removed. -=-=- SLIB is available from: http://swiss.csail.mit.edu/ftpdir/scm/slib-3b1.zip http://swiss.csail.mit.edu/ftpdir/scm/slib-3b1-1.noarch.rpm http://swiss.csail.mit.edu/ftpdir/scm/slib-3b1-1.exe swiss.csail.mit.edu:/pub/scm/slib-3b1.zip swiss.csail.mit.edu:/pub/scm/slib-3b1-1.noarch.rpm swiss.csail.mit.edu:/pub/scm/slib-3b1-1.exe SLIB-PSD is a portable debugger for Scheme (requires emacs editor): http://swiss.csail.mit.edu/ftpdir/scm/slib-psd1-3.tar.gz swiss.csail.mit.edu:/pub/scm/slib-psd1-3.tar.gz SCHELOG is an embedding of Prolog in Scheme+SLIB: http://www.ccs.neu.edu/home/dorai/schelog/schelog.html Programs for printing and viewing TexInfo documentation (which SLIB has) come with GNU Emacs or can be obtained via ftp from: ftp://ftp.gnu.org/pub/gnu/texinfo/texinfo-4.8.tar.gz slib-3b1/arraymap.scm0000644001705200017500000001246510627702713012525 0ustar tbtb;;;; "arraymap.scm", applicative routines for arrays in Scheme. ;;; Copyright (C) 1993, 2003 Aubrey Jaffer ; ;Permission to copy this software, to modify it, to redistribute it, ;to distribute modified versions, and to use it for any purpose is ;granted, subject to the following restrictions and understandings. ; ;1. Any copy made of this software must include this copyright notice ;in full. ; ;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; ;3. In conjunction with products arising from the use of this ;material, there shall be no use of my name in any advertising, ;promotional, or sales literature without prior written consent in ;each case. (require 'array) ;;@code{(require 'array-for-each)} ;;@ftindex array-for-each ;;@args array0 proc array1 @dots{} ;;@var{array1}, @dots{} must have the same number of dimensions as ;;@var{array0} and have a range for each index which includes the range ;;for the corresponding index in @var{array0}. @var{proc} is applied to ;;each tuple of elements of @var{array1} @dots{} and the result is stored ;;as the corresponding element in @var{array0}. The value returned is ;;unspecified. The order of application is unspecified. (define (array-map! ra0 proc . ras) (define (ramap rdims inds) (if (null? (cdr rdims)) (do ((i (+ -1 (car rdims)) (+ -1 i)) (is (cons (+ -1 (car rdims)) inds) (cons (+ -1 i) inds))) ((negative? i)) (apply array-set! ra0 (apply proc (map (lambda (ra) (apply array-ref ra is)) ras)) is)) (let ((crdims (cdr rdims))) (do ((i (+ -1 (car rdims)) (+ -1 i))) ((negative? i)) (ramap crdims (cons i inds)))))) (ramap (reverse (array-dimensions ra0)) '())) ;;@args prototype proc array1 array2 @dots{} ;;@var{array2}, @dots{} must have the same number of dimensions as ;;@var{array1} and have a range for each index which includes the ;;range for the corresponding index in @var{array1}. @var{proc} is ;;applied to each tuple of elements of @var{array1}, @var{array2}, ;;@dots{} and the result is stored as the corresponding element in a ;;new array of type @var{prototype}. The new array is returned. The ;;order of application is unspecified. (define (array-map prototype proc ra1 . ras) (define nra (apply make-array prototype (array-dimensions ra1))) (apply array-map! nra proc ra1 ras) nra) ;;@args proc array0 @dots{} ;;@var{proc} is applied to each tuple of elements of @var{array0} @dots{} ;;in row-major order. The value returned is unspecified. (define (array-for-each proc . ras) (define (rafe rdims inds) (if (null? (cdr rdims)) (let ((sdni (reverse (cons #f inds)))) (define lastpair (last-pair sdni)) (do ((i 0 (+ 1 i))) ((> i (+ -1 (car rdims)))) (set-car! lastpair i) (apply proc (map (lambda (ra) (apply array-ref ra sdni)) ras)))) (let ((crdims (cdr rdims)) (ll (+ -1 (car rdims)))) (do ((i 0 (+ 1 i))) ((> i ll)) (rafe crdims (cons i inds)))))) (rafe (array-dimensions (car ras)) '())) ;;@args array ;;Returns an array of lists of indexes for @var{array} such that, if ;;@var{li} is a list of indexes for which @var{array} is defined, ;;(equal? @var{li} (apply array-ref (array-indexes @var{array}) ;;@var{li})). (define (array-indexes ra) (let ((ra0 (apply make-array '#() (array-dimensions ra)))) (array-index-map! ra0 list) ra0)) ;;@args array proc ;;applies @var{proc} to the indices of each element of @var{array} in ;;turn. The value returned and the order of application are ;;unspecified. ;; ;;One can implement @var{array-index-map!} as ;;@example ;;(define (array-index-map! ra fun) ;; (array-index-for-each ;; ra ;; (lambda is (apply array-set! ra (apply fun is) is)))) ;;@end example (define (array-index-for-each ra fun) (define (ramap rdims inds) (if (null? (cdr rdims)) (do ((i (+ -1 (car rdims)) (+ -1 i)) (is (cons (+ -1 (car rdims)) inds) (cons (+ -1 i) inds))) ((negative? i)) (apply fun is)) (let ((crdims (cdr rdims))) (do ((i (+ -1 (car rdims)) (+ -1 i))) ((negative? i)) (ramap crdims (cons i inds)))))) (if (zero? (array-rank ra)) (fun) (ramap (reverse (array-dimensions ra)) '()))) ;;@args array proc ;;applies @var{proc} to the indices of each element of @var{array} in ;;turn, storing the result in the corresponding element. The value ;;returned and the order of application are unspecified. ;; ;;One can implement @var{array-indexes} as ;;@example ;;(define (array-indexes array) ;; (let ((ra (apply make-array '#() (array-dimensions array)))) ;; (array-index-map! ra (lambda x x)) ;; ra)) ;;@end example ;;Another example: ;;@example ;;(define (apl:index-generator n) ;; (let ((v (make-vector n 1))) ;; (array-index-map! v (lambda (i) i)) ;; v)) ;;@end example (define (array-index-map! ra fun) (array-index-for-each ra (lambda is (apply array-set! ra (apply fun is) is)))) ;;@args destination source ;;Copies every element from vector or array @var{source} to the ;;corresponding element of @var{destination}. @var{destination} must ;;have the same rank as @var{source}, and be at least as large in each ;;dimension. The order of copying is unspecified. (define (array:copy! dest source) (array-map! dest identity source)) slib-3b1/arraymap.txi0000644001705200017500000000532410747237373012553 0ustar tbtb@code{(require 'array-for-each)} @ftindex array-for-each @deffn {Procedure} array-map! array0 proc array1 @dots{} @var{array1}, @dots{} must have the same number of dimensions as @var{array0} and have a range for each index which includes the range for the corresponding index in @var{array0}. @var{proc} is applied to each tuple of elements of @var{array1} @dots{} and the result is stored as the corresponding element in @var{array0}. The value returned is unspecified. The order of application is unspecified. @end deffn @defun array-map prototype proc array1 array2 @dots{} @var{array2}, @dots{} must have the same number of dimensions as @var{array1} and have a range for each index which includes the range for the corresponding index in @var{array1}. @var{proc} is applied to each tuple of elements of @var{array1}, @var{array2}, @dots{} and the result is stored as the corresponding element in a new array of type @var{prototype}. The new array is returned. The order of application is unspecified. @end defun @defun array-for-each proc array0 @dots{} @var{proc} is applied to each tuple of elements of @var{array0} @dots{} in row-major order. The value returned is unspecified. @end defun @defun array-indexes array Returns an array of lists of indexes for @var{array} such that, if @var{li} is a list of indexes for which @var{array} is defined, (equal? @var{li} (apply array-ref (array-indexes @var{array}) @var{li})). @end defun @defun array-index-for-each array proc applies @var{proc} to the indices of each element of @var{array} in turn. The value returned and the order of application are unspecified. One can implement @var{array-index-map!} as @example (define (array-index-map! ra fun) (array-index-for-each ra (lambda is (apply array-set! ra (apply fun is) is)))) @end example @end defun @deffn {Procedure} array-index-map! array proc applies @var{proc} to the indices of each element of @var{array} in turn, storing the result in the corresponding element. The value returned and the order of application are unspecified. One can implement @var{array-indexes} as @example (define (array-indexes array) (let ((ra (apply make-array '#() (array-dimensions array)))) (array-index-map! ra (lambda x x)) ra)) @end example Another example: @example (define (apl:index-generator n) (let ((v (make-vector n 1))) (array-index-map! v (lambda (i) i)) v)) @end example @end deffn @deffn {Procedure} array:copy! destination source Copies every element from vector or array @var{source} to the corresponding element of @var{destination}. @var{destination} must have the same rank as @var{source}, and be at least as large in each dimension. The order of copying is unspecified. @end deffn slib-3b1/array.scm0000644001705200017500000004301610661142047012017 0ustar tbtb;;;;"array.scm" Arrays for Scheme ; Copyright (C) 2001, 2003, 2005, 2006 Aubrey Jaffer ; ;Permission to copy this software, to modify it, to redistribute it, ;to distribute modified versions, and to use it for any purpose is ;granted, subject to the following restrictions and understandings. ; ;1. Any copy made of this software must include this copyright notice ;in full. ; ;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; ;3. In conjunction with products arising from the use of this ;material, there shall be no use of my name in any advertising, ;promotional, or sales literature without prior written consent in ;each case. ;;@code{(require 'array)} or @code{(require 'srfi-63)} ;;@ftindex array (require 'record) (define array:rtd (make-record-type "array" '(dimensions scales ;list of dimension scales offset ;exact integer store ;data ))) (define array:dimensions (let ((dimensions (record-accessor array:rtd 'dimensions))) (lambda (array) (cond ((vector? array) (list (vector-length array))) ((string? array) (list (string-length array))) (else (dimensions array)))))) (define array:scales (let ((scales (record-accessor array:rtd 'scales))) (lambda (obj) (cond ((string? obj) '(1)) ((vector? obj) '(1)) (else (scales obj)))))) (define array:store (let ((store (record-accessor array:rtd 'store))) (lambda (obj) (cond ((string? obj) obj) ((vector? obj) obj) (else (store obj)))))) (define array:offset (let ((offset (record-accessor array:rtd 'offset))) (lambda (obj) (cond ((string? obj) 0) ((vector? obj) 0) (else (offset obj)))))) (define array:construct (record-constructor array:rtd '(dimensions scales offset store))) ;;@args obj ;;Returns @code{#t} if the @1 is an array, and @code{#f} if not. (define array? (let ((array:array? (record-predicate array:rtd))) (lambda (obj) (or (string? obj) (vector? obj) (array:array? obj))))) ;;@noindent ;;@emph{Note:} Arrays are not disjoint from other Scheme types. ;;Vectors and possibly strings also satisfy @code{array?}. ;;A disjoint array predicate can be written: ;; ;;@example ;;(define (strict-array? obj) ;; (and (array? obj) (not (string? obj)) (not (vector? obj)))) ;;@end example ;;@body ;;Returns @code{#t} if @1 and @2 have the same rank and dimensions and the ;;corresponding elements of @1 and @2 are @code{equal?}. ;;@body ;;@0 recursively compares the contents of pairs, vectors, strings, and ;;@emph{arrays}, applying @code{eqv?} on other objects such as numbers ;;and symbols. A rule of thumb is that objects are generally @0 if ;;they print the same. @0 may fail to terminate if its arguments are ;;circular data structures. ;; ;;@example ;;(equal? 'a 'a) @result{} #t ;;(equal? '(a) '(a)) @result{} #t ;;(equal? '(a (b) c) ;; '(a (b) c)) @result{} #t ;;(equal? "abc" "abc") @result{} #t ;;(equal? 2 2) @result{} #t ;;(equal? (make-vector 5 'a) ;; (make-vector 5 'a)) @result{} #t ;;(equal? (make-array (A:fixN32b 4) 5 3) ;; (make-array (A:fixN32b 4) 5 3)) @result{} #t ;;(equal? (make-array '#(foo) 3 3) ;; (make-array '#(foo) 3 3)) @result{} #t ;;(equal? (lambda (x) x) ;; (lambda (y) y)) @result{} @emph{unspecified} ;;@end example (define (equal? obj1 obj2) (cond ((eqv? obj1 obj2) #t) ((or (pair? obj1) (pair? obj2)) (and (pair? obj1) (pair? obj2) (equal? (car obj1) (car obj2)) (equal? (cdr obj1) (cdr obj2)))) ((and (string? obj1) (string? obj2)) (string=? obj1 obj2)) ((and (vector? obj1) (vector? obj2)) (and (equal? (vector-length obj1) (vector-length obj2)) (do ((idx (+ -1 (vector-length obj1)) (+ -1 idx))) ((or (negative? idx) (not (equal? (vector-ref obj1 idx) (vector-ref obj2 idx)))) (negative? idx))))) ((and (array? obj1) (array? obj2)) (and (equal? (array:dimensions obj1) (array:dimensions obj2)) (letrec ((rascan (lambda (dims idxs) (if (null? dims) (equal? (apply array-ref obj1 idxs) (apply array-ref obj2 idxs)) (do ((res #t (rascan (cdr dims) (cons idx idxs))) (idx (+ -1 (car dims)) (+ -1 idx))) ((or (not res) (negative? idx)) res)))))) (rascan (reverse (array:dimensions obj1)) '())))) (else #f))) ;;@body ;;Returns the number of dimensions of @1. If @1 is not an array, 0 is ;;returned. (define (array-rank obj) (if (array? obj) (length (array:dimensions obj)) 0)) ;;@args array ;;Returns a list of dimensions. ;; ;;@example ;;(array-dimensions (make-array '#() 3 5)) ;; @result{} (3 5) ;;@end example (define array-dimensions array:dimensions) ;;@args prototype k1 @dots{} ;; ;;Creates and returns an array of type @1 with dimensions @2, @dots{} ;;and filled with elements from @1. @1 must be an array, vector, or ;;string. The implementation-dependent type of the returned array ;;will be the same as the type of @1; except if that would be a vector ;;or string with rank not equal to one, in which case some variety of ;;array will be returned. ;; ;;If the @1 has no elements, then the initial contents of the returned ;;array are unspecified. Otherwise, the returned array will be filled ;;with the element at the origin of @1. (define (make-array prototype . dimensions) (define prot (array:store prototype)) (define pdims (array:dimensions prototype)) (define onedim? (eqv? 1 (length dimensions))) (define tcnt (apply * dimensions)) (let ((initializer (if (zero? (apply * pdims)) '() (list (apply array-ref prototype (map (lambda (x) 0) pdims)))))) (cond ((and onedim? (string? prot)) (apply make-string (car dimensions) initializer)) ((and onedim? (vector? prot)) (apply make-vector (car dimensions) initializer)) (else (let ((store (if (string? prot) (apply make-string tcnt initializer) (apply make-vector tcnt initializer)))) (define (loop dims scales) (if (null? dims) (array:construct dimensions (cdr scales) 0 store) (loop (cdr dims) (cons (* (car dims) (car scales)) scales)))) (loop (reverse dimensions) '(1))))))) ;;@args prototype k1 @dots{} ;;@0 is an alias for @code{make-array}. (define create-array make-array) ;;@args array mapper k1 @dots{} ;;@0 can be used to create shared subarrays of other ;;arrays. The @var{mapper} is a function that translates coordinates in ;;the new array into coordinates in the old array. A @var{mapper} must be ;;linear, and its range must stay within the bounds of the old array, but ;;it can be otherwise arbitrary. A simple example: ;; ;;@example ;;(define fred (make-array '#(#f) 8 8)) ;;(define freds-diagonal ;; (make-shared-array fred (lambda (i) (list i i)) 8)) ;;(array-set! freds-diagonal 'foo 3) ;;(array-ref fred 3 3) ;; @result{} FOO ;;(define freds-center ;; (make-shared-array fred (lambda (i j) (list (+ 3 i) (+ 3 j))) ;; 2 2)) ;;(array-ref freds-center 0 0) ;; @result{} FOO ;;@end example (define (make-shared-array array mapper . dimensions) (define odl (array:scales array)) (define rank (length dimensions)) (define shape (map (lambda (dim) (if (list? dim) dim (list 0 (+ -1 dim)))) dimensions)) (do ((idx (+ -1 rank) (+ -1 idx)) (uvt (if (zero? rank) '() (append (cdr (vector->list (make-vector rank 0))) '(1))) (append (cdr uvt) '(0))) (uvts '() (cons uvt uvts))) ((negative? idx) (let ((ker0 (apply + (map * odl (apply mapper uvt))))) (array:construct (map (lambda (dim) (+ 1 (- (cadr dim) (car dim)))) shape) (map (lambda (uvt) (- (apply + (map * odl (apply mapper uvt))) ker0)) uvts) (apply + (array:offset array) (map * odl (apply mapper (map car shape)))) (array:store array)))))) ;;@args rank proto list ;;@3 must be a rank-nested list consisting of all the elements, in ;;row-major order, of the array to be created. ;; ;;@0 returns an array of rank @1 and type @2 consisting of all the ;;elements, in row-major order, of @3. When @1 is 0, @3 is the lone ;;array element; not necessarily a list. ;; ;;@example ;;(list->array 2 '#() '((1 2) (3 4))) ;; @result{} #2A((1 2) (3 4)) ;;(list->array 0 '#() 3) ;; @result{} #0A 3 ;;@end example (define (list->array rank proto lst) (define dimensions (do ((shp '() (cons (length row) shp)) (row lst (car lst)) (rnk (+ -1 rank) (+ -1 rnk))) ((negative? rnk) (reverse shp)))) (let ((nra (apply make-array proto dimensions))) (define (l2ra dims idxs row) (cond ((null? dims) (apply array-set! nra row (reverse idxs))) ((if (not (eqv? (car dims) (length row))) (slib:error 'list->array 'non-rectangular 'array dims dimensions)) (do ((idx 0 (+ 1 idx)) (row row (cdr row))) ((>= idx (car dims))) (l2ra (cdr dims) (cons idx idxs) (car row)))))) (l2ra dimensions '() lst) nra)) ;;@args array ;;Returns a rank-nested list consisting of all the elements, in ;;row-major order, of @1. In the case of a rank-0 array, @0 returns ;;the single element. ;; ;;@example ;;(array->list #2A((ho ho ho) (ho oh oh))) ;; @result{} ((ho ho ho) (ho oh oh)) ;;(array->list #0A ho) ;; @result{} ho ;;@end example (define (array->list ra) (define (ra2l dims idxs) (if (null? dims) (apply array-ref ra (reverse idxs)) (do ((lst '() (cons (ra2l (cdr dims) (cons idx idxs)) lst)) (idx (+ -1 (car dims)) (+ -1 idx))) ((negative? idx) lst)))) (ra2l (array:dimensions ra) '())) ;;@args vect proto dim1 @dots{} ;;@1 must be a vector of length equal to the product of exact ;;nonnegative integers @3, @dots{}. ;; ;;@0 returns an array of type @2 consisting of all the elements, in ;;row-major order, of @1. In the case of a rank-0 array, @1 has a ;;single element. ;; ;;@example ;;(vector->array #(1 2 3 4) #() 2 2) ;; @result{} #2A((1 2) (3 4)) ;;(vector->array '#(3) '#()) ;; @result{} #0A 3 ;;@end example (define (vector->array vect prototype . dimensions) (define vdx (vector-length vect)) (if (not (eqv? vdx (apply * dimensions))) (slib:error 'vector->array vdx '<> (cons '* dimensions))) (let ((ra (apply make-array prototype dimensions))) (define (v2ra dims idxs) (cond ((null? dims) (set! vdx (+ -1 vdx)) (apply array-set! ra (vector-ref vect vdx) (reverse idxs))) (else (do ((idx (+ -1 (car dims)) (+ -1 idx))) ((negative? idx) vect) (v2ra (cdr dims) (cons idx idxs)))))) (v2ra dimensions '()) ra)) ;;@args array ;;Returns a new vector consisting of all the elements of @1 in ;;row-major order. ;; ;;@example ;;(array->vector #2A ((1 2)( 3 4))) ;; @result{} #(1 2 3 4) ;;(array->vector #0A ho) ;; @result{} #(ho) ;;@end example (define (array->vector ra) (define dims (array:dimensions ra)) (let* ((vdx (apply * dims)) (vect (make-vector vdx))) (define (ra2v dims idxs) (if (null? dims) (let ((val (apply array-ref ra (reverse idxs)))) (set! vdx (+ -1 vdx)) (vector-set! vect vdx val)) (do ((idx (+ -1 (car dims)) (+ -1 idx))) ((negative? idx) vect) (ra2v (cdr dims) (cons idx idxs))))) (ra2v dims '()) vect)) (define (array:in-bounds? array indices) (do ((bnds (array:dimensions array) (cdr bnds)) (idxs indices (cdr idxs))) ((or (null? bnds) (null? idxs) (not (integer? (car idxs))) (not (< -1 (car idxs) (car bnds)))) (and (null? bnds) (null? idxs))))) ;;@args array index1 @dots{} ;;Returns @code{#t} if its arguments would be acceptable to ;;@code{array-ref}. (define (array-in-bounds? array . indices) (array:in-bounds? array indices)) ;;@args array k1 @dots{} ;;Returns the (@2, @dots{}) element of @1. (define (array-ref array . indices) (define store (array:store array)) (or (array:in-bounds? array indices) (slib:error 'array-ref 'bad-indices indices)) ((if (string? store) string-ref vector-ref) store (apply + (array:offset array) (map * (array:scales array) indices)))) ;;@args array obj k1 @dots{} ;;Stores @2 in the (@3, @dots{}) element of @1. The value returned ;;by @0 is unspecified. (define (array-set! array obj . indices) (define store (array:store array)) (or (array:in-bounds? array indices) (slib:error 'array-set! 'bad-indices indices)) ((if (string? store) string-set! vector-set!) store (apply + (array:offset array) (map * (array:scales array) indices)) obj)) ;;@noindent ;;These functions return a prototypical uniform-array enclosing the ;;optional argument (which must be of the correct type). If the ;;uniform-array type is supported by the implementation, then it is ;;returned; defaulting to the next larger precision type; resorting ;;finally to vector. (define (make-prototype-checker name pred? creator) (lambda args (case (length args) ((1) (if (pred? (car args)) (creator (car args)) (slib:error name 'incompatible 'type (car args)))) ((0) (creator)) (else (slib:error name 'wrong 'number 'of 'args args))))) (define (integer-bytes?? n) (lambda (obj) (and (integer? obj) (exact? obj) (or (negative? n) (not (negative? obj))) (do ((num obj (quotient num 256)) (n (+ -1 (abs n)) (+ -1 n))) ((or (zero? num) (negative? n)) (zero? num)))))) ;;@defun A:floC128b z ;;@defunx A:floC128b ;;Returns an inexact 128.bit flonum complex uniform-array prototype. ;;@end defun (define A:floC128b (make-prototype-checker 'A:floC128b complex? vector)) ;;@defun A:floC64b z ;;@defunx A:floC64b ;;Returns an inexact 64.bit flonum complex uniform-array prototype. ;;@end defun (define A:floC64b (make-prototype-checker 'A:floC64b complex? vector)) ;;@defun A:floC32b z ;;@defunx A:floC32b ;;Returns an inexact 32.bit flonum complex uniform-array prototype. ;;@end defun (define A:floC32b (make-prototype-checker 'A:floC32b complex? vector)) ;;@defun A:floC16b z ;;@defunx A:floC16b ;;Returns an inexact 16.bit flonum complex uniform-array prototype. ;;@end defun (define A:floC16b (make-prototype-checker 'A:floC16b complex? vector)) ;;@defun A:floR128b x ;;@defunx A:floR128b ;;Returns an inexact 128.bit flonum real uniform-array prototype. ;;@end defun (define A:floR128b (make-prototype-checker 'A:floR128b real? vector)) ;;@defun A:floR64b x ;;@defunx A:floR64b ;;Returns an inexact 64.bit flonum real uniform-array prototype. ;;@end defun (define A:floR64b (make-prototype-checker 'A:floR64b real? vector)) ;;@defun A:floR32b x ;;@defunx A:floR32b ;;Returns an inexact 32.bit flonum real uniform-array prototype. ;;@end defun (define A:floR32b (make-prototype-checker 'A:floR32b real? vector)) ;;@defun A:floR16b x ;;@defunx A:floR16b ;;Returns an inexact 16.bit flonum real uniform-array prototype. ;;@end defun (define A:floR16b (make-prototype-checker 'A:floR16b real? vector)) ;;@defun A:floR128d q ;;@defunx A:floR128d ;;Returns an exact 128.bit decimal flonum rational uniform-array prototype. ;;@end defun (define A:floR128d (make-prototype-checker 'A:floR128d real? vector)) ;;@defun A:floR64d q ;;@defunx A:floR64d ;;Returns an exact 64.bit decimal flonum rational uniform-array prototype. ;;@end defun (define A:floR64d (make-prototype-checker 'A:floR64d real? vector)) ;;@defun A:floR32d q ;;@defunx A:floR32d ;;Returns an exact 32.bit decimal flonum rational uniform-array prototype. ;;@end defun (define A:floR32d (make-prototype-checker 'A:floR32d real? vector)) ;;@defun A:fixZ64b n ;;@defunx A:fixZ64b ;;Returns an exact binary fixnum uniform-array prototype with at least ;;64 bits of precision. ;;@end defun (define A:fixZ64b (make-prototype-checker 'A:fixZ64b (integer-bytes?? -8) vector)) ;;@defun A:fixZ32b n ;;@defunx A:fixZ32b ;;Returns an exact binary fixnum uniform-array prototype with at least ;;32 bits of precision. ;;@end defun (define A:fixZ32b (make-prototype-checker 'A:fixZ32b (integer-bytes?? -4) vector)) ;;@defun A:fixZ16b n ;;@defunx A:fixZ16b ;;Returns an exact binary fixnum uniform-array prototype with at least ;;16 bits of precision. ;;@end defun (define A:fixZ16b (make-prototype-checker 'A:fixZ16b (integer-bytes?? -2) vector)) ;;@defun A:fixZ8b n ;;@defunx A:fixZ8b ;;Returns an exact binary fixnum uniform-array prototype with at least ;;8 bits of precision. ;;@end defun (define A:fixZ8b (make-prototype-checker 'A:fixZ8b (integer-bytes?? -1) vector)) ;;@defun A:fixN64b k ;;@defunx A:fixN64b ;;Returns an exact non-negative binary fixnum uniform-array prototype with at ;;least 64 bits of precision. ;;@end defun (define A:fixN64b (make-prototype-checker 'A:fixN64b (integer-bytes?? 8) vector)) ;;@defun A:fixN32b k ;;@defunx A:fixN32b ;;Returns an exact non-negative binary fixnum uniform-array prototype with at ;;least 32 bits of precision. ;;@end defun (define A:fixN32b (make-prototype-checker 'A:fixN32b (integer-bytes?? 4) vector)) ;;@defun A:fixN16b k ;;@defunx A:fixN16b ;;Returns an exact non-negative binary fixnum uniform-array prototype with at ;;least 16 bits of precision. ;;@end defun (define A:fixN16b (make-prototype-checker 'A:fixN16b (integer-bytes?? 2) vector)) ;;@defun A:fixN8b k ;;@defunx A:fixN8b ;;Returns an exact non-negative binary fixnum uniform-array prototype with at ;;least 8 bits of precision. ;;@end defun (define A:fixN8b (make-prototype-checker 'A:fixN8b (integer-bytes?? 1) vector)) ;;@defun A:bool bool ;;@defunx A:bool ;;Returns a boolean uniform-array prototype. ;;@end defun (define A:bool (make-prototype-checker 'A:bool boolean? vector)) slib-3b1/array.txi0000644001705200017500000002047410747237373012060 0ustar tbtb@code{(require 'array)} or @code{(require 'srfi-63)} @ftindex array @defun array? obj Returns @code{#t} if the @var{obj} is an array, and @code{#f} if not. @end defun @noindent @emph{Note:} Arrays are not disjoint from other Scheme types. Vectors and possibly strings also satisfy @code{array?}. A disjoint array predicate can be written: @example (define (strict-array? obj) (and (array? obj) (not (string? obj)) (not (vector? obj)))) @end example @defun equal? obj1 obj2 Returns @code{#t} if @var{obj1} and @var{obj2} have the same rank and dimensions and the corresponding elements of @var{obj1} and @var{obj2} are @code{equal?}. @code{equal?} recursively compares the contents of pairs, vectors, strings, and @emph{arrays}, applying @code{eqv?} on other objects such as numbers and symbols. A rule of thumb is that objects are generally @code{equal?} if they print the same. @code{equal?} may fail to terminate if its arguments are circular data structures. @example (equal? 'a 'a) @result{} #t (equal? '(a) '(a)) @result{} #t (equal? '(a (b) c) '(a (b) c)) @result{} #t (equal? "abc" "abc") @result{} #t (equal? 2 2) @result{} #t (equal? (make-vector 5 'a) (make-vector 5 'a)) @result{} #t (equal? (make-array (A:fixN32b 4) 5 3) (make-array (A:fixN32b 4) 5 3)) @result{} #t (equal? (make-array '#(foo) 3 3) (make-array '#(foo) 3 3)) @result{} #t (equal? (lambda (x) x) (lambda (y) y)) @result{} @emph{unspecified} @end example @end defun @defun array-rank obj Returns the number of dimensions of @var{obj}. If @var{obj} is not an array, 0 is returned. @end defun @defun array-dimensions array Returns a list of dimensions. @example (array-dimensions (make-array '#() 3 5)) @result{} (3 5) @end example @end defun @defun make-array prototype k1 @dots{} Creates and returns an array of type @var{prototype} with dimensions @var{k1}, @dots{} and filled with elements from @var{prototype}. @var{prototype} must be an array, vector, or string. The implementation-dependent type of the returned array will be the same as the type of @var{prototype}; except if that would be a vector or string with rank not equal to one, in which case some variety of array will be returned. If the @var{prototype} has no elements, then the initial contents of the returned array are unspecified. Otherwise, the returned array will be filled with the element at the origin of @var{prototype}. @end defun @defun create-array prototype k1 @dots{} @code{create-array} is an alias for @code{make-array}. @end defun @defun make-shared-array array mapper k1 @dots{} @code{make-shared-array} can be used to create shared subarrays of other arrays. The @var{mapper} is a function that translates coordinates in the new array into coordinates in the old array. A @var{mapper} must be linear, and its range must stay within the bounds of the old array, but it can be otherwise arbitrary. A simple example: @example (define fred (make-array '#(#f) 8 8)) (define freds-diagonal (make-shared-array fred (lambda (i) (list i i)) 8)) (array-set! freds-diagonal 'foo 3) (array-ref fred 3 3) @result{} FOO (define freds-center (make-shared-array fred (lambda (i j) (list (+ 3 i) (+ 3 j))) 2 2)) (array-ref freds-center 0 0) @result{} FOO @end example @end defun @defun list->array rank proto list @var{list} must be a rank-nested list consisting of all the elements, in row-major order, of the array to be created. @code{list->array} returns an array of rank @var{rank} and type @var{proto} consisting of all the elements, in row-major order, of @var{list}. When @var{rank} is 0, @var{list} is the lone array element; not necessarily a list. @example (list->array 2 '#() '((1 2) (3 4))) @result{} #2A((1 2) (3 4)) (list->array 0 '#() 3) @result{} #0A 3 @end example @end defun @defun array->list array Returns a rank-nested list consisting of all the elements, in row-major order, of @var{array}. In the case of a rank-0 array, @code{array->list} returns the single element. @example (array->list #2A((ho ho ho) (ho oh oh))) @result{} ((ho ho ho) (ho oh oh)) (array->list #0A ho) @result{} ho @end example @end defun @defun vector->array vect proto dim1 @dots{} @var{vect} must be a vector of length equal to the product of exact nonnegative integers @var{dim1}, @dots{}. @code{vector->array} returns an array of type @var{proto} consisting of all the elements, in row-major order, of @var{vect}. In the case of a rank-0 array, @var{vect} has a single element. @example (vector->array #(1 2 3 4) #() 2 2) @result{} #2A((1 2) (3 4)) (vector->array '#(3) '#()) @result{} #0A 3 @end example @end defun @defun array->vector array Returns a new vector consisting of all the elements of @var{array} in row-major order. @example (array->vector #2A ((1 2)( 3 4))) @result{} #(1 2 3 4) (array->vector #0A ho) @result{} #(ho) @end example @end defun @defun array-in-bounds? array index1 @dots{} Returns @code{#t} if its arguments would be acceptable to @code{array-ref}. @end defun @defun array-ref array k1 @dots{} Returns the (@var{k1}, @dots{}) element of @var{array}. @end defun @deffn {Procedure} array-set! array obj k1 @dots{} Stores @var{obj} in the (@var{k1}, @dots{}) element of @var{array}. The value returned by @code{array-set!} is unspecified. @end deffn @noindent These functions return a prototypical uniform-array enclosing the optional argument (which must be of the correct type). If the uniform-array type is supported by the implementation, then it is returned; defaulting to the next larger precision type; resorting finally to vector. @defun A:floC128b z @defunx A:floC128b Returns an inexact 128.bit flonum complex uniform-array prototype. @end defun @defun A:floC64b z @defunx A:floC64b Returns an inexact 64.bit flonum complex uniform-array prototype. @end defun @defun A:floC32b z @defunx A:floC32b Returns an inexact 32.bit flonum complex uniform-array prototype. @end defun @defun A:floC16b z @defunx A:floC16b Returns an inexact 16.bit flonum complex uniform-array prototype. @end defun @defun A:floR128b x @defunx A:floR128b Returns an inexact 128.bit flonum real uniform-array prototype. @end defun @defun A:floR64b x @defunx A:floR64b Returns an inexact 64.bit flonum real uniform-array prototype. @end defun @defun A:floR32b x @defunx A:floR32b Returns an inexact 32.bit flonum real uniform-array prototype. @end defun @defun A:floR16b x @defunx A:floR16b Returns an inexact 16.bit flonum real uniform-array prototype. @end defun @defun A:floR128d q @defunx A:floR128d Returns an exact 128.bit decimal flonum rational uniform-array prototype. @end defun @defun A:floR64d q @defunx A:floR64d Returns an exact 64.bit decimal flonum rational uniform-array prototype. @end defun @defun A:floR32d q @defunx A:floR32d Returns an exact 32.bit decimal flonum rational uniform-array prototype. @end defun @defun A:fixZ64b n @defunx A:fixZ64b Returns an exact binary fixnum uniform-array prototype with at least 64 bits of precision. @end defun @defun A:fixZ32b n @defunx A:fixZ32b Returns an exact binary fixnum uniform-array prototype with at least 32 bits of precision. @end defun @defun A:fixZ16b n @defunx A:fixZ16b Returns an exact binary fixnum uniform-array prototype with at least 16 bits of precision. @end defun @defun A:fixZ8b n @defunx A:fixZ8b Returns an exact binary fixnum uniform-array prototype with at least 8 bits of precision. @end defun @defun A:fixN64b k @defunx A:fixN64b Returns an exact non-negative binary fixnum uniform-array prototype with at least 64 bits of precision. @end defun @defun A:fixN32b k @defunx A:fixN32b Returns an exact non-negative binary fixnum uniform-array prototype with at least 32 bits of precision. @end defun @defun A:fixN16b k @defunx A:fixN16b Returns an exact non-negative binary fixnum uniform-array prototype with at least 16 bits of precision. @end defun @defun A:fixN8b k @defunx A:fixN8b Returns an exact non-negative binary fixnum uniform-array prototype with at least 8 bits of precision. @end defun @defun A:bool bool @defunx A:bool Returns a boolean uniform-array prototype. @end defun slib-3b1/batch.scm0000644001705200017500000003753410611045107011764 0ustar tbtb;;; "batch.scm" Group and execute commands on various systems. ;Copyright (C) 1994, 1995, 1997, 2004 Aubrey Jaffer ; ;Permission to copy this software, to modify it, to redistribute it, ;to distribute modified versions, and to use it for any purpose is ;granted, subject to the following restrictions and understandings. ; ;1. Any copy made of this software must include this copyright notice ;in full. ; ;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; ;3. In conjunction with products arising from the use of this ;material, there shall be no use of my name in any advertising, ;promotional, or sales literature without prior written consent in ;each case. (require 'tree) (require 'line-i/o) ;Just for write-line (require 'databases) (require 'parameters) (require 'string-port) (require 'pretty-print) (require 'common-list-functions) (require-if '(and bignum compiling) 'posix-time) (define system (if (provided? 'system) system (lambda (str) 1))) (define system:success? (case (software-type) ((vms) (lambda (int) (eqv? 1 int))) (else zero?))) ;;(trace system system:success? exit quit slib:exit) (define (batch:port parms) (let ((bp (parameter-list-ref parms 'batch-port))) (cond ((or (not (pair? bp)) (not (output-port? (car bp)))) (slib:warn 'batch-line "missing batch-port parameter" bp) (current-output-port)) (else (car bp))))) (define (batch:dialect parms) ; was batch-family (car (parameter-list-ref parms 'batch-dialect))) (define (batch:operating-system parms) (car (parameter-list-ref parms 'operating-system))) (define (batch-line parms str) (define line-limit (batch:line-length-limit parms)) (define port (batch:port parms)) (cond ((and line-limit (>= (string-length str) line-limit)) (let ((msg (string-append "batch line is too long " (number->string (string-length str)) " > " (number->string line-limit)))) (batch:comment parms (string-append "WARN: " msg)) (if (not (eq? port (current-output-port))) (slib:warn msg))))) (write-line str port) #t) ;;; add a Scheme batch-dialect? ;@ (define (batch:try-chopped-command parms . args) (define args-but-last (batch:flatten (butlast args 1))) (define line-limit (batch:line-length-limit parms)) (let loop ((fodder (car (last-pair args)))) (let ((str (batch:glued-line parms (batch:flatten (append args-but-last (list fodder)))))) (cond ((< (string-length str) line-limit) (batch:try-command parms str)) ((< (length fodder) 2) (slib:warn 'batch:try-chopped-command "can't fit in " line-limit (append args-but-last (list fodder))) #f) (else (let ((hlen (quotient (length fodder) 2))) (and (loop (last fodder hlen)) (loop (butlast fodder hlen))))))))) (define (batch:glued-line parms strings) (case (batch:dialect parms) ((vms) (apply string-join " " "$" strings)) ((unix dos amigaos system *unknown*) (apply string-join " " strings)) (else #f))) ;@ (define (batch:try-command parms . strings) (set! strings (batch:flatten strings)) (let ((line (batch:glued-line parms strings))) (and line (case (batch:dialect parms) ((unix dos vms amigaos) (batch-line parms line)) ((system) (let ((port (batch:port parms))) (write `(system ,line) port) (newline port) (and (provided? 'system) (system:success? (system line))))) ((*unknown*) (let ((port (batch:port parms))) (write `(system ,line) port) (newline port) #t)) (else #f))))) ;@ (define (batch:command parms . strings) (cond ((apply batch:try-command parms strings)) (else (slib:error 'batch:command 'failed strings)))) ;@ (define (batch:run-script parms name . strings) (case (batch:dialect parms strings) ((vms) (batch:command parms (string-append "@" name) strings)) (else (batch:command parms name strings)))) (define (batch:comment-prefix dialect) (case dialect ((unix) "# ") ((dos) "rem ") ((vms) "$! ") ((amigaos) "; ") ((system) "; ") ((*unknown*) ";;; "))) ;;; Comment lines usually don't have a length limit. (define (batch:write-comment-line dialect line port) (write-line (string-append (batch:comment-prefix dialect) line) port) #t) ;@ (define (batch:comment parms . lines) (define port (batch:port parms)) (define dialect (batch:dialect parms)) (set! lines (batch:flatten lines)) (every (lambda (line) (batch:write-comment-line dialect line port)) lines)) ;@ (define (batch:lines->file parms file . lines) (define port (batch:port parms)) (set! lines (batch:flatten lines)) (case (or (batch:dialect parms) '*unknown*) ((unix) (batch-line parms (string-append "rm -f " file)) (every (lambda (string) (batch-line parms (string-append "echo '" string "'>>" file))) lines)) ((dos) (batch-line parms (string-append "DEL " file)) (every (lambda (string) (batch-line parms (string-append "ECHO" (if (equal? "" string) "." " ") string ">>" file))) lines)) ((vms) (and (batch-line parms (string-append "$DELETE " file)) (batch-line parms (string-append "$CREATE " file)) (batch-line parms (string-append "$DECK")) (every (lambda (string) (batch-line parms string)) lines) (batch-line parms (string-append "$EOD")))) ((amigaos) (batch-line parms (string-append "delete force " file)) (every (lambda (str) (letrec ((star-quote (lambda (str) (if (equal? "" str) str (let* ((ch (string-ref str 0)) (s (if (char=? ch #\") (string #\* ch) (string ch)))) (string-append s (star-quote (substring str 1 (string-length str))))))))) (batch-line parms (string-append "echo \"" (star-quote str) "\" >> " file)))) lines)) ((system) (write `(delete-file ,file) port) (newline port) (delete-file file) (pretty-print `(call-with-output-file ,file (lambda (fp) (for-each (lambda (string) (write-line string fp)) ',lines))) port) (call-with-output-file file (lambda (fp) (for-each (lambda (string) (write-line string fp)) lines))) #t) ((*unknown*) (write `(delete-file ,file) port) (newline port) (pretty-print `(call-with-output-file ,file (lambda (fp) (for-each (lambda (string) (write-line string fp)) ,lines))) port) #f))) ;@ (define (batch:delete-file parms file) (define port (batch:port parms)) (case (batch:dialect parms) ((unix) (batch-line parms (string-append "rm -f " file)) #t) ((dos) (batch-line parms (string-append "DEL " file)) #t) ((vms) (batch-line parms (string-append "$DELETE " file)) #t) ((amigaos) (batch-line parms (string-append "delete force " file)) #t) ((system) (write `(delete-file ,file) port) (newline port) (delete-file file)) ; SLIB provides ((*unknown*) (write `(delete-file ,file) port) (newline port) #f))) ;@ (define (batch:rename-file parms old-name new-name) (define port (batch:port parms)) (case (batch:dialect parms) ((unix) (batch-line parms (string-join " " "mv -f" old-name new-name))) ;;((dos) (batch-line parms (string-join " " "REN" old-name new-name))) ((dos) (batch-line parms (string-join " " "MOVE" "/Y" old-name new-name))) ((vms) (batch-line parms (string-join " " "$RENAME" old-name new-name))) ((amigaos) (batch-line parms (string-join " " "failat 21")) (batch-line parms (string-join " " "delete force" new-name)) (batch-line parms (string-join " " "rename" old-name new-name))) ((system) (batch:extender 'rename-file batch:rename-file)) ((*unknown*) (write `(rename-file ,old-name ,new-name) port) (newline port) #f))) (define (batch:write-header-comment parms name port) (define dialect (batch:dialect parms)) (define operating-system (or (batch:operating-system parms) *operating-system*)) (batch:write-comment-line dialect (string-append (if (string? name) (string-append "\"" name "\"") (case dialect ((system *unknown*) "Scheme") ((vms) "VMS") ((dos) "DOS") ((default-for-platform) "??") (else (symbol->string dialect)))) " (" (symbol->string operating-system) ")" " script created by SLIB/batch " (cond ((provided? 'bignum) (require 'posix-time) (let ((ct (ctime (current-time)))) (substring ct 0 (+ -1 (string-length ct))))) (else ""))) port)) ;@ (define (batch:call-with-output-script parms name proc) (define dialect (batch:dialect parms)) (define operating-system (or (batch:operating-system parms) *operating-system*)) (case dialect ((unix) ((cond ((and (string? name) (provided? 'system)) (lambda (proc) (let ((ans (call-with-output-file name proc))) (system (string-append "chmod +x '" name "'")) ans))) ((output-port? name) (lambda (proc) (proc name))) (else (lambda (proc) (proc (current-output-port))))) (lambda (port) (write-line (if (eq? 'plan9 operating-system) "#! /bin/rc" "#! /bin/sh") port) (batch:write-header-comment parms name port) (proc port)))) ((dos) ((cond ((string? name) (lambda (proc) (call-with-output-file (string-append name ".bat") proc))) ((output-port? name) (lambda (proc) (proc name))) (else (lambda (proc) (proc (current-output-port))))) (lambda (port) (batch:write-header-comment parms name port) (proc port)))) ((vms) ((cond ((string? name) (lambda (proc) (call-with-output-file (string-append name ".COM") proc))) ((output-port? name) (lambda (proc) (proc name))) (else (lambda (proc) (proc (current-output-port))))) (lambda (port) (batch:write-header-comment parms name port) ;;(write-line "$DEFINE/USER SYS$OUTPUT BUILD.LOG" port) (proc port)))) ((amigaos) ((cond ((and (string? name) (provided? 'system)) (lambda (proc) (let ((ans (call-with-output-file name proc))) (system (string-append "protect " name " rswd")) ans))) ((output-port? name) (lambda (proc) (proc name))) (else (lambda (proc) (proc (current-output-port))))) (lambda (port) (batch:write-header-comment parms name port) (proc port)))) ((system) ((cond ((and (string? name) (provided? 'system)) (lambda (proc) (let ((ans (call-with-output-file name (lambda (port) (proc name))))) (system (string-append "chmod +x " name)) ans))) ((output-port? name) (lambda (proc) (proc name))) (else (lambda (proc) (proc (current-output-port))))) (lambda (port) (batch:write-header-comment parms name port) (proc port)))) ((*unknown*) ((cond ((and (string? name) (provided? 'system)) (lambda (proc) (let ((ans (call-with-output-file name (lambda (port) (proc name))))) (system (string-append "chmod +x " name)) ans))) ((output-port? name) (lambda (proc) (proc name))) (else (lambda (proc) (proc (current-output-port))))) (lambda (port) (batch:write-header-comment parms name port) (proc port)))))) ;;; This little ditty figures out how to use a Scheme extension or ;;; SYSTEM to execute a command that is not available in the batch ;;; mode chosen. (define (batch:extender NAME BATCHER) (lambda (parms . args) (define port (batch:port parms)) (cond ((provided? 'i/o-extensions) ; SCM specific (write `(,NAME ,@args) port) (newline port) (apply (slib:eval NAME) args)) ((not (provided? 'system)) #f) (else (let ((pl (make-parameter-list (map car parms)))) (adjoin-parameters! pl (cons 'batch-dialect (os->batch-dialect (parameter-list-ref parms 'operating-system)))) (system (call-with-output-string (lambda (port) (batch:call-with-output-script port (lambda (batch-port) (define new-parms (copy-tree pl)) (adjoin-parameters! new-parms (list 'batch-port batch-port)) (apply BATCHER new-parms args))))))))))) ;@ (define (truncate-up-to str chars) (define (tut str) (do ((i (string-length str) (+ -1 i))) ((or (zero? i) (memv (string-ref str (+ -1 i)) chars)) (substring str i (string-length str))))) (cond ((char? chars) (set! chars (list chars))) ((string? chars) (set! chars (string->list chars)))) (if (string? str) (tut str) (map tut str))) ;@ (define (must-be-first firsts lst) (append (remove-if-not (lambda (i) (member i lst)) firsts) (remove-if (lambda (i) (member i firsts)) lst))) ;@ (define (must-be-last lst lasts) (append (remove-if (lambda (i) (member i lasts)) lst) (remove-if-not (lambda (i) (member i lst)) lasts))) ;@ (define (string-join joiner . args) (if (null? args) "" (apply string-append (car args) (map (lambda (s) (string-append joiner s)) (cdr args))))) (define (batch:flatten strings) (apply append (map (lambda (obj) (cond ((eq? "" obj) '()) ((string? obj) (list obj)) ((eq? #f obj) '()) ((null? obj) '()) ((list? obj) (batch:flatten obj)) (else (slib:error 'batch:flatten "unexpected type" obj "in" strings)))) strings))) (define batch:database #f) (define batch-dialect->line-length-limit #f) ;@ (define os->batch-dialect #f) (define (batch:line-length-limit parms) (let ((bl (parameter-list-ref parms 'batch-line-length-limit))) (if bl (car bl) (batch-dialect->line-length-limit (batch:dialect parms))))) ;@ (define (batch:initialize! database) (set! batch:database database) (define-tables database '(batch-dialect ((family atom)) ((line-length-limit number)) ((unix 1023) (dos 127) (vms 1023) (amigaos 511) (system 1023) (*unknown* -1))) '(operating-system ((name symbol)) ((os-family batch-dialect)) (;;(3b1 *unknown*) (*unknown* *unknown*) (acorn *unknown*) (aix unix) (alliant *unknown*) (amiga amigaos) (apollo unix) (apple2 *unknown*) (arm *unknown*) (atari.st *unknown*) (atari-st *unknown*) (cdc *unknown*) (celerity *unknown*) (concurrent *unknown*) (convex *unknown*) (darwin unix) (encore *unknown*) (harris *unknown*) (hp-ux unix) (hp48 *unknown*) (irix unix) (isis *unknown*) (linux unix) (mac *unknown*) (masscomp unix) (mips *unknown*) (ms-dos dos) (ncr *unknown*) (newton *unknown*) (next unix) (novell *unknown*) (os/2 dos) (osf1 unix) (plan9 unix) (prime *unknown*) (psion *unknown*) (pyramid *unknown*) (sequent *unknown*) (sgi *unknown*) (stratus *unknown*) (sunos unix) (transputer *unknown*) (unicos unix) (unix unix) (vms vms) ))) (define-domains database '(operating-system operating-system #f symbol #f)) (set! os->batch-dialect (((batch:database 'open-table) 'operating-system #f) 'get 'os-family)) (set! batch-dialect->line-length-limit (((batch:database 'open-table) 'batch-dialect #f) 'get 'line-length-limit)) ) ;@ (define *operating-system* (cond ((and (eq? 'unix (software-type)) (provided? 'system)) (let* ((file-name (tmpnam)) (uname (and (system (string-append "uname > " file-name)) (call-with-input-file file-name read))) (ustr (and (symbol? uname) (symbol->string uname)))) (delete-file file-name) (cond ((and ustr (> (string-length ustr) 5) (string-ci=? "cygwin" (substring ustr 0 6))) 'gnu-win32) ((and ustr (> (string-length ustr) 4) (string-ci=? "mingw" (substring ustr 0 5))) 'gnu-win32) (ustr uname) (else (software-type))))) (else (software-type)))) slib-3b1/Bev2slib.scm0000644001705200017500000000570307776076455012400 0ustar tbtb;;;; "Bev2slib.scm" Build SLIB catalogs for Stephen Bevan's libraries. ;Copyright (C) 1998 Aubrey Jaffer ; ;Permission to copy this software, to modify it, to redistribute it, ;to distribute modified versions, and to use it for any purpose is ;granted, subject to the following restrictions and understandings. ; ;1. Any copy made of this software must include this copyright notice ;in full. ; ;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; ;3. In conjunction with products arising from the use of this ;material, there shall be no use of my name in any advertising, ;promotional, or sales literature without prior written consent in ;each case. ;;; Put this file into the implementation-vicinity directory for your ;;; scheme implementation. ;;; Add the line ;;; (load (in-vicinity (implementation-vicinity) "Bev2slib.scm")) ;;; to "mkimpcat.scm" ;;; Delete "slibcat" in your implementation-vicinity. ;;; Bind `Bevan-dir' to the directory containing directories "bawk", ;;; "mawk", "pathname", etc. Bev2slib.scm will put entries into the ;;; catalog only for those directories and files which exist. (let ((Bevan-dir (in-vicinity (library-vicinity) "../"));"/usr/local/lib/Bevan/" (catname "sitecat")) (call-with-output-file (in-vicinity (implementation-vicinity) catname) (lambda (op) (define (display* . args) (for-each (lambda (arg) (display arg op)) args) (newline op)) (define (add-alias from to) (display " " op) (write (cons from to) op) (newline op)) (begin (display* ";\"" catname "\" Site-specific SLIB catalog for " (scheme-implementation-type) (scheme-implementation-version) ". -*-scheme-*-") (display* ";") (display* "; DO NOT EDIT THIS FILE") (display* "; it is automagically generated by \"Bev2slib.scm\"") (newline op) ) ;; Output association lists to file "sitecat" (for-each (lambda (dir) (let* ((vic (in-vicinity Bevan-dir (string-append dir "/"))) (map-file (in-vicinity vic (string-append dir ".map")))) (display* ";;; from " map-file) (display* "(") (and (file-exists? map-file) (call-with-input-file map-file (lambda (ip) (define files '()) (do ((feature (read ip) (read ip))) ((eof-object? feature)) (let* ((type (read ip)) (file (read ip)) (fsym (string->symbol (string-append "Req::" file)))) (and (not (assq fsym files)) (set! files (cons (cons fsym file) files))) (add-alias feature fsym))) (for-each (lambda (pr) (add-alias (car pr) (in-vicinity vic (cdr pr)))) files) ))) (display* ")"))) '("char-set" "conc-string" "string" "string-03" "avl-tree" "avl-trie" "bawk" "mawk" "pathname")) (begin (display* "(") (add-alias 'btree (in-vicinity Bevan-dir "bawk/btree")) (add-alias 'read-line 'line-i/o) (display* ")") )))) slib-3b1/bigloo.init0000644001705200017500000003170710733633204012341 0ustar tbtb;; "bigloo.init" Initialization for SLIB for Bigloo -*-scheme-*- ;;; Author: Aubrey Jaffer ;;; ;;; This code is in the public domain. ;;@ (software-type) should be set to the generic operating system type. ;;; UNIX, VMS, MACOS, AMIGA and MS-DOS are supported. (define (software-type) 'unix) ;;@ (scheme-implementation-type) should return the name of the scheme ;;; implementation loading this file. (define (scheme-implementation-type) 'Bigloo) ;;@ (scheme-implementation-home-page) should return a (string) URI ;;; (Uniform Resource Identifier) for this scheme implementation's home ;;; page; or false if there isn't one. (define (scheme-implementation-home-page) "http://www-sop.inria.fr/mimosa/fp/Bigloo/") ;;@ (scheme-implementation-version) should return a string describing ;;; the version the scheme implementation loading this file. (define (scheme-implementation-version) *bigloo-version*) ;;@ (implementation-vicinity) should be defined to be the pathname of ;;; the directory where any auxillary files to your Scheme ;;; implementation reside. (define implementation-vicinity (let ((impl-path (or (getenv "BIGLOO_IMPLEMENTATION_PATH") (case (software-type) ((unix) (string-append *default-lib-dir* "/")) ((ms-dos) "C:\\scheme\\") (else ""))))) (lambda () impl-path))) ;;@ (library-vicinity) should be defined to be the pathname of the ;;; directory where files of Scheme library functions reside. (define library-vicinity (let ((library-path (or ;; Use this getenv if your implementation supports it. (getenv "SCHEME_LIBRARY_PATH") ;; Use this path if your scheme does not support GETENV ;; or if SCHEME_LIBRARY_PATH is not set. (case (software-type) ((unix) (cond ((directory? "/usr/share/slib/") "/usr/share/slib/") ((directory? "/usr/local/lib/slib/") "/usr/local/lib/slib/") (else ""))) ((ms-dos) "C:\\SLIB\\") (else ""))))) (lambda () library-path))) ;;@ (home-vicinity) should return the vicinity of the user's HOME ;;; directory, the directory which typically contains files which ;;; customize a computer environment for a user. (define (home-vicinity) (let ((home (getenv "HOME"))) (and home (case (software-type) ((unix coherent ms-dos) ;V7 unix has a / on HOME (if (eqv? #\/ (string-ref home (+ -1 (string-length home)))) home (string-append home "/"))) (else home))))) ;@ (define in-vicinity string-append) ;@ (define (user-vicinity) (case (software-type) ((vms) "[.]") (else ""))) (define *load-pathname* #f) ;@ (define vicinity:suffix? (let ((suffi (case (software-type) ((amiga) '(#\: #\/)) ((macos thinkc) '(#\:)) ((ms-dos windows atarist os/2) '(#\\ #\/)) ((nosve) '(#\: #\.)) ((unix coherent plan9) '(#\/)) ((vms) '(#\: #\])) (else (slib:warn "require.scm" 'unknown 'software-type (software-type)) "/")))) (lambda (chr) (and (memv chr suffi) #t)))) ;@ (define (pathname->vicinity pathname) (let loop ((i (- (string-length pathname) 1))) (cond ((negative? i) "") ((vicinity:suffix? (string-ref pathname i)) (substring pathname 0 (+ i 1))) (else (loop (- i 1)))))) (define (program-vicinity) (if *load-pathname* (pathname->vicinity *load-pathname*) (slib:error 'program-vicinity " called; use slib:load to load"))) ;@ (define sub-vicinity (case (software-type) ((vms) (lambda (vic name) (let ((l (string-length vic))) (if (or (zero? (string-length vic)) (not (char=? #\] (string-ref vic (- l 1))))) (string-append vic "[" name "]") (string-append (substring vic 0 (- l 1)) "." name "]"))))) (else (let ((*vicinity-suffix* (case (software-type) ((nosve) ".") ((macos thinkc) ":") ((ms-dos windows atarist os/2) "\\") ((unix coherent plan9 amiga) "/")))) (lambda (vic name) (string-append vic name *vicinity-suffix*)))))) ;@ (define (make-vicinity ) ) ;@ (define with-load-pathname (let ((exchange (lambda (new) (let ((old *load-pathname*)) (set! *load-pathname* new) old)))) (lambda (path thunk) (let* ((old (exchange path)) (val (thunk))) (exchange old) val)))) ;;@ SLIB:FEATURES is a list of symbols naming the (SLIB) features ;;; initially supported by this implementation. (define slib:features '( source ;can load scheme source files ;(SLIB:LOAD-SOURCE "filename") ;;; compiled ;can load compiled files ;(SLIB:LOAD-COMPILED "filename") vicinity srfi-59 srfi-96 ;; Scheme report features ;; R5RS-compliant implementations should provide all 9 features. ;;; r5rs ;conforms to eval ;R5RS two-argument eval ;;; values ;R5RS multiple values ;;; dynamic-wind ;R5RS dynamic-wind ;;; macro ;R5RS high level macros delay ;has DELAY and FORCE multiarg-apply ;APPLY can take more than 2 args. ;;; char-ready? rev4-optional-procedures ;LIST-TAIL, STRING-COPY, ;STRING-FILL!, and VECTOR-FILL! ;; These four features are optional in both R4RS and R5RS multiarg/and- ;/ and - can take more than 2 args. ;;; rationalize transcript ;TRANSCRIPT-ON and TRANSCRIPT-OFF with-file ;has WITH-INPUT-FROM-FILE and ;WITH-OUTPUT-TO-FILE r4rs ;conforms to ieee-p1178 ;conforms to r3rs ;conforms to ;;; rev2-procedures ;SUBSTRING-MOVE-LEFT!, ;SUBSTRING-MOVE-RIGHT!, ;SUBSTRING-FILL!, ;STRING-NULL?, APPEND!, 1+, ;-1+, ?, >=? ;;; object-hash ;has OBJECT-HASH ;; full-continuation ;not without the -call/cc switch ieee-floating-point ;conforms to IEEE Standard 754-1985 ;IEEE Standard for Binary ;Floating-Point Arithmetic. ;; Other common features srfi-0 ;srfi-0, COND-EXPAND finds all srfi-* ;;; sicp ;runs code from Structure and ;Interpretation of Computer ;Programs by Abelson and Sussman. defmacro ;has Common Lisp DEFMACRO ;;; record ;has user defined data structures string-port ;has CALL-WITH-INPUT-STRING and ;CALL-WITH-OUTPUT-STRING ;;; sort pretty-print ;;; object->string ;;; format ;Common-lisp output formatting ;;; trace ;has macros: TRACE and UNTRACE ;;; compiler ;has (COMPILER) ;;; ed ;(ED) is editor system ;posix (system ) getenv ;posix (getenv ) program-arguments ;returns list of strings (argv) ;;; current-time ;returns time in seconds since 1/1/1970 ;; Implementation Specific features promise ;;; string-case ; missing StudlyCapsExpand ; symbol-append doesn't handle ; non-symbols. )) ;;@ http://practical-scheme.net/wiliki/schemexref.cgi?command-line ;;http://practical-scheme.net/wiliki/schemexref.cgi?executable-name (define (program-arguments) (cons (executable-name) (command-line))) (define pretty-print pp) ;;; OBJ->STRING returns strings with control characters. ;;(define (object->string x) (obj->string x)) ;; input-port-position port bigloo procedure ;; output-port-position port bigloo procedure ;; ;; Returns the current position (a character number), in the port. ;; ;; set-input-port-position! port pos bigloo procedure ;; set-output-port-position! port pos bigloo procedure ;; ;; These functions set the file position indicator for port. The new ;; position, measured in bytes, is specified by pos. It is an error to ;; seek a port that cannot be changed (for instance, a string or a ;; console port). The result of these functions is unspecified. An error ;; is raised if the position cannot be changed. ;;@ (FILE-POSITION . ) (define (file-position port . k) (if (null? k) ((if (output-port? port) output-port-position input-port-position) port) (apply (if (output-port? port) set-output-port-position! set-input-port-position!) port k))) ;;@ (OUTPUT-PORT-WIDTH ) (define (output-port-width . arg) 79) ;;@ (OUTPUT-PORT-HEIGHT ) (define (output-port-height . arg) 24) ;;@ (TMPNAM) makes a temporary file name. (define tmpnam (let ((cntr 100)) (lambda () (set! cntr (+ 1 cntr)) (let ((tmp (string-append "slib_" (number->string cntr)))) (if (file-exists? tmp) (tmpnam) tmp))))) ;;@ FORCE-OUTPUT flushes any pending output on optional arg output port ;;; use this definition if your system doesn't have such a procedure. (define (force-output . args) (flush-output-port (if (pair? args) (car args) (current-output-port)))) ;;@ CALL-WITH-INPUT-STRING and CALL-WITH-OUTPUT-STRING are the string ;;; port versions of CALL-WITH-*PUT-FILE. (define (call-with-output-string f) (let ((outsp (open-output-string))) (f outsp) (close-output-port outsp))) (define (call-with-input-string s f) (let* ((insp (open-input-string s)) (res (f insp))) (close-input-port insp) res)) ;;;; "rationalize" adjunct procedures. ;;; (define (find-ratio x e) ;;; (let ((rat (rationalize x e))) ;;; (list (numerator rat) (denominator rat)))) ;;; (define (find-ratio-between x y) ;;; (find-ratio (/ (+ x y) 2) (/ (- x y) 2))) ;;@ CHAR-CODE-LIMIT is one greater than the largest integer which can ;;; be returned by CHAR->INTEGER. (define char-code-limit 256) ;;@ MOST-POSITIVE-FIXNUM is used in modular.scm (define most-positive-fixnum 536870911) ;;@ Return argument (define (identity x) x) ;;@ SLIB:EVAL is single argument eval using the top-level (user) environment. (define slib:eval eval) (define-macro (defmacro name . forms) `(define-macro (,name . ,(car forms)) ,@(cdr forms))) ;@ (define (defmacro? m) (get-eval-expander m)) ;@ (define (macroexpand-1 body) (expand-once body)) ;@ (define (macroexpand body) (expand body)) ;@ (define (gentemp) (gensym)) ;@ (define defmacro:eval slib:eval) ;;(define (defmacro:expand* x) ;; (require 'defmacroexpand) (apply defmacro:expand* x '())) ;@ (define slib:warn (lambda args (let ((cep (current-error-port))) (if (provided? 'trace) (print-call-stack cep)) (display "Warn: " cep) (for-each (lambda (x) (display #\space cep) (write x cep)) args)))) ;;@ define an error procedure for the library (define slib:error (let ((error error)) (lambda args (if (provided? 'trace) (print-call-stack (current-error-port))) (error 'slib:error "" args)))) ;@ (define (make-exchanger obj) (lambda (rep) (let ((old obj)) (set! obj rep) old))) (define (open-file filename modes) (case modes ((r rb) (open-input-file filename)) ((w wb) (open-output-file filename)) (else (slib:error 'open-file 'mode? modes)))) ;;(define (port? obj) (or (input-port? port) (output-port? port))) (define (call-with-open-ports . ports) (define proc (car ports)) (cond ((procedure? proc) (set! ports (cdr ports))) (else (set! ports (reverse ports)) (set! proc (car ports)) (set! ports (reverse (cdr ports))))) (let ((ans (apply proc ports))) (for-each close-port ports) ans)) (define (close-port port) (cond ((input-port? port) (close-input-port port) (if (output-port? port) (close-output-port port))) ((output-port? port) (close-output-port port)) (else (slib:error 'close-port 'port? port)))) ;@ (define (browse-url url) (define (try cmd end) (zero? (system (string-append cmd url end)))) (or (try "netscape-remote -remote 'openURL(" ")'") (try "netscape -remote 'openURL(" ")'") (try "netscape '" "'&") (try "netscape '" "'"))) ;;@ define these as appropriate for your system. (define slib:tab (integer->char 9)) (define slib:form-feed (integer->char 12)) ;;; records (defmacro define-record forms (let* ((name (car forms)) (maker-name (symbol-append 'make- name))) `(begin (define-struct ,name ,@(cadr forms)) (define ,maker-name ,name)) )) ;;@ Define these if your implementation's syntax can support it and if ;;; they are not already defined. (define (1+ n) (+ n 1)) (define (-1+ n) (+ n -1)) (define 1- -1+) ;;@ Define SLIB:EXIT to be the implementation procedure to exit or ;;; return if exiting not supported. (define slib:exit (lambda args (exit 0))) ;;@ Here for backward compatability (define scheme-file-suffix (let ((suffix (case (software-type) ((nosve) "_scm") (else ".scm")))) (lambda () suffix))) ;;@ (SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever ;;; suffix all the module files in SLIB have. See feature 'SOURCE. (define (slib:load-source f) (loadq (string-append f (scheme-file-suffix)))) ;;@ (SLIB:LOAD-COMPILED "foo") should load the file that was produced ;;; by compiling "foo.scm" if this implementation can compile files. ;;; See feature 'COMPILED. (define slib:load-compiled loadq) ;;@ At this point SLIB:LOAD must be able to load SLIB files. (define (slib:load file) (if (file-exists? (string-append file (scheme-file-suffix))) (slib:load-source file) (slib:load-compiled file))) ;@ (define defmacro:load slib:load-source) ;;; If your implementation provides R4RS macros: ;;(define macro:eval slib:eval) ;;(define macro:load slib:load-source) ;;; If your implementation provides syntax-case macros: ;;(define syncase:eval slib:eval) ;;(define syncase:load slib:load-source) (slib:load (in-vicinity (library-vicinity) "require")) slib-3b1/break.scm0000644001705200017500000001161107776076456012010 0ustar tbtb;;;; "break.scm" Breakpoints for debugging in Scheme. ;;; Copyright (C) 1991, 1992, 1993, 1995, 2003 Aubrey Jaffer ; ;Permission to copy this software, to modify it, to redistribute it, ;to distribute modified versions, and to use it for any purpose is ;granted, subject to the following restrictions and understandings. ; ;1. Any copy made of this software must include this copyright notice ;in full. ; ;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; ;3. In conjunction with products arising from the use of this ;material, there shall be no use of my name in any advertising, ;promotional, or sales literature without prior written consent in ;each case. (require 'qp) (require 'alist) ;;;; BREAKPOINTS ;;; Typing (init-debug) at top level sets up a continuation for ;;; breakpoint. When (breakpoint arg1 ...) is then called it returns ;;; from the top level continuation and pushes the continuation from ;;; which it was called on breakpoint:continuation-stack. If ;;; (continue) is later called, it pops the topmost continuation off ;;; of breakpoint:continuation-stack and returns #f to it. (define breakpoint:continuation-stack '()) ;@ (define breakpoint (let ((call-with-current-continuation call-with-current-continuation) (apply apply) (qpn qpn) (cons cons) (length length)) (lambda args (if (provided? 'trace) (print-call-stack (current-error-port))) (apply qpn "BREAKPOINT:" args) (let ((ans (call-with-current-continuation (lambda (x) (set! breakpoint:continuation-stack (cons x breakpoint:continuation-stack)) (debug:top-continuation (length breakpoint:continuation-stack)))))) (cond ((not (eq? ans breakpoint:continuation-stack)) ans)))))) ;@ (define continue (let ((null? null?) (car car) (cdr cdr)) (lambda args (cond ((null? breakpoint:continuation-stack) (display "; no break to continue from") (newline)) (else (let ((cont (car breakpoint:continuation-stack))) (set! breakpoint:continuation-stack (cdr breakpoint:continuation-stack)) (if (null? args) (cont #f) (apply cont args)))))))) (define debug:top-continuation (if (provided? 'abort) (lambda (val) (display val) (newline) (abort)) (begin (display "; type (init-debug)") #f))) ;@ (define (init-debug) (call-with-current-continuation (lambda (x) (set! debug:top-continuation x)))) ;@ (define breakf (let ((null? null?) ;These bindings are so that (not not) ;breakf will not break on parts (car car) (cdr cdr) ;of itself. (eq? eq?) (+ +) (zero? zero?) (modulo modulo) (apply apply) (display display) (breakpoint breakpoint)) (lambda (function . optname) ;; (set! trace:indent 0) (let ((name (if (null? optname) function (car optname)))) (lambda args (cond ((and (not (null? args)) (eq? (car args) 'debug:unbreak-object) (null? (cdr args))) function) (else (breakpoint name args) (apply function args)))))))) ;;; the reason I use a symbol for debug:unbreak-object is so ;;; that functions can still be unbreaked if this file is read in twice. ;@ (define (unbreakf function) ;; (set! trace:indent 0) (function 'debug:unbreak-object)) ;;;;The break: functions wrap around the debug: functions to provide ;;; niceties like keeping track of breakd functions and dealing with ;;; redefinition. (define break:adder (alist-associator eq?)) (define break:deler (alist-remover eq?)) (define *breakd-procedures* '()) (define (break:breakf fun sym) (cond ((not (procedure? fun)) (display "WARNING: not a procedure " (current-error-port)) (display sym (current-error-port)) (newline (current-error-port)) (set! *breakd-procedures* (break:deler *breakd-procedures* sym)) fun) (else (let ((p (assq sym *breakd-procedures*))) (cond ((and p (eq? (cdr p) fun)) fun) (else (let ((tfun (breakf fun sym))) (set! *breakd-procedures* (break:adder *breakd-procedures* sym tfun)) tfun))))))) (define (break:unbreakf fun sym) (let ((p (assq sym *breakd-procedures*))) (set! *breakd-procedures* (break:deler *breakd-procedures* sym)) (cond ((not (procedure? fun)) fun) ((not p) fun) ((eq? (cdr p) fun) (unbreakf fun)) (else fun)))) ;;;; Finally, the macros break and unbreak ;@ (defmacro break xs (if (null? xs) `(begin ,@(map (lambda (x) `(set! ,x (break:breakf ,x ',x))) (map car *breakd-procedures*)) (map car *breakd-procedures*)) `(begin ,@(map (lambda (x) `(set! ,x (break:breakf ,x ',x))) xs)))) (defmacro unbreak xs (if (null? xs) (slib:eval `(begin ,@(map (lambda (x) `(set! ,x (break:unbreakf ,x ',x))) (map car *breakd-procedures*)) '',(map car *breakd-procedures*))) `(begin ,@(map (lambda (x) `(set! ,x (break:unbreakf ,x ',x))) xs)))) slib-3b1/bytenumb.scm0000644001705200017500000003520310547005620012523 0ustar tbtb;;; "bytenumb.scm" Byte integer and IEEE floating-point conversions. ; Copyright (C) 2003 Aubrey Jaffer ; ;Permission to copy this software, to modify it, to redistribute it, ;to distribute modified versions, and to use it for any purpose is ;granted, subject to the following restrictions and understandings. ; ;1. Any copy made of this software must include this copyright notice ;in full. ; ;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; ;3. In conjunction with products arising from the use of this ;material, there shall be no use of my name in any advertising, ;promotional, or sales literature without prior written consent in ;each case. (require 'byte) (require 'logical) ;;@code{(require 'byte-number)} ;;@ftindex byte-number ;;@noindent ;;The multi-byte sequences produced and used by numeric conversion ;;routines are always big-endian. Endianness can be changed during ;;reading and writing bytes using @code{read-bytes} and ;;@code{write-bytes} @xref{Byte, read-bytes}. ;; ;;@noindent ;;The sign of the length argument to bytes/integer conversion ;;procedures determines the signedness of the number. ;;@body ;;Converts the first @code{(abs @var{n})} bytes of big-endian @1 array ;;to an integer. If @2 is negative then the integer coded by the ;;bytes are treated as two's-complement (can be negative). ;; ;;@example ;;(bytes->integer (bytes 0 0 0 15) -4) @result{} 15 ;;(bytes->integer (bytes 0 0 0 15) 4) @result{} 15 ;;(bytes->integer (bytes 255 255 255 255) -4) @result{} -1 ;;(bytes->integer (bytes 255 255 255 255) 4) @result{} 4294967295 ;;(bytes->integer (bytes 128 0 0 0) -4) @result{} -2147483648 ;;(bytes->integer (bytes 128 0 0 0) 4) @result{} 2147483648 ;;@end example (define (bytes->integer bytes n) (define cnt (abs n)) (cond ((zero? n) 0) ((and (negative? n) (> (byte-ref bytes 0) 127)) (do ((lng (- 255 (byte-ref bytes 0)) (+ (- 255 (byte-ref bytes idx)) (* 256 lng))) (idx 1 (+ 1 idx))) ((>= idx cnt) (- -1 lng)))) (else (do ((lng (byte-ref bytes 0) (+ (byte-ref bytes idx) (* 256 lng))) (idx 1 (+ 1 idx))) ((>= idx cnt) lng))))) ;;@body ;;Converts the integer @1 to a byte-array of @code{(abs @var{n})} ;;bytes. If @1 and @2 are both negative, then the bytes in the ;;returned array are coded two's-complement. ;; ;;@example ;;(bytes->list (integer->bytes 15 -4)) @result{} (0 0 0 15) ;;(bytes->list (integer->bytes 15 4)) @result{} (0 0 0 15) ;;(bytes->list (integer->bytes -1 -4)) @result{} (255 255 255 255) ;;(bytes->list (integer->bytes 4294967295 4)) @result{} (255 255 255 255) ;;(bytes->list (integer->bytes -2147483648 -4)) @result{} (128 0 0 0) ;;(bytes->list (integer->bytes 2147483648 4)) @result{} (128 0 0 0) ;;@end example (define (integer->bytes n len) (define bytes (make-bytes (abs len))) (cond ((and (negative? n) (negative? len)) (do ((idx (+ -1 (abs len)) (+ -1 idx)) (res (- -1 n) (quotient res 256))) ((negative? idx) bytes) (byte-set! bytes idx (- 255 (modulo res 256))))) (else (do ((idx (+ -1 (abs len)) (+ -1 idx)) (res n (quotient res 256))) ((negative? idx) bytes) (byte-set! bytes idx (modulo res 256)))))) ;;@body ;;@1 must be a 4-element byte-array. @0 calculates and returns the ;;value of @1 interpreted as a big-endian IEEE 4-byte (32-bit) number. (define (bytes->ieee-float bytes) (define zero (or (string->number "0.0") 0)) (define one (or (string->number "1.0") 1)) (define len (bytes-length bytes)) (define S (logbit? 7 (byte-ref bytes 0))) (define E (+ (ash (logand #x7F (byte-ref bytes 0)) 1) (ash (logand #x80 (byte-ref bytes 1)) -7))) (if (not (eqv? 4 len)) (slib:error 'bytes->ieee-float 'wrong 'length len)) (do ((F (byte-ref bytes (+ -1 len)) (+ (byte-ref bytes idx) (/ F 256))) (idx (+ -2 len) (+ -1 idx))) ((<= idx 1) (set! F (/ (+ (logand #x7F (byte-ref bytes 1)) (/ F 256)) 128)) (cond ((< 0 E 255) (* (if S (- one) one) (expt 2 (- E 127)) (+ 1 F))) ((zero? E) (if (zero? F) (if S (- zero) zero) (* (if S (- one) one) (expt 2 -126) F))) ;; E must be 255 ((not (zero? F)) (/ zero zero)) (else (/ (if S (- one) one) zero)))))) ;; S EEEEEEE E FFFFFFF FFFFFFFF FFFFFFFF ;; ========= ========= ======== ======== ;; 0 1 8 9 31 ;;@example ;;(bytes->ieee-float (bytes 0 0 0 0)) @result{} 0.0 ;;(bytes->ieee-float (bytes #x80 0 0 0)) @result{} -0.0 ;;(bytes->ieee-float (bytes #x40 0 0 0)) @result{} 2.0 ;;(bytes->ieee-float (bytes #x40 #xd0 0 0)) @result{} 6.5 ;;(bytes->ieee-float (bytes #xc0 #xd0 0 0)) @result{} -6.5 ;; ;;(bytes->ieee-float (bytes 0 #x80 0 0)) @result{} 11.754943508222875e-39 ;;(bytes->ieee-float (bytes 0 #x40 0 0)) @result{} 5.877471754111437e-39 ;;(bytes->ieee-float (bytes 0 0 0 1)) @result{} 1.401298464324817e-45 ;; ;;(bytes->ieee-float (bytes #xff #x80 0 0)) @result{} -inf.0 ;;(bytes->ieee-float (bytes #x7f #x80 0 0)) @result{} +inf.0 ;;(bytes->ieee-float (bytes #x7f #x80 0 1)) @result{} 0/0 ;;(bytes->ieee-float (bytes #x7f #xc0 0 0)) @result{} 0/0 ;;@end example ;;@body ;;@1 must be a 8-element byte-array. @0 calculates and returns the ;;value of @1 interpreted as a big-endian IEEE 8-byte (64-bit) number. (define (bytes->ieee-double bytes) (define zero (or (string->number "0.0") 0)) (define one (or (string->number "1.0") 1)) (define len (bytes-length bytes)) (define S (logbit? 7 (byte-ref bytes 0))) (define E (+ (ash (logand #x7F (byte-ref bytes 0)) 4) (ash (logand #xF0 (byte-ref bytes 1)) -4))) (if (not (eqv? 8 len)) (slib:error 'bytes->ieee-double 'wrong 'length len)) (do ((F (byte-ref bytes (+ -1 len)) (+ (byte-ref bytes idx) (/ F 256))) (idx (+ -2 len) (+ -1 idx))) ((<= idx 1) (set! F (/ (+ (logand #x0F (byte-ref bytes 1)) (/ F 256)) 16)) (cond ((< 0 E 2047) (* (if S (- one) one) (expt 2 (- E 1023)) (+ 1 F))) ((zero? E) (if (zero? F) (if S (- zero) zero) (* (if S (- one) one) (expt 2 -1022) F))) ;; E must be 2047 ((not (zero? F)) (/ zero zero)) (else (/ (if S (- one) one) zero)))))) ;; S EEEEEEE EEEE FFFF FFFFFFFF FFFFFFFF FFFFFFFF FFFFFFFF FFFFFFFF FFFFFFFF ;; ========= ========= ======== ======== ======== ======== ======== ======== ;; 0 1 11 12 63 ;;@example ;;(bytes->ieee-double (bytes 0 0 0 0 0 0 0 0)) @result{} 0.0 ;;(bytes->ieee-double (bytes #x80 0 0 0 0 0 0 0)) @result{} -0.0 ;;(bytes->ieee-double (bytes #x40 0 0 0 0 0 0 0)) @result{} 2.0 ;;(bytes->ieee-double (bytes #x40 #x1A 0 0 0 0 0 0)) @result{} 6.5 ;;(bytes->ieee-double (bytes #xC0 #x1A 0 0 0 0 0 0)) @result{} -6.5 ;; ;;(bytes->ieee-double (bytes 0 8 0 0 0 0 0 0)) @result{} 11.125369292536006e-309 ;;(bytes->ieee-double (bytes 0 4 0 0 0 0 0 0)) @result{} 5.562684646268003e-309 ;;(bytes->ieee-double (bytes 0 0 0 0 0 0 0 1)) @result{} 4.0e-324 ;; ;;(bytes->ieee-double (bytes #xFF #xF0 0 0 0 0 0 0)) @result{} -inf.0 ;;(bytes->ieee-double (bytes #x7F #xF0 0 0 0 0 0 0)) @result{} +inf.0 ;;(bytes->ieee-double (bytes #x7F #xF8 0 0 0 0 0 0)) @result{} 0/0 ;;@end example ;;@args x ;;Returns a 4-element byte-array encoding the IEEE single-precision ;;floating-point of @1. (define ieee-float->bytes (let ((zero (or (string->number "0.0") 0)) (exactify (if (provided? 'inexact) inexact->exact identity))) (lambda (flt) (define byts (make-bytes 4 0)) (define S (and (real? flt) (negative? (if (zero? flt) (/ flt) flt)))) (define (scale flt scl) (cond ((zero? scl) (out (/ flt 2) scl)) ((>= flt 16) (let ((flt/16 (/ flt 16))) (cond ((= flt/16 flt) (byte-set! byts 0 (if S #xFF #x7F)) (byte-set! byts 1 #x80) byts) (else (scale flt/16 (+ scl 4)))))) ((>= flt 2) (scale (/ flt 2) (+ scl 1))) ((and (>= scl 4) (< (* 16 flt) 1)) (scale (* flt 16) (+ scl -4))) ((< flt 1) (scale (* flt 2) (+ scl -1))) (else (out (+ -1 flt) scl)))) (define (out flt scl) (do ((flt (* 128 flt) (* 256 (- flt val))) (val (exactify (floor (* 128 flt))) (exactify (floor (* 256 (- flt val))))) (idx 1 (+ 1 idx))) ((> idx 3) (byte-set! byts 1 (bitwise-if #x80 (ash scl 7) (byte-ref byts 1))) (byte-set! byts 0 (+ (if S 128 0) (ash scl -1))) byts) (byte-set! byts idx val))) (set! flt (magnitude flt)) (cond ((zero? flt) (if S (byte-set! byts 0 #x80)) byts) ((or (not (real? flt)) (not (= flt flt))) (byte-set! byts 0 (if S #xFF #x7F)) (byte-set! byts 1 #xC0) byts) (else (scale flt 127)))))) ;;@example ;;(bytes->list (ieee-float->bytes 0.0)) @result{} (0 0 0 0) ;;(bytes->list (ieee-float->bytes -0.0)) @result{} (128 0 0 0) ;;(bytes->list (ieee-float->bytes 2.0)) @result{} (64 0 0 0) ;;(bytes->list (ieee-float->bytes 6.5)) @result{} (64 208 0 0) ;;(bytes->list (ieee-float->bytes -6.5)) @result{} (192 208 0 0) ;; ;;(bytes->list (ieee-float->bytes 11.754943508222875e-39)) @result{} ( 0 128 0 0) ;;(bytes->list (ieee-float->bytes 5.877471754111438e-39)) @result{} ( 0 64 0 0) ;;(bytes->list (ieee-float->bytes 1.401298464324817e-45)) @result{} ( 0 0 0 1) ;; ;;(bytes->list (ieee-float->bytes -inf.0)) @result{} (255 128 0 0) ;;(bytes->list (ieee-float->bytes +inf.0)) @result{} (127 128 0 0) ;;(bytes->list (ieee-float->bytes 0/0)) @result{} (127 192 0 0) ;;@end example ;;@args x ;;Returns a 8-element byte-array encoding the IEEE double-precision ;;floating-point of @1. (define ieee-double->bytes (let ((zero (or (string->number "0.0") 0)) (exactify (if (provided? 'inexact) inexact->exact identity))) (lambda (flt) (define byts (make-bytes 8 0)) (define S (and (real? flt) (negative? (if (zero? flt) (/ flt) flt)))) (define (scale flt scl) (cond ((zero? scl) (out (/ flt 2) scl)) ((>= flt 16) (let ((flt/16 (/ flt 16))) (cond ((= flt/16 flt) (byte-set! byts 0 (if S #xFF #x7F)) (byte-set! byts 1 #xF0) byts) (else (scale flt/16 (+ scl 4)))))) ((>= flt 2) (scale (/ flt 2) (+ scl 1))) ((and (>= scl 4) (< (* 16 flt) 1)) (scale (* flt 16) (+ scl -4))) ((< flt 1) (scale (* flt 2) (+ scl -1))) (else (out (+ -1 flt) scl)))) (define (out flt scl) (do ((flt (* 16 flt) (* 256 (- flt val))) (val (exactify (floor (* 16 flt))) (exactify (floor (* 256 (- flt val))))) (idx 1 (+ 1 idx))) ((> idx 7) (byte-set! byts 1 (bitwise-if #xF0 (ash scl 4) (byte-ref byts 1))) (byte-set! byts 0 (+ (if S 128 0) (ash scl -4))) byts) (byte-set! byts idx val))) (set! flt (magnitude flt)) (cond ((zero? flt) (if S (byte-set! byts 0 #x80)) byts) ((or (not (real? flt)) (not (= flt flt))) (byte-set! byts 0 #x7F) (byte-set! byts 1 #xF8) byts) (else (scale flt 1023)))))) ;;@example ;;(bytes->list (ieee-double->bytes 0.0)) @result{} (0 0 0 0 0 0 0 0) ;;(bytes->list (ieee-double->bytes -0.0)) @result{} (128 0 0 0 0 0 0 0) ;;(bytes->list (ieee-double->bytes 2.0)) @result{} (64 0 0 0 0 0 0 0) ;;(bytes->list (ieee-double->bytes 6.5)) @result{} (64 26 0 0 0 0 0 0) ;;(bytes->list (ieee-double->bytes -6.5)) @result{} (192 26 0 0 0 0 0 0) ;; ;;(bytes->list (ieee-double->bytes 11.125369292536006e-309)) ;; @result{} ( 0 8 0 0 0 0 0 0) ;;(bytes->list (ieee-double->bytes 5.562684646268003e-309)) ;; @result{} ( 0 4 0 0 0 0 0 0) ;;(bytes->list (ieee-double->bytes 4.0e-324)) ;; @result{} ( 0 0 0 0 0 0 0 1) ;; ;;(bytes->list (ieee-double->bytes -inf.0)) @result{} (255 240 0 0 0 0 0 0) ;;(bytes->list (ieee-double->bytes +inf.0)) @result{} (127 240 0 0 0 0 0 0) ;;(bytes->list (ieee-double->bytes 0/0)) @result{} (127 248 0 0 0 0 0 0) ;;@end example ;;@subsubheading Byte Collation Order ;; ;;@noindent ;;The @code{stringinteger bytes n Converts the first @code{(abs @var{n})} bytes of big-endian @var{bytes} array to an integer. If @var{n} is negative then the integer coded by the bytes are treated as two's-complement (can be negative). @example (bytes->integer (bytes 0 0 0 15) -4) @result{} 15 (bytes->integer (bytes 0 0 0 15) 4) @result{} 15 (bytes->integer (bytes 255 255 255 255) -4) @result{} -1 (bytes->integer (bytes 255 255 255 255) 4) @result{} 4294967295 (bytes->integer (bytes 128 0 0 0) -4) @result{} -2147483648 (bytes->integer (bytes 128 0 0 0) 4) @result{} 2147483648 @end example @end defun @defun integer->bytes n len Converts the integer @var{n} to a byte-array of @code{(abs @var{n})} bytes. If @var{n} and @var{len} are both negative, then the bytes in the returned array are coded two's-complement. @example (bytes->list (integer->bytes 15 -4)) @result{} (0 0 0 15) (bytes->list (integer->bytes 15 4)) @result{} (0 0 0 15) (bytes->list (integer->bytes -1 -4)) @result{} (255 255 255 255) (bytes->list (integer->bytes 4294967295 4)) @result{} (255 255 255 255) (bytes->list (integer->bytes -2147483648 -4)) @result{} (128 0 0 0) (bytes->list (integer->bytes 2147483648 4)) @result{} (128 0 0 0) @end example @end defun @defun bytes->ieee-float bytes @var{bytes} must be a 4-element byte-array. @code{bytes->ieee-float} calculates and returns the value of @var{bytes} interpreted as a big-endian IEEE 4-byte (32-bit) number. @end defun @example (bytes->ieee-float (bytes 0 0 0 0)) @result{} 0.0 (bytes->ieee-float (bytes #x80 0 0 0)) @result{} -0.0 (bytes->ieee-float (bytes #x40 0 0 0)) @result{} 2.0 (bytes->ieee-float (bytes #x40 #xd0 0 0)) @result{} 6.5 (bytes->ieee-float (bytes #xc0 #xd0 0 0)) @result{} -6.5 (bytes->ieee-float (bytes 0 #x80 0 0)) @result{} 11.754943508222875e-39 (bytes->ieee-float (bytes 0 #x40 0 0)) @result{} 5.877471754111437e-39 (bytes->ieee-float (bytes 0 0 0 1)) @result{} 1.401298464324817e-45 (bytes->ieee-float (bytes #xff #x80 0 0)) @result{} -inf.0 (bytes->ieee-float (bytes #x7f #x80 0 0)) @result{} +inf.0 (bytes->ieee-float (bytes #x7f #x80 0 1)) @result{} 0/0 (bytes->ieee-float (bytes #x7f #xc0 0 0)) @result{} 0/0 @end example @defun bytes->ieee-double bytes @var{bytes} must be a 8-element byte-array. @code{bytes->ieee-double} calculates and returns the value of @var{bytes} interpreted as a big-endian IEEE 8-byte (64-bit) number. @end defun @example (bytes->ieee-double (bytes 0 0 0 0 0 0 0 0)) @result{} 0.0 (bytes->ieee-double (bytes #x80 0 0 0 0 0 0 0)) @result{} -0.0 (bytes->ieee-double (bytes #x40 0 0 0 0 0 0 0)) @result{} 2.0 (bytes->ieee-double (bytes #x40 #x1A 0 0 0 0 0 0)) @result{} 6.5 (bytes->ieee-double (bytes #xC0 #x1A 0 0 0 0 0 0)) @result{} -6.5 (bytes->ieee-double (bytes 0 8 0 0 0 0 0 0)) @result{} 11.125369292536006e-309 (bytes->ieee-double (bytes 0 4 0 0 0 0 0 0)) @result{} 5.562684646268003e-309 (bytes->ieee-double (bytes 0 0 0 0 0 0 0 1)) @result{} 4.0e-324 (bytes->ieee-double (bytes #xFF #xF0 0 0 0 0 0 0)) @result{} -inf.0 (bytes->ieee-double (bytes #x7F #xF0 0 0 0 0 0 0)) @result{} +inf.0 (bytes->ieee-double (bytes #x7F #xF8 0 0 0 0 0 0)) @result{} 0/0 @end example @defun ieee-float->bytes x Returns a 4-element byte-array encoding the IEEE single-precision floating-point of @var{x}. @end defun @example (bytes->list (ieee-float->bytes 0.0)) @result{} (0 0 0 0) (bytes->list (ieee-float->bytes -0.0)) @result{} (128 0 0 0) (bytes->list (ieee-float->bytes 2.0)) @result{} (64 0 0 0) (bytes->list (ieee-float->bytes 6.5)) @result{} (64 208 0 0) (bytes->list (ieee-float->bytes -6.5)) @result{} (192 208 0 0) (bytes->list (ieee-float->bytes 11.754943508222875e-39)) @result{} ( 0 128 0 0) (bytes->list (ieee-float->bytes 5.877471754111438e-39)) @result{} ( 0 64 0 0) (bytes->list (ieee-float->bytes 1.401298464324817e-45)) @result{} ( 0 0 0 1) (bytes->list (ieee-float->bytes -inf.0)) @result{} (255 128 0 0) (bytes->list (ieee-float->bytes +inf.0)) @result{} (127 128 0 0) (bytes->list (ieee-float->bytes 0/0)) @result{} (127 192 0 0) @end example @defun ieee-double->bytes x Returns a 8-element byte-array encoding the IEEE double-precision floating-point of @var{x}. @end defun @example (bytes->list (ieee-double->bytes 0.0)) @result{} (0 0 0 0 0 0 0 0) (bytes->list (ieee-double->bytes -0.0)) @result{} (128 0 0 0 0 0 0 0) (bytes->list (ieee-double->bytes 2.0)) @result{} (64 0 0 0 0 0 0 0) (bytes->list (ieee-double->bytes 6.5)) @result{} (64 26 0 0 0 0 0 0) (bytes->list (ieee-double->bytes -6.5)) @result{} (192 26 0 0 0 0 0 0) (bytes->list (ieee-double->bytes 11.125369292536006e-309)) @result{} ( 0 8 0 0 0 0 0 0) (bytes->list (ieee-double->bytes 5.562684646268003e-309)) @result{} ( 0 4 0 0 0 0 0 0) (bytes->list (ieee-double->bytes 4.0e-324)) @result{} ( 0 0 0 0 0 0 0 1) (bytes->list (ieee-double->bytes -inf.0)) @result{} (255 240 0 0 0 0 0 0) (bytes->list (ieee-double->bytes +inf.0)) @result{} (127 240 0 0 0 0 0 0) (bytes->list (ieee-double->bytes 0/0)) @result{} (127 248 0 0 0 0 0 0) @end example @subsubheading Byte Collation Order @noindent The @code{string (define (byte-set! bytes k byte) (array-set! bytes byte k)) ;;@args k byte ;;@args k ;;@0 returns a newly allocated byte-array of length @1. If @2 is ;;given, then all elements of the byte-array are initialized to @2, ;;otherwise the contents of the byte-array are unspecified. (define (make-bytes len . opt) (make-array (apply A:fixN8b opt) len)) ;;@args bytes ;;@0 returns length of byte-array @1. (define (bytes-length bts) (car (array-dimensions bts))) ;;@args byte @dots{} ;;Returns a newly allocated byte-array composed of the small ;;nonnegative arguments. (define (bytes . args) (list->array 1 (A:fixN8b) args)) ;;@args bytes ;;@0 returns a newly allocated byte-array formed from the small ;;nonnegative integers in the list @1. (define (list->bytes lst) (list->array 1 (A:fixN8b) lst)) ;;@args bytes ;;@0 returns a newly allocated list of the bytes that make up the ;;given byte-array. (define bytes->list array->list) ;;@noindent ;;@code{Bytes->list} and @code{list->bytes} are inverses so far as ;;@code{equal?} is concerned. ;;@findex equal? ;;@args bytes ;;Returns a new string formed from applying @code{integer->char} to ;;each byte in @0. Note that this may signal an error for bytes ;;having values between 128 and 255. (define (bytes->string bts) (define len (bytes-length bts)) (let ((new (make-string len))) (do ((idx (- len 1) (+ -1 idx))) ((negative? idx) new) (string-set! new idx (integer->char (byte-ref bts idx)))))) ;;@args string ;;Returns a new byte-array formed from applying @code{char->integer} ;;to each character in @0. Note that this may signal an error if an ;;integer is larger than 255. (define (string->bytes str) (define len (string-length str)) (let ((new (make-bytes len))) (do ((idx (- len 1) (+ -1 idx))) ((negative? idx) new) (byte-set! new idx (char->integer (string-ref str idx)))))) ;;@args bytes ;;Returns a newly allocated copy of the given @1. (define (bytes-copy bts) (define len (bytes-length bts)) (let ((new (make-bytes len))) (do ((idx (- len 1) (+ -1 idx))) ((negative? idx) new) (byte-set! new idx (byte-ref bytes idx))))) ;;@args bytes start end ;;@1 must be a bytes, and @2 and @3 ;;must be exact integers satisfying ;; ;;@center 0 <= @2 <= @3 <= @w{@t{(bytes-length @1)@r{.}}} ;; ;;@0 returns a newly allocated bytes formed from the bytes of ;;@1 beginning with index @2 (inclusive) and ending with index ;;@3 (exclusive). (define (subbytes bytes start end) (define new (make-bytes (- end start))) (do ((idx (- end start 1) (+ -1 idx))) ((negative? idx) new) (byte-set! new idx (byte-ref bytes (+ start idx))))) ;;@body ;;Reverses the order of byte-array @1. (define (bytes-reverse! bytes) (do ((idx 0 (+ 1 idx)) (xdi (+ -1 (bytes-length bytes)) (+ -1 xdi))) ((> idx xdi) bytes) (let ((tmp (byte-ref bytes idx))) (byte-set! bytes idx (byte-ref bytes xdi)) (byte-set! bytes xdi tmp)))) ;;@body ;;Returns a newly allocated bytes-array consisting of the elements of ;;@1 in reverse order. (define (bytes-reverse bytes) (bytes-reverse! (bytes-copy bytes))) ;;@noindent ;;@cindex binary ;;Input and output of bytes should be with ports opened in @dfn{binary} ;;mode (@pxref{Input/Output}). Calling @code{open-file} with @r{'rb} or ;;@findex open-file ;;@r{'wb} modes argument will return a binary port if the Scheme ;;implementation supports it. ;;@args byte port ;;@args byte ;;Writes the byte @1 (not an external representation of the byte) to ;;the given @2 and returns an unspecified value. The @2 argument may ;;be omitted, in which case it defaults to the value returned by ;;@code{current-output-port}. ;;@findex current-output-port (define (write-byte byt . opt) (apply write-char (integer->char byt) opt)) ;;@args port ;;@args ;;Returns the next byte available from the input @1, updating the @1 ;;to point to the following byte. If no more bytes are available, an ;;end-of-file object is returned. @1 may be omitted, in which case it ;;defaults to the value returned by @code{current-input-port}. ;;@findex current-input-port (define (read-byte . opt) (let ((c (apply read-char opt))) (if (eof-object? c) c (char->integer c)))) ;;@noindent ;;When reading and writing binary numbers with @code{read-bytes} and ;;@code{write-bytes}, the sign of the length argument determines the ;;endianness (order) of bytes. Positive treats them as big-endian, ;;the first byte input or output is highest order. Negative treats ;;them as little-endian, the first byte input or output is the lowest ;;order. ;; ;;@noindent ;;Once read in, SLIB treats byte sequences as big-endian. The ;;multi-byte sequences produced and used by number conversion routines ;;@pxref{Byte/Number Conversions} are always big-endian. ;;@args n port ;;@args n ;;@0 returns a newly allocated bytes-array filled with ;;@code{(abs @var{n})} bytes read from @2. If @1 is positive, then ;;the first byte read is stored at index 0; otherwise the last byte ;;read is stored at index 0. Note that the length of the returned ;;byte-array will be less than @code{(abs @var{n})} if @2 reaches ;;end-of-file. ;; ;;@2 may be omitted, in which case it defaults to the value returned ;;by @code{current-input-port}. (define (read-bytes n . port) (let* ((len (abs n)) (byts (make-bytes len)) (cnt (if (positive? n) (apply subbytes-read! byts 0 n port) (apply subbytes-read! byts (- n) 0 port)))) (if (= cnt len) byts (if (positive? n) (subbytes byts 0 cnt) (subbytes byts (- len cnt) len))))) ;;@args bytes n port ;;@args bytes n ;;@0 writes @code{(abs @var{n})} bytes to output-port @3. If @2 is ;;positive, then the first byte written is index 0 of @1; otherwise ;;the last byte written is index 0 of @1. @0 returns an unspecified ;;value. ;; ;;@3 may be omitted, in which case it defaults to the value returned ;;by @code{current-output-port}. (define (write-bytes bytes n . port) (if (positive? n) (apply subbytes-write bytes 0 n port) (apply subbytes-write bytes (- n) 0 port))) ;;@noindent ;;@code{subbytes-read!} and @code{subbytes-write} provide ;;lower-level procedures for reading and writing blocks of bytes. The ;;relative size of @var{start} and @var{end} determines the order of ;;writing. ;;@args bts start end port ;;@args bts start end ;;Fills @1 with up to @code{(abs (- @var{start} @var{end}))} bytes ;;read from @4. The first byte read is stored at index @1. ;;@0 returns the number of bytes read. ;; ;;@4 may be omitted, in which case it defaults to the value returned ;;by @code{current-input-port}. (define (subbytes-read! bts start end . port) (if (>= end start) (do ((idx start (+ 1 idx))) ((>= idx end) idx) (let ((byt (apply read-byte port))) (cond ((eof-object? byt) (set! idx (+ -1 idx)) (set! end idx)) (else (byte-set! bts idx byt))))) (do ((idx (+ -1 start) (+ -1 idx)) (cnt 0 (+ 1 cnt))) ((< idx end) cnt) (let ((byt (apply read-byte port))) (cond ((eof-object? byt) (set! idx start) (set! cnt (+ -1 cnt))) (else (byte-set! bts idx byt))))))) ;;@args bts start end port ;;@args bts start end ;;@0 writes @code{(abs (- @var{start} @var{end}))} bytes to ;;output-port @4. The first byte written is index @2 of @1. @0 ;;returns the number of bytes written. ;; ;;@4 may be omitted, in which case it defaults to the value returned ;;by @code{current-output-port}. (define (subbytes-write bts start end . port) (if (>= end start) (do ((idx start (+ 1 idx))) ((>= idx end) (- end start)) (apply write-byte (byte-ref bts idx) port)) (do ((idx (+ -1 start) (+ -1 idx))) ((< idx end) (- start end)) (apply write-byte (byte-ref bts idx) port)))) slib-3b1/byte.txi0000644001705200017500000001451610747237373011705 0ustar tbtb@code{(require 'byte)} @ftindex byte @noindent Some algorithms are expressed in terms of arrays of small integers. Using Scheme strings to implement these arrays is not portable vis-a-vis the correspondence between integers and characters and non-ascii character sets. These functions abstract the notion of a @dfn{byte}. @cindex byte @cindex byte @defun byte-ref bytes k @var{k} must be a valid index of @var{bytes}. @code{byte-ref} returns byte @var{k} of @var{bytes} using zero-origin indexing. @end defun @deffn {Procedure} byte-set! bytes k byte @var{k} must be a valid index of @var{bytes}, and @var{byte} must be a small nonnegative integer. @code{byte-set!} stores @var{byte} in element @var{k} of @var{bytes} and returns an unspecified value. @c @end deffn @defun make-bytes k byte @defunx make-bytes k @code{make-bytes} returns a newly allocated byte-array of length @var{k}. If @var{byte} is given, then all elements of the byte-array are initialized to @var{byte}, otherwise the contents of the byte-array are unspecified. @end defun @defun bytes-length bytes @code{bytes-length} returns length of byte-array @var{bytes}. @end defun @defun bytes byte @dots{} Returns a newly allocated byte-array composed of the small nonnegative arguments. @end defun @defun list->bytes bytes @code{list->bytes} returns a newly allocated byte-array formed from the small nonnegative integers in the list @var{bytes}. @end defun @defun bytes->list bytes @code{bytes->list} returns a newly allocated list of the bytes that make up the given byte-array. @end defun @noindent @code{Bytes->list} and @code{list->bytes} are inverses so far as @code{equal?} is concerned. @findex equal? @defun bytes->string bytes Returns a new string formed from applying @code{integer->char} to each byte in @code{bytes->string}. Note that this may signal an error for bytes having values between 128 and 255. @end defun @defun string->bytes string Returns a new byte-array formed from applying @code{char->integer} to each character in @code{string->bytes}. Note that this may signal an error if an integer is larger than 255. @end defun @defun bytes-copy bytes Returns a newly allocated copy of the given @var{bytes}. @end defun @defun subbytes bytes start end @var{bytes} must be a bytes, and @var{start} and @var{end} must be exact integers satisfying @center 0 <= @var{start} <= @var{end} <= @w{@t{(bytes-length @var{bytes})@r{.}}} @code{subbytes} returns a newly allocated bytes formed from the bytes of @var{bytes} beginning with index @var{start} (inclusive) and ending with index @var{end} (exclusive). @end defun @deffn {Procedure} bytes-reverse! bytes Reverses the order of byte-array @var{bytes}. @end deffn @defun bytes-reverse bytes Returns a newly allocated bytes-array consisting of the elements of @var{bytes} in reverse order. @end defun @noindent @cindex binary Input and output of bytes should be with ports opened in @dfn{binary} @cindex binary mode (@pxref{Input/Output}). Calling @code{open-file} with @r{'rb} or @findex open-file @r{'wb} modes argument will return a binary port if the Scheme implementation supports it. @defun write-byte byte port @defunx write-byte byte Writes the byte @var{byte} (not an external representation of the byte) to the given @var{port} and returns an unspecified value. The @var{port} argument may be omitted, in which case it defaults to the value returned by @code{current-output-port}. @findex current-output-port @end defun @defun read-byte port @defunx read-byte Returns the next byte available from the input @var{port}, updating the @var{port} to point to the following byte. If no more bytes are available, an end-of-file object is returned. @var{port} may be omitted, in which case it defaults to the value returned by @code{current-input-port}. @findex current-input-port @end defun @noindent When reading and writing binary numbers with @code{read-bytes} and @code{write-bytes}, the sign of the length argument determines the endianness (order) of bytes. Positive treats them as big-endian, the first byte input or output is highest order. Negative treats them as little-endian, the first byte input or output is the lowest order. @noindent Once read in, SLIB treats byte sequences as big-endian. The multi-byte sequences produced and used by number conversion routines @pxref{Byte/Number Conversions} are always big-endian. @defun read-bytes n port @defunx read-bytes n @code{read-bytes} returns a newly allocated bytes-array filled with @code{(abs @var{n})} bytes read from @var{port}. If @var{n} is positive, then the first byte read is stored at index 0; otherwise the last byte read is stored at index 0. Note that the length of the returned byte-array will be less than @code{(abs @var{n})} if @var{port} reaches end-of-file. @var{port} may be omitted, in which case it defaults to the value returned by @code{current-input-port}. @end defun @defun write-bytes bytes n port @defunx write-bytes bytes n @code{write-bytes} writes @code{(abs @var{n})} bytes to output-port @var{port}. If @var{n} is positive, then the first byte written is index 0 of @var{bytes}; otherwise the last byte written is index 0 of @var{bytes}. @code{write-bytes} returns an unspecified value. @var{port} may be omitted, in which case it defaults to the value returned by @code{current-output-port}. @end defun @noindent @code{subbytes-read!} and @code{subbytes-write} provide lower-level procedures for reading and writing blocks of bytes. The relative size of @var{start} and @var{end} determines the order of writing. @deffn {Procedure} subbytes-read! bts start end port @deffnx {Procedure} subbytes-read! bts start end Fills @var{bts} with up to @code{(abs (- @var{start} @var{end}))} bytes read from @var{port}. The first byte read is stored at index @var{bts}. @code{subbytes-read!} returns the number of bytes read. @var{port} may be omitted, in which case it defaults to the value returned by @code{current-input-port}. @end deffn @defun subbytes-write bts start end port @defunx subbytes-write bts start end @code{subbytes-write} writes @code{(abs (- @var{start} @var{end}))} bytes to output-port @var{port}. The first byte written is index @var{start} of @var{bts}. @code{subbytes-write} returns the number of bytes written. @var{port} may be omitted, in which case it defaults to the value returned by @code{current-output-port}. @end defun slib-3b1/ChangeLog0000644001705200017500000060113010750526413011746 0ustar tbtb2008-02-01 Aubrey Jaffer * require.scm (*slib-version*): Bumped from 3a5 to 3b1. 2008-01-31 Aubrey Jaffer * FAQ, slib.spec, Makefile: Always put - between slib and version. 2008-01-28 Aubrey Jaffer * fdl.texi: (Version 1.2, November 2002) Registered in CVS. * slib.texi (About SLIB): SLIB is part of the GNU project. (Installation): Fixed \ problem choking pdf generation. 2008-01-23 Aubrey Jaffer * byte.scm: Rewritten to use uniform arrays. * random.scm (random): Err when passed negative number. * scheme48.init (char-code-limit): 128; does ascii conversions. 2008-01-23 Ivan Shmakov * scheme48.init (slib:os-strings): Fixed init for 1.7 (and 1.3). (defmacro:eval, defmacro:load): Fixed. 2008-01-21 Aubrey Jaffer * Makefile (ciefiles): Separated from Scheme sourefiles. (test): Unmaintained target removed. 2008-01-19 Aubrey Jaffer * scheme48.init (1+, -1+): Removed; choke Scheme48-1.7. Added SRFIs as found in Scheme-48 release-notes. (scheme-implementation-version): Lose text after number. * Makefile ($(S48SLIB), $(S48LIB)): Prefix with $(DESTDIR). 2008-01-18 Aubrey Jaffer * srfi-1.scm (lset<=): Fixed to use first argument. * Makefile (install, psdtemp/slib): mkdir -p. 2008-01-17 Aubrey Jaffer * transact.scm (word:lock!): Don't try to read file until after call-with-open-ports returns. (describe-file-lock): Handle case when file isn't locked. (windows:user-email-address): Much simplified; updated to Windows-XP from Windows-95. 2008-01-16 Aubrey Jaffer * Makefile (RSYNC): --rsync-path no longer needed. * transact.scm (describe-file-lock): Added diagnostic to current-error-port. * slib.nsi (MUI_ICON): Set to "SLIB.ico". * Makefile (allfiles): Added SLIB.ico. 2008-01-15 Aubrey Jaffer * rdms.scm (open-table): Return #f for failure per documentation. 2008-01-07 Aubrey Jaffer * solid.scm (light:point, light:spot): Fixed. 2008-01-02 Aubrey Jaffer * determ.scm (matrix:inverse, matrix->lists): Corrected documentation. 2007-12-31 Aubrey Jaffer * clrnamdb.scm, resenecolours.txt: Updated to Resene-2007. 2007-12-23 Aubrey Jaffer * slib.texi: Removed glob as alias for filename. * glob.scm: In documentation, removed glob as alias for filename. * dirs.scm: Require 'filename instead of 'glob. * require.scm: Condition SRFI scan on srfi-0. * mklibcat.scm: Feature-name is srfi-0 (was srfi). * scheme48.init, mzscheme.init, Template.scm, umbscheme.init, vscm.init, STk.init, scheme2c.init, scsh.init, sisc.init, t3.init, RScheme.init, macscheme.init, mitscheme.init, pscheme.init, jscheme.init, kawa.init, bigloo.init, chez.init, elk.init, gambit.init, guile.init (slib:features): Added srfi-96. Replaced srfi with srfi-0. * mbe.scm (macro:eval): defmacro:eval. (macro:load): defmacro:load. * defmacex.scm (defmacro:expand*): Use macroexpand instead of macroexpand-1 in preparation for macroexpand-1 deprecation. * vscm.init (slib:features): Added macro. * RScheme.init (slib:features): Added defmacro. * mzscheme.init (slib:features): Added syntax-case. * guile.init, scheme48.init, sisc.init (macro:load): slib:load-source. * umbscheme.init, pscheme.init (defmacro:eval, defmacro:load): Simplified. * kawa.init, mitscheme.init, bigloo.init, gambit.init, jscheme.init: (re)moved some comments. * Template.scm, t3.init, STk.init, macscheme.init, scheme2c.init, scsh.init, chez.init, elk.init (slib:features): Added defmacro. 2007-12-21 Aubrey Jaffer * slib.nsi: Added *.init files. * slib.sh, slib.1: Added Larceny. * slib.texi (Installation): Added Larceny. * README (Implementation-specific Instructions): Updated. 2007-12-20 Aubrey Jaffer * prec.scm (prec:parse-delimited): First (recursive) clause was missing argument. 2007-12-18 Aubrey Jaffer * guile.init ((ice-9 slib)): "ice-9/slib.scm" doesn't become valid (and shorter) until version guile-1.8.3. 2007-12-08 Aubrey Jaffer * Makefile (catalogs): Copy "mkpltcat.scm" to "mkimpcat.scm" in mzscheme's implementation-vicinity. (mkfiles): Added "mkpltcat.scm". * mkpltcat.scm: "mkimpcat.scm" for mzscheme which adds all supported SRFIs to the catalog. * mzscheme.init (slib:features): Added format. (slib:load-compiled): Handle SRFI requires. * slib.texi (Spectra): Clarified action of features cie1964, cie1931, and ciexyz. 2007-11-29 Aubrey Jaffer * slib.texi (Installation): Documented *_IMPLEMENTATION_PATHs. * slib.sh: mzscheme.init renamed from DrScheme.init. * mzscheme.init: Renamed from DrScheme.init. * Makefile (ifiles): mzscheme.init renamed from DrScheme.init. * Template.scm (implementation-vicinity): Environment variable {TEMPLATE}_IMPLEMENTATION_PATH overrides. * mitscheme.init (implementation-vicinity): Environment variable MITSCHEME_IMPLEMENTATION_PATH overrides. * vscm.init (implementation-vicinity): Environment variable VSCM_IMPLEMENTATION_PATH overrides. * STk.init (implementation-vicinity): Environment variable STK_IMPLEMENTATION_PATH overrides. * RScheme.init (implementation-vicinity): Environment variable RSCHEME_IMPLEMENTATION_PATH overrides. * jscheme.init (implementation-vicinity): Environment variable JSCHEME_IMPLEMENTATION_PATH overrides. * gambit.init (implementation-vicinity): Environment variable GAMBIT_IMPLEMENTATION_PATH overrides. * elk.init (implementation-vicinity): Environment variable ELK_IMPLEMENTATION_PATH overrides. * chez.init (implementation-vicinity): Environment variable CHEZ_IMPLEMENTATION_PATH overrides. * bigloo.init (program-arguments): Defined per information on http://practical-scheme.net/wiliki/schemexref.cgi?command-line and http://practical-scheme.net/wiliki/schemexref.cgi?executable-name. (implementation-vicinity): Environment variable BIGLOO_IMPLEMENTATION_PATH overrides. * guile.init (slib:features): Abstracted defined? tests. (implementation-vicinity): Environment variable GUILE_IMPLEMENTATION_PATH overrides. * DrScheme.init, elk.init (program-arguments): Fake the program name (first element) from scheme-implementation-type. (implementation-vicinity): Environment variable MZSCHEME_IMPLEMENTATION_PATH overrides. * scsh.init (program-arguments): Defined to command-line per http://practical-scheme.net/wiliki/schemexref.cgi?command-line * scheme48.init (program-arguments): Removed dummy definition. * sisc.init (library-vicinity, implementation-vicinity): Find path once. * scheme2c.init, kawa.init, umbscheme.init (implementation-vicinity): find path once. * slib.texi (System Interface): Added program-arguments. 2007-11-28 Aubrey Jaffer * slib.sh (Usage): Updated implementation list. * slib.texi (The SLIB script): Updated implementation list. 2007-11-27 Aubrey Jaffer (slib:load): Broken for Guile-1.6.7; conditioned 1.8 code. 2007-11-27 Rob Browning * guile.init (implementation-vicinity): Just (%site-dir). (file-position, gentemp): module-replace! (library-vicinity): Try (%search-load-path "slib/guile.init"). 2007-11-23 Aubrey Jaffer * require.scm (*slib-version*): Bumped from 3a4 to 3a5. * Makefile (new): Update jacal.texi. 2007-11-22 Aubrey Jaffer * mkclrnam.scm (load-rgb-txt): Added parser for Color-Naming-Experiment. 2007-11-03 Aubrey Jaffer * slib.texi (Input/Output): Added file-position. * elk.init, jscheme.init, kawa.init, macscheme.init, mitscheme.init, RScheme.init, bigloo.init, guile.init, pscheme.init, scheme2c.init, scheme48.init, scsh.init, sisc.init, STk.init, Template.scm, gambit.init, t3.init, umbscheme.init, vscm.init (file-position): Added procedure to set and retrieve file position. 2007-10-20 Aubrey Jaffer * DrScheme.init (slib:require): Removed superfluous definition. 2007-10-13 Aubrey Jaffer * slib.texi (System): Cleaned up browse-url entry. * require.scm: Check up to srfi-150. 2007-09-23 Aubrey Jaffer * guile.init (array?): Put in fix for (array? 'foo) returning #t. 2007-09-23 Robert Babbit * guile.init (system, delete-file, open-file, make-array): Changed from SET! to DEFINE and added Guile 1.8 module magic. 2007-09-04 Aubrey Jaffer * sisc.init: SISC has defmacro, but not macroexpand. 2007-09-03 Aubrey Jaffer * Makefile (srcdir.mk): Removed. (install*): Added $(DESTDIR) prefix. (ifiles): Added sisc.init. * ANNOUNCE, README, slib.sh, slib.texi: Added SISC. * sisc.init: Added. (slib:features): Added string-port. 2007-08-29 Aubrey Jaffer * dbinterp.scm (dbinterp:memoize): LAST-PAIR replaces LIST-TAIL. (interpolate-from-table): Removed memoizing from get, isam-prev. * mklibcat.scm, slib.texi, FAQ (SRFI): Added srfi-28. 2007-08-26 Aubrey Jaffer * FAQ (SRFI): Added section. * slib.texi (SRFI): Added srfi-94 and srfi-95. * Makefile (release): Update $(htmldir)SLIB.FAQ. 2007-08-24 Aubrey Jaffer * slib.texi (SRFI): Added 94 and 95. 2007-08-16 Aubrey Jaffer * array.scm (A:floR*b): Argument letter z --> x. (A:flo*d): Corrected typo (was A:flo*b); argument letter z --> q. (A:*): Coded TeXinfo explicitly to preserve procedure name case. 2007-07-24 Aubrey Jaffer * schmooz.scm (pathname->local-filename): Renamed from pathname->filename; put returned filename in user-vicinity. 2007-07-22 Aubrey Jaffer * schmooz.scm (pathname->filename): Added; complement to pathname->vicinity. (schmooz): Put generated .txi files in current directory. * Makefile (slib.fn): Removed. 2007-06-24 Aubrey Jaffer * determ.scm (matrix:sum, matrix:difference): Added. (matrix:product): Extended to multiplication by scalar. 2007-06-18 Aubrey Jaffer * Makefile (ifiles): Added kawa.init. * kawa.init: Added. getenv not available; so library-vicinity is hard-wired. * slib.texi (Bit-Twiddling): Added r6rs bitwise-bit-count. (Feature): Added kawa. * logical.scm (bitwise-bit-count): Added; returns negative integer for negative input. (logcount): Simplified in terms of bitwise-bit-count. 2007-06-08 Aubrey Jaffer * Makefile: Changed to use "mkdir -p" (per Marijn Schouten). 2007-05-31 Aubrey Jaffer * arraymap.scm (array-index-for-each): Added. (array-index-map!): Implemented in terms of array-index-for-each. 2007-05-01 Aubrey Jaffer * xml-parse.scm: Finished converting documentation to schmooz. * mklibcat.scm (ssax): Added alias for xml-parse. 2007-04-30 Aubrey Jaffer * xml-parse.scm (ssax:init-buffer): Made reentrant. (ssax:make-parser): Added argument length check. 2007-04-29 Aubrey Jaffer * slib.texi (Parsing XML): Added. * Makefile (txiscms): Added xml-parse. * xml-parse.scm: Added (demacroized from public-domain SSAX 5.1). 2007-04-28 Aubrey Jaffer * Makefile (slib.html): Make in unix for w32install because MinGW chokes on @syncodeindex. 2007-04-26 Aubrey Jaffer * mklibcat.scm (let-values): Added as alias for srfi-11. * hash.scm: Reordered definitions to suit Kawa. 2007-04-25 Aubrey Jaffer * slib.texi (Binding to multiple values): srfi-11 added. * srfi-11.scm: Added (http://srfi.schemers.org/srfi-11/srfi-11.html). 2007-04-19 Aubrey Jaffer * comparse.scm, dbutil.scm, slib.texi, solid.scm: Don't break @ref fields over lines. * batch.scm (batch:initialize!): Keep atari.st for legacy code. 2007-04-13 Aubrey Jaffer * slib.sh (Kawa): Now supported. * withfile.scm, trnscrpt.scm: Changed shadow bindings to not duplicate top-level names. * require.scm (slib:require, slib:require-if, slib:provide, slib:provided?): Reordered defines so Kawa loads successfully. 2007-04-07 Aubrey Jaffer * differ.scm (diff:edits): Finding edits needs a larger fp array than finding edit-length. 2007-03-28 Aubrey Jaffer * batch.scm (batch:initialize!): atari.st --> atari-st. * manifest.scm (feature->export-alist): path.scm --> path_scm. * cring.scm, wttree.scm: Replaced . with _ in identifier names for R4RS compatibility. * collect.scm (reduce): Support both comlist (2-argument) variant and the collect (> 2-argument) variant. * srfi-1.scm (reduce): Support both comlist (2-argument) variant and the SRFI-1 (3-argument) variant. 2007-03-26 Aubrey Jaffer * slib.texi (Sorting): Added srfi-95. * require.scm (slib:report, slib:report-locations): Changed shadow bindings to not duplicate top-level names. Code cleanup. * root.scm (integer-sqrt): Removed (now in "math-integer.scm"). * mularg.scm (/, -): Removed gratuitous shadow binding. * mklibcat.scm (srfi-95): Added alias for sort. 2007-03-05 Jerry van Dijk * Makefile (w32install): Added target. * slib.nsi: NSIS Windows installer script. 2007-03-05 Aubrey Jaffer * jscheme.init (force-output): Fixed typo. (scheme-implementation-version): 7.2. (gcd, lcm, round, atan, expt): Fixed some R5RS non-conformances. 2007-02-09 Taylor R. Campbell * mitscheme.init: TRANSFORMER-ITEM/EXPANDER is changed to STRIP-KEYWORD-VALUE-ITEM. 2007-01-28 Aubrey Jaffer * guile.init (gentemp): Added because Guile deprecates it and puts space in symbol name. 2007-01-03 Aubrey Jaffer * bytenumb.scm (ieee-float->bytes, ieee-double->bytes): Test for 0 and 0/0 only once. 2006-12-20 Aubrey Jaffer * bytenumb.scm (ieee-float->bytes, ieee-double->bytes): Changed abs to magnitude to work with 0/0. 2006-12-06 Aubrey Jaffer * qp.scm (qpn, qpr): Don't protect (capture) qp. 2006-11-23 Aubrey Jaffer * slib.texi (Sorting): Removed outdated survey of implementations. * sort.scm (sort:sort-list!): Don't do key-wrap! unless given key argument. 2006-11-22 Ivan Shmakov * scheme48.init (delete-file): Rewrote using Posix unlink. 2006-11-17 Aubrey Jaffer * elk.init (delete-file): Quoted filename to system. * scheme2c.init (delete-file, file-exists?): Quoted filename to system. * scheme48.init (delete-file): Quoted filename to system. * umbscheme.init (file-exists?, delete-file): Quoted filename to system. * vscm.init (file-exists?): Quoted filename to system. * batch.scm (batch:call-with-output-script): Quoted filename argument to chmod. 2006-11-10 Stéphane Rollandin * mwdenote.scm (mw:denote-of-define-macro, mw:denote-of-defmacro): Added. * mwexpand.scm (mw:expand): Don't expand DEFINE-MACRO args specs. 2006-11-06 Aubrey Jaffer * slib.texi (Sorting): Made asymptotic constraints more detailed. * slib.texi (Sorting): Updated for limited KEY arg calling. 2006-11-05 Aubrey Jaffer * sort.scm (sorted?, merge, merge!, sort, sort!): Call KEY arg at most once per element. 2006-11-04 Aubrey Jaffer * modular.scm (modular:*): Normalize inputs. 2006-11-01 Aubrey Jaffer * slib.texi: Eliminated cover texts from GFDL. 2006-10-29 Aubrey Jaffer * grapheps.ps (fudge3): Abstracted divisible-by-3 mess. 2006-10-21 Aubrey Jaffer * require.scm (*slib-version*): Bumped from 3a3 to 3a4. 2006-10-21 Aubrey Jaffer * grapheps.scm (plot): Handle list of lists data. 2006-10-13 Aubrey Jaffer * slib.texi (Sorting): Updated; cleaned up. * sort.scm (merge!): Fixed. (sort!): Swap pairs so that list returned EQ? to argument. 2006-10-11 Aubrey Jaffer * slib.texi (Sorting): Added optional KEY arguments. * sort.scm (sort, sort!, sorted?, merge, merge!): Added optional KEY argument. 2006-09-26 Aubrey Jaffer * dft.scm (dft, dft-1): Added routines which use the best method for decimating each dimension. (dft:dft): Call 1d transform only with contiguous arrays. (dft:dft): Tested and fixed for ranks 1 to 3. 2006-09-21 Aubrey Jaffer * dft.scm (dft:check-dimensions): Abstracted from fft and fft-1. 2006-09-19 Aubrey Jaffer * tzfile.scm (tzfile:read): Use subbytes instead of subarray. * byte.scm (subbytes): Added. (subbytes-read!, subbytes-write): Renamed from substring-... 2006-09-17 Aubrey Jaffer * Makefile (txiscms): Aded math-integer. (afiles): Added math-real. * slib.texi (Irrational Real Functions) (Irrational Integer Functions): Sections added. * math-integer.scm, math-real.scm: Added. 2006-09-15 Aubrey Jaffer * slib.texi (Feature): Indexed number-system attribute features. * require.scm: Tightened number-system attribute features. 2006-09-14 Aubrey Jaffer * indexes.texi (Index): Removed "Full Table of Contents". * slib.texi (SRFI): Added @ftindex entries. 2006-09-13 Aubrey Jaffer * slib.texi (SRFI): Added @ftindex entries for SRFIs. * vscm.init, umbscheme.init, Template.scm, t3.init, STk.init, scsh.init, scheme2c.init, RScheme.init, mitscheme.init, macscheme.init, jscheme.init, gambit.init, elk.init, DrScheme.init, chez.init, bigloo.init (slib:error): Capture `error' identifier (to survive redefinition). * srfi-23.scm (error): File added. * elk.init (slib:error): Removed bad insertion. 2006-09-12 Aubrey Jaffer * peanosfc.scm (peano-coordinates->integer) (integer->peano-coordinates): Fixed; were broken for rank != 2. 2006-09-10 Aubrey Jaffer * root.scm (integer-sqrt): Streamlined. 2006-09-05 Aubrey Jaffer * dft.scm (sft, sft-1, fft, fft-1): Added optional array-prototype argument. * subarray.scm (subarray): Handle reverse index ranges. 2006-09-04 Aubrey Jaffer * pnm.scm (pnm:array-write): Don't lose comments when recursing. * dft.scm (sft, sft-1): Slow Fourier transforms added. (dft:sft1d!, dft:fft1d!): Flipped polarity of exponent to agree with http://en.wikipedia.org/wiki/Discrete_Fourier_transform. * dft.scm: Renamed from "fft.scm". 2006-09-03 Aubrey Jaffer * fft.scm (fft:dft): Generalized to any positive rank. 2006-09-02 Aubrey Jaffer * slib.spec (%files): Added man1/slib.1.gz. 2006-08-13 Aubrey Jaffer * grapheps.ps (sign): Cleaner than inline code. 2006-08-10 Aubrey Jaffer * Makefile (dvi, pdf): New tetex-3.0(-20.FC5) broke them -- fixed. 2006-08-01 Aubrey Jaffer * grapheps.ps (setup-plot): Now handles decreasing axes. 2006-07-24 Aubrey Jaffer * grapheps.scm (rule-horizontal): Corrected documentation. 2006-07-10 Aubrey Jaffer * root.scm (secant:find-root-1): Fixed internal argument mismatch for number-of-iterations case. 2006-06-25 Aubrey Jaffer * bigloo.init (slib:features): Lacks object-hash. 2006-06-02 Aubrey Jaffer * getopt.scm (*argv*): Removed (define *argv* *argv*). 2006-05-21 Aubrey Jaffer * solid.scm (solid:prism, solid:lumber): Added. 2006-05-16 Aubrey Jaffer * array.scm (make-shared-array): Work for rank-0 arrays. (equal?): Compare element-by-element of two arrays. (make-array): Return string or vector even if prototype is a strict array. 2006-05-15 Aubrey Jaffer * array.scm (make-array): Return simple string or vector if possible. 2006-05-14 Aubrey Jaffer * slib.texi: Converted to @copying and GNU Free Documentation License. * Makefile (docs): Added target to make all documentation files and invoke xdvi. (texifiles): Added fdl.texi. 2006-05-13 Aubrey Jaffer * bigloo.init (slib:load): Fixed suffix lossage. (slib:features): Removed object->string and rationalize. * strcase.scm (symbol-append): Work with case-sensitive or case-insensitive symbols. 2006-05-01 Ivan Shmakov * scheme48.init (file-exists?): Much simplified. 2006-04-23 Kevin Ryde * guile.init: Fixed line-i/o in Guile >= 1.8. * srfi-1.scm (reduce-right): Was infinite loop. 2006-04-19 Aubrey Jaffer * *.init, Template.scm, require.scm (slib:features): Renamed from *features* to avoid conflict with Guile identifier. 2006-04-15 Aubrey Jaffer * Makefile (S48LIB): Renamed from LIB. (S48SLIB): Subdirectory of implementation-vicinity. (install48): Make $(S48SLIB) directory and files. 2006-04-05 Ben Goetter * pscheme.init: Revised for Pscheme 1.3. 2006-04-03 Aubrey Jaffer * simetrix.scm (SI:unit-infos): Updated u and eV to CODATA-2002. 2006-03-27 Aubrey Jaffer * require.scm (catalog:get): Handle (home-vicinity) being false. 2006-03-21 Aubrey Jaffer * scheme48.init: (slib:load-compiled): Loads a native SRFI module. Create "implcat" and new-catalog with native SRFI modules. 2006-03-19 Aubrey Jaffer * modular.scm (modular:characteristic, modular:+): Recoded so `-' has no more than 2 arguments. 2006-03-18 Aubrey Jaffer * scheme48.init (slib-primitives): Removed s48-modulo and s48-atan. * guile.init (char-code-limit): Reduced to workaround string ordering bug. 2006-03-17 Aubrey Jaffer * guile.init (system, delete-file, open-file, make-array): Changed from define to set! to eliminate guile-1.8.0 warning: WARNING: (guile-user): imported module (ice-9 slib) overrides core binding 2006-03-16 Aubrey Jaffer * guile.init (defined?, in-vicinity, port?, 1+, -1+, 1-): Removed definitions duplicating Guile defines. (*features*): Set, rather than define. (browse-url): Added. * require.scm (catalog:get): mklibcat is `source'. (require): Don't provide `new-catalog'. * mklibcat.scm: Change all slib files to `source'. 2006-03-01 Aubrey Jaffer * modular.scm (mod, rem): Removed. (modular:characteristic): Renamed from modulus->integer. (modular:expt): Handle base = modulus - 1. Corrected documentation. 2006-02-13 Aubrey Jaffer * require.scm (*slib-version*): Bumped from 3a2 to 3a3. 2006-02-02 Aubrey Jaffer * grapheps.scm (graph:plot): Plot multiple traces from array. (functions->array): Generalizes graph:plot-function. 2006-01-16 Aubrey Jaffer * guile.init (slib:load, slib:load-from-path): Adapted patch from Thomas Bushnell BSG for loading into SLIB module. * top-refs.scm (top-refs:expression): Check for lists before walking CASE and COND clauses (srfi-61.scm macro broke it). 2006-01-09 Aubrey Jaffer * http-cgi.scm (query-alist->parameter-list): Fixed order of nary fields. 2006-01-05 Aubrey Jaffer * db2html.scm (command:make-editable-table): Boolean "arity". * http-cgi.scm (http:status-line): Changed to HTTP-1.0; works better in MS-Windows. 2005-12-01 Aubrey Jaffer * require.scm, mklibcat.scm, mkclrnam.scm, alistab.scm, Makefile: Downcased *slib-version* symbol. * guile.init (home-vicinity): Check for getenv first. (*features*): Fixed array, system, etc. (system->line): Fixed return status (thanks to Rob Browning). (guile:wrap-case-insensitive): Removed; sources now case clean. * dirs.scm, transact.scm, batch.scm, prec.scm, Template.scm, *.init: Downcased all software-type symbols. 2005-11-26 Aubrey Jaffer * guile.init (system->line): Added features line-i/o and hash. (implementation-vicinity): Fixed to parent directory of ice-9. 2005-11-01 Aubrey Jaffer * peanosfc.scm (peano-coordinates->natural) (natural->peano-coordinates): Non-negative versions. 2005-10-29 Aubrey Jaffer * bytenumb.scm (bytes->ieee-float, bytes->ieee-double) (ieee-float->bytes, ieee-double->bytes): Fixed for -0.0. 2005-10-25 Aubrey Jaffer * bytenumb.scm (ieee-float->bytes, ieee-double->bytes): Handle 0/0 in srfi-70 arithmetic. 2005-10-18 Aubrey Jaffer * slib.texi (SRFI): Added table mapping SRFI to feature. (Scheme Syntax Extension Packages): Moved most SRFIs here. * mklibcat.scm (and-let*, receive, define-record-type) (guarded-cond-clause): Added aliases for srfi-2, srfi-8, srfi-9, and srfi-61. * srfi.scm: Removed comments about copyright. * slib.spec (%post): Commented out install-info. * Makefile (srfiles): Most srfi-* moved from txiscms. (srfiles): Added srfi-61. 2005-10-17 Ivan Shmakov * srfi-61.scm (cond): Added extension. * mklibcat.scm (srfi-61): Added. 2005-10-16 Aubrey Jaffer * slib.texi (Root Finding): integer-sqrt changed to floor of sqrt. * root.scm (integer-sqrt): Changed to algorithm attributed to Bradley Lucier by Steve VanDevender. 2005-09-25 Aubrey Jaffer * slib.spec: Updated from RedHat version from Jindrich Novy. * guile.init (sub-vicinity): Downcased software-type symbols. 2005-08-16 Aubrey Jaffer * slib.texi (The Limit): Added. 2005-08-09 Aubrey Jaffer * slib.texi (Array Mapping): Added. * linterp.scm (interpolate-array-ref, resample-array!): Added. 2005-07-28 Aubrey Jaffer * phil-spc.scm (hilbert-coordinates->integer): nbits calculation was missing (incorrectly used rank). (bitwise-laminate, bitwise-delaminate): Removed unused functions. 2005-06-22 Aubrey Jaffer * slib.spec (install): Make slib executable. 2005-06-18 Aubrey Jaffer * Makefile (rpm): Program name changed to rpmbuild. * slib.spec: Fixed for rpmbuild version 4.3.1 2005-06-04 Aubrey Jaffer * require.scm (*SLIB-VERSION*): Bumped from 3a1 to 3a2. 2005-05-08 Aubrey Jaffer * Makefile (allfiles): Added clrnamdb.scm. 2005-04-15 Aubrey Jaffer * slib.texi (Installation): Instructions to replace Guile's built-in slib directory. 2005-04-14 Aubrey Jaffer * dynwind.scm (with-load-pathname): Redefinition removed. * slib.texi (Vicinity): with-load-pathname moved from System. * require.scm: Moved vicinity definitions to *.init. * Template.scm, *.init: Now contains all vicinity definitions. * pnm.scm (pnm:image-file->array, pnm:array-write): Support up to 16-bit values. * slib.texi (Color Data-Type): Expanded make-color description. * color.scm (make-color): Apply conversion function. 2005-04-11 Aubrey Jaffer * timecore.scm (time:year-70): Fixed -- was very broken. 2005-03-22 Aubrey Jaffer * solid.scm (solid:polyline): Added. 2005-03-20 Kevin Ryde * guile.init (?, >=?): Added rev2-procedures. (delete-file): Return #f for failure (not bomb). (system, open-file): Made compatible with SLIB. 2005-03-18 Reed Sheridan * uri.scm (uri:decode-authority, uri:split): Remove colon from end of idx-: (renamed cdx) to work around Gambit keyword syntax. 2005-03-18 Aubrey Jaffer * Makefile (install): Installs in $(libdir)slib/. (uninstall): Fixed. 2005-03-16 Aubrey Jaffer * array.scm (array->vector): Return vector for rank-0 array. 2005-03-13 Aubrey Jaffer * solid.scm (solid:text, solid:font): Added. (solid:extract-elevations): Rein in line length. 2005-03-07 Aubrey Jaffer * guile.init (a:*): Added case-insensitive aliases. (random:chunk): Added. 2005-03-06 Aubrey Jaffer * differ.scm (diff:edit-length): Reconciled case for Guile. * solid.scm (solid:bry): Fixed scaling off-by-one error. 2005-02-24 Aubrey Jaffer * phil-spc.scm (delaminate-list): Added. (integer->hilbert-coordinates, hilbert-coordinates->integer): Use lists of integers instead of bignums for intermediate results. 2005-02-23 Aubrey Jaffer * phil-spc.scm (integer->hilbert-coordinates) (hilbert-coordinates->integer): Distributed rank-bit flipping. 2005-02-21 Aubrey Jaffer * phil-spc.scm (hilbert-coordinates->integer) (integer->hilbert-coordinates): Added optional width argument treating integers as fractional bits. 2005-02-18 Aubrey Jaffer * grapheps.scm (set-margin-templates): Added. 2005-02-06 Aubrey Jaffer * peanosfc.scm: Peano space filling curve added. 2005-01-27 Aubrey Jaffer * logical.scm (any-bits-set?, first-set-bit, bitwise-merge): Added remaining SRFI-33 aliases. 2005-01-24 Aubrey Jaffer * guile.init: Removed gray-code functions (for SRFI-60). * logical.scm: Moved gray-code to "phil-spc.scm" (for SRFI-60). * phil-spc.scm: Moved gray-code functions from "logical.scm". 2005-01-23 Aubrey Jaffer * slib.texi (The SLIB script): Added section. * Makefile (uninstall): Added. (pinstall): Install slib.1 2005-01-20 Aubrey Jaffer * gambit.init: Major update for Gambit-C 4.0b12. * slib.texi (Define-Structure): Documentation from Gambit-C 4.0. * timecore.scm (tzfile:transition-index, time:split): Cleaned to work with Gambit-C time datatype. * Makefile (install): Include definition for S48_VICINITY. 2005-01-19 Aubrey Jaffer * http-cgi.scm (http:forwarding-page): Renamed DELAY argument. * htmlform.scm (html:meta-refresh): Renamed DELAY argument. * slib.sh (gsi): Gambit 4.0 doesn't allow input redirection; foils --version test. 2005-01-16 Aubrey Jaffer * array.scm: Fixed documentation. (make-array): Rank 0 arrays are box. (array->vector, array->list): Added. (list->array, vector->array): Added. 2005-01-09 Aubrey Jaffer * html4each.scm (htm-fields): Don't warn about empty ALT fields. * slib.texi (Bit-Twiddling): Updated for SRFI-60 changes. * phil-spc.scm: Updated for logical.scm changes. (bitwise-delaminate, bitwise-laminate): Moved from logical.scm. * logical.scm (logical:reduce): Handle null arity. (reverse-bit-field): Replaced bit-reverse export. (rotate-bit-field): Replaced logical:rotate export. (copy-bit-field): Chaned argument order. Laminates moved to "phil-spc.scm". ARITHMETIC-SHIFT replaces interal uses of ASH. 2005-01-07 Aubrey Jaffer * guile.init (expt): Workaround removed. LOGICAL: aliases removed. * sort.scm, pnm.scm, matfile.scm, logical.scm, grapheps.scm, fft.scm, differ.scm, determ.scm, charplot.scm, arraymap.scm: MAKE-ARRAY replaced CREATE-ARRAY. 2004-12-27 Aubrey Jaffer * array.scm (Ac64, Ac32, Ar64, Ar32): Added word "inexact" to descriptions. 2004-12-22 Aubrey Jaffer * vet.scm (vet-slib): Accept file arguments to include in vetting. 2004-12-19 Aubrey Jaffer * slib.texi (Bit-Twiddling): Updated and shuffled. * logical.scm (logand, logior, logxor): Take one or more arguments. 2004-11-14 Aubrey Jaffer * scheme48.init (inexact->exact, exact->inexact, atan, modulo): Bugs have been fixed in 1.1 2004-11-13 Aubrey Jaffer * scheme48.init: From s48-0_57.init, which works with Scheme48 1.1 2004-11-09 Aubrey Jaffer * db2html.scm (table->linked-html): Chop tables into 50-row chunks. * tzfile.scm (tzfile:read): Use bytes, not strings. * pnm.scm (pnm:write-bits): Added. * array.scm (make-shared-array): Recoded 3-arg -. 2004-10-27 Aubrey Jaffer * timezone.scm (read-tzfile): Check for "/etc/localtime". * psxtime.scm (tzset, daylight?, *timezone*, tzname): Moved from "timezone.scm". * slib.texi (Time Infrastructure): Added. * Makefile (afiles): Added "timecore.scm". * timecore.scm: Core time conversion routines split from "psxtime.scm". 2004-10-16 Aubrey Jaffer * html4each.scm (htm-fields): Handle field without value. 2004-10-15 Aubrey Jaffer * slib.texi (Cyclic Checksum): Added citation for Philip Koopman and his exhaustive analysis of CRC behavior. 2004-10-13 Aubrey Jaffer * byte.scm (bytes-reverse!): Was hosed for even number of bytes. 2004-10-10 Aubrey Jaffer * slib.texi (SRFI): SRFI-47 is the same as 'array. * colorspc.scm (read-normalized-illuminant, illuminant-map) (illuminant-map->XYZ): Added. (wavelength->CIEXYZ, XYZ:normalize, XYZ:normalize-colors) (temperature->CIEXYZ, spectrum->CIEXYZ, wavelength->CIEXYZ): Removed; use chromaticity functions instead. * daylight.scm (sunlight-chromaticity): Replaces sunlight-CIEXYZ. * solid.scm (scene:sun, scene:overcast): Use chromaticity to normalize XYZ values. * subarray.scm (subarray, array-trim): Rewrote for all-0-based arrays. 2004-10-07 Aubrey Jaffer * arraymap.scm (array-map!, array-for-each, array-index-map!): Use of ARRAY-DIMENSIONS replaces use of ARRAY-SHAPE. (make-shared-array): converted. * array.scm: Made compatible with SRFI-47. (equal?): Replaces array=?. (make-array): Restored. * schmooz.scm (schmooz-fun): Latest Texinfo needs additional blank lines after @end statements converting to info. 2004-10-03 Aubrey Jaffer * colorspc.scm (read-cie-illuminant): Added. * ciesia.dat: Added CIE Standard Illuminant A relative spectral power distribution 300 nm - 830 nm at 5 nm intervals. * ciesid65.dat: Added CIE Standard Illuminant D65 relative spectral power distribution 300 nm - 830 nm at 5 nm intervals. 2004-09-22 Aubrey Jaffer * slib.texi (Miscellany): Added EXPT for integers. * cring.scm (number^): Is EXPT. * modular.scm (modular:expt): EXPT replaces integer-expt. * bytenumb.scm (expt): Replaces BN:EXPT. * logical.scm (expt): Replaces INTEGER-EXPT. * Template.scm (expt): Define for exacts-only implementation. 2004-09-14 Aubrey Jaffer * arraymap.scm (array:copy!): Renamed from array-copy! and argument order reversed. 2004-09-04 Aubrey Jaffer * batch.scm (batch:write-comment-line): Simplified. (batch-line): Issue warning, but don't fail when line is too long. 2004-08-21 Aubrey Jaffer * format.scm (format:get-port-column, format:set-port-column!): Added to track individual port columns. * FAQ (What happened to FORMAT?): Question removed. * format.scm: Tidied slib:error messages. * Makefile (texifiles, format.texi): Added. * format.texi, formatst.scm: Reinstated. * format.scm: Made reentrant; call slib:error for errors. 2004-08-11 Aubrey Jaffer * matfile.scm (unwritten-stubber): Place holder for VAX and Cray floating conversions. 2004-08-10 Aubrey Jaffer * slib.texi (Session Support): Documented 'abort feature. * determ.scm (matrix2array, matrix2lists): Changed to 0-base. 2004-07-28 Aubrey Jaffer * top-refs.scm (exports<-info-index): Adjusted for texinfo 4.7, which breaks long index lines. 2004-07-27 Aubrey Jaffer * Makefile (docfiles): Added indexs.texi. * slib.texi (Top, About SLIB): Changed conditional for texinfo 4.7. * indexs.texi (Index): Give each index its own node. Moved index stuff here so it doesn't break texinfo-every-node-update. 2004-06-17 Ivan Shmakov * coerce.scm (type-of): Removed RECORD. * hash.scm (hash): Removed obsolete support for RECORD types. 2004-06-14 Aubrey Jaffer * *.init (slib:eval-load): Moved to "require.scm". * require.scm (slib:eval-load): Definition moved here. 2004-06-13 Aubrey Jaffer * slib.texi (System): Added with-load-pathname. * dynwind.scm (with-load-pathname): Redefine using dynamic-wind. * require.scm (vicinity:suffix?): Flag unknown SOFTWARE-TYPE. * *.init (slib:eval-load): Converted to use with-load-pathname. 2004-06-13 Ivan Shmakov * manifest.scm (file->loads, file->definitions, file->exports): * top-refs.scm (top-refs:include): * ppfile.scm (pprint-filter-file): * Template.scm (slib:eval-load): * repl.scm (repl:repl): Converted to use with-load-pathname. * require.scm (with-load-pathname): Added. 2004-06-12 Aubrey Jaffer * coerce.scm (type-of): Vector has priority over array. 2004-06-10 Aubrey Jaffer * trace.scm (debug:trace-procedure): Use 'call and 'retn instead of (string->symbol "CALL") to avoid slashification. * qp.scm (qp): Put ellipsis (...) in middle of strings, symbols. 2004-06-03 Aubrey Jaffer * slib.texi (Random Numbers): Don't change PRNG seed (URL). 2004-05-23 Aubrey Jaffer * dbutil.scm (close-database): Don't lock immutable dbs. 2004-05-19 Aubrey Jaffer * solid.scm (solid:cylinder): Negative radius for invisible side. 2004-04-20 Aubrey Jaffer * differ.scm (diff:mid-split): Removed unused M argument. 2004-04-16 Aubrey Jaffer * differ.scm: Removed equality predicate arguments. 2004-04-14 Aubrey Jaffer * differ.scm (diff2ez): Interleave insertions and deletions. (diff2editlen, diff2edits!, edits2lcs!, diff:invert-edits!): Derive lengths from array-dimensions. (diff:edit-length, diff:edits, diff:longest-common-subsequence): Moved all array creation to top-level API. 2004-04-11 Aubrey Jaffer * differ.scm (diff:negate-edits!): diff:fixup-edits Remnant. (diff:fixup-edits): Removed unnecessary procedure. (diff:longest-common-subsequence): Removed diff:order-edits call. (sort): Feature no longer required. 2004-03-20 Aubrey Jaffer * transact.scm (file-lock!): Don't call EMACS:LOCK! unless CURRENT-TIME is provided. * Makefile (S48INIT): Abstracted .init file. (IMAGE48): Renamed from IMAGE. 2004-03-20 Ivan Shmakov * s48-0_57.init (slib:warn, string-port): native functions based. (slib-primitives): Makes transact.scm work with Scheme48 0.57. 2004-03-19 Aubrey Jaffer * transact.scm (word-lock:certificate): Test file's existence before OPEN-FILE. 2004-03-07 Aubrey Jaffer * differ.scm (fp:run): Removed gratuitous variable KFPOFF. (diff:mid-split): Removed unused definitions. (diff:fixup-edits): Abstracted from DIFF:ORDER-EDITS. Procedures grouped into API and supporting procedures. 2004-03-01 Radey Shouman * pnm.scm (pnm:type-dimensions): Allow comments beginning with # and ending with newline in pnm file headers as required by libppm documentation. 2004-02-08 Aubrey Jaffer * manifest.scm (file->requires): Don't squawk if feature not in catalog. Read through non-lists at top level. * colorspc.scm (temperature->XYZ): Use blackbody-spectrum default span. 2004-02-01 Aubrey Jaffer * manifest.scm (file->requires, file->loads, file->definitions) (file->exports): Ignore first line if it begins with '#'. (feature->requires*, file->requires*): Added transitive closures. 2004-01-31 L.J. Buitinck * soundex.scm (soundex): Converted to use dotted pairs for CODES. 2004-01-31 Aubrey Jaffer * solid.scm (scene:viewpoint): Restored earlier code which works with current freewrl. (solid:bry, solid:extract-elevations, solid:extract-colors): ARRAY-DIMENSIONS replaced ARRAY-SHAPE. * grapheps.scm (write-array-def): ARRAY-DIMENSIONS replaced ARRAY-SHAPE. * charplot.scm (charplot:plot, charplot:data->lists): ARRAY-DIMENSIONS replaced ARRAY-SHAPE. * sort.scm (sorted?, sort!, rank-1-array->list, sort): ARRAY-DIMENSIONS replaced ARRAY-SHAPE. 2004-01-20 Aubrey Jaffer * bigloo.init (slib:load): Source or compiled. 2004-01-16 Aubrey Jaffer * Makefile ($(infodir)slib.info): "cp -a" ==> "cp -p". * slib.sh: grep -q is not universal. 2004-01-14 Aubrey Jaffer * slib.sh: Separated shell assignments and exports. * Makefile (srcdir.mk): Include after target. Separated shell assignments and exports. 2004-01-13 Aubrey Jaffer * DrScheme.init (slib:warn): Added newline. 2004-01-11 Aubrey Jaffer * differ.scm (diff2editlen, diff2edits): 0-based fp. (fp:compare, fp:run, fp:init! diff:divide-and-conquer) (diff2et, diff2ez): 0-based fp; added fpoff argument. * scamacr.scm (let*): Fixed syncase:andmap reference. * slib.texi (provided?): Add scheme-implementation-type footnote. * mitscheme.init (slib:error): Dispatch to special error routines. * wttree.scm (error:error, error:wrong-type-argument): (error:bad-range-argument): Changed to SLIB:ERROR. * require.scm (provided?): Answer #t to (scheme-implementation-type). 2004-01-09 L.J. Buitinck * srfi-1.scm (filter!): Updated. 2004-01-09 Ken Anderson * jscheme.init (scheme-implementation-version): 6.2. (defmacro): Made native. 2004-01-08 Aubrey Jaffer * batch.scm (*operating-system*): SOFTWARE-TYPE symbols are uppercase. 2004-01-06 Ken Anderson * jscheme.init: Added. 2004-01-04 Aubrey Jaffer * vscm.init, umbscheme.init, scsh.init, macscheme.init, guile.init, gambit.init, elk.init, chez.init, STk.init, RScheme.init, Template.scm, pscheme.init, t3.init, scheme48.init, scheme2c.init, s48-0_57.init, mitscheme.init, bigloo.init (*features*): Regularized order and content. * slib.texi (Rev4 Optional Procedures): Removed R4RS essential procedures string->list, list->string, vector->list, and list->vector. * rdms.scm (make-relational-system): Recode 3-argument -. 2004-01-04 Ivan Shmakov * transact.scm (word:lock!, word-lock:certificate): Modes are symbols. 2004-01-03 Aubrey Jaffer * sc4opt.scm (string->list, list->string, vector->list): (list->vector): Removed. These are R4RS essential procedures. * dbinterp.scm, rdms.scm : Require REV4-OPTIONAL-PROCEDURES for LIST-TAIL. * byte.scm, chap.scm, getparam.scm, strcase.scm: Require REV4-OPTIONAL-PROCEDURES for STRING-COPY. * vet.scm (r4rs-symbols): Removed optional procedures DENOMINATOR, FORCE, LIST-TAIL, NUMERATOR, RATIONALIZE, STRING-COPY, STRING-FILL!, TRANSCRIPT-OFF, TRANSCRIPT-ON, VECTOR-FILL!, WITH-INPUT-FROM-FILE, and WITH-OUTPUT-TO-FILE. 2003-12-19 Aubrey Jaffer * grapheps.scm (create-postscript-graph): Push bounds on stack at end of preamble. * grapheps.ps (wholepage): Bounds left on stack by preamble. 2003-12-16 Aubrey Jaffer * color.scm (string->color): Was spoofed by #00. 2003-12-16 L.J. Buitinck * srfi-1.scm (take!, split-at, fold, fold-right, pair-fold) (pair-fold-right, reduce, reduce-right, delete-duplicates) (alist-cons, alist-copy, alist-delete, lset<=, lset=, lset-adjoin) (lset-union, lset-intersection, lset-difference, lset-xor) (lset-diff+intersection): Added. 2003-12-14 Aubrey Jaffer * mkclrnam.scm (make-slib-color-name-db): Added nbs-iscc. * Makefile (rfiles): Added nbs-iscc. * mklibcat.scm (nbs-iscc): Added. * nbs-iscc.txt: Added. 2003-12-11 Aubrey Jaffer * charplot.scm (charplot:array->list): Handle rank-1 arrays. 2003-12-11 Ivan Shmakov * dbsyn.scm (within-database): Added define-macro syntax. (add-macro-support): Added. 2003-12-09 Aubrey Jaffer * manifest.scm (file->exports, file->definitions): Added optional arguments to allow selection for types of definitions. 2003-12-06 Aubrey Jaffer * grapheps.scm (in-graphic-context): Use gpush and gpop. * grapheps.ps (impulse, bargraph): Fixed. (triup, tridown): Removed gratuitous 2 copy. (gpush, gpop): Added for pointsize and glyphsize state. 2003-12-05 Aubrey Jaffer * dbinterp.scm (dbinterp:memoize): Speeds interpolate-from-table by factor of 2. 2003-12-02 Aubrey Jaffer * printf.scm (stdio:iprintf): `K' put dot between number and unit. * rdms.scm (delete-table): Delete table only if TABLE-EXISTS? * dbutil.scm (mdbm:try-opens, mdbm:open-type): Unlock if fail. 2003-11-30 Aubrey Jaffer * require.scm (*SLIB-VERSION*): Bumped from 2d6 to 3a1. 2003-11-30 Aubrey Jaffer * mklibcat.scm (precedence-parse): defmacro because uses fluid-let. 2003-11-29 Aubrey Jaffer * grapheps.scm: Added introduction. * charplot.scm (charplot:array->list): Added missing SCM function. * grapheps.scm (set-color): Use setgray instead of slib GREY. * array.scm (make-array): Removed. * dbutil.scm (mdbm:try-opens): Try alist-table when all types in *base-table-implementations* failed. 2003-11-28 Aubrey Jaffer * grapheps.scm: Reorganized for better documentation flow. * Makefile (txiscms, txifiles): grapheps now schmoozed. * slib.texi (Graphing): Node hosts "Character Plotting" and subtree "PostScript Graphing". * grapheps.scm: Documented and fixed minor bugs. * grapheps.ps (y-axis, x-axis): Check for axis within bounds. 2003-11-27 Aubrey Jaffer * grapheps.scm (create-postscript-graph): Take document %%title from title-top and title-bottom. (grid-verticals, grid-horizontals): Split gridding. (plot): Ported charplot function. * grapheps.ps: PostScript runtime support for creating graphs. * grapheps.scm: Procedures for creating PostScript graphs. 2003-11-23 Aubrey Jaffer * array.scm (make-prototype-checker): Added prototype checks. 2003-11-18 Aubrey Jaffer * charplot.scm: Code cleanup and comments. 2003-11-17 Aubrey Jaffer * gambit.init (define-macro): Set *defmacros*; macroexpand works! 2003-11-15 Aubrey Jaffer * charplot.scm (charplot:plot-function): Changed dats array to Ar64. Changed scaling by one so last x is tried. (charplot:make-array): Reduced width by one so newline is in column 79. (charplot:plot): Output extra newline if x scale overruns it. 2003-11-10 Aubrey Jaffer * slib.texi (Feature): *features* no longer advertised. * vet.scm (provided+?): Added. Converted to predicate argument. * fluidlet.scm (fluid-let): Recoded trivial use of make-list. * gambit.init (implementation-vicinity): Use Gambc-3.0 default. (home-vicinity): Added. (print-call-stack): Added stub to satisfy 'TRACE. (defmacro): slib:eval workaround of macro restrictions. * mitscheme.init (*features*): Has FLUID-LET. * manifest.scm: Updated examples. (feature->requires, file->requires): Take predicate argument PROVIDED? instead of features-list. 2003-11-09 Aubrey Jaffer * slib.texi (The Library System): Reorganized. (Catalog Vicinities): Separated from "Library Catalogs". 2003-11-08 Aubrey Jaffer * random.scm (seed->random-state): Seed is string, not bytes. 2003-11-05 Aubrey Jaffer * arraymap.scm (array-map): Added. 2003-11-02 Aubrey Jaffer * mkclrnam.scm, dbrowse.scm, dbcom.scm, db2html.scm: Replaced type uint with ordinal. * rdms.scm, alistab.scm: Replaced types uint, base-id by ordinal. 2003-11-01 Aubrey Jaffer * rdms.scm (domains:init-data): Simplified. (slib:error): Replaces alias rdms:error. 2003-10-31 Aubrey Jaffer * slib.texi (Base Table): Reorganized subsection into 9 node tree. * rdms.scm (isam-next, isam-prev): Take optional column argument. * scheme48.init, s48-0_57.init (inexact->exact, exact->inexact): Workaround exactness bug. 2003-10-30 Aubrey Jaffer * slib.texi (Base Table): Description of wb-table and rwb-isam. * rdms.scm (isam-prev isam-next): Added. 2003-10-29 Aubrey Jaffer * slib.texi (Indexed Sequential Access Methods): Added. (Table Operations): Reorganized subsection into into 6 node tree. 2003-10-28 Aubrey Jaffer * slib.texi (Base Table): Added new MAKE-GETTER-1 method retrieving single non-key field. * rdms.scm (get, get*): Use optional make-getter-1 method. 2003-10-25 Aubrey Jaffer * dbutil.scm (define-tables): Replaced for-each row:insert with row:insert*. * slib.texi (Require): Updated examples. (Feature): Clarified about *features* per session. (Base Table): Added rwb-isam. * rdms.scm (catalog:init-cols): TABLE-NAME now symbol. (domains:init-data): ATOM is just symbol or #f. * comlist.scm (butnthcdr): Fixed short-list bug. 2003-10-24 Aubrey Jaffer * rdms.scm (coltab-name domain-name): Changed to symbol from atom. * comlist.scm (butnthcdr): SIMSYNCH FIFO8 uses negative k. * dbutil.scm (define-domains): Added. 2003-10-18 Aubrey Jaffer * comlist.scm (remove-duplicates): moved LETREC outside. (butlast): Defined in terms of BUTNTHCDR. (butnthcdr): SET-CDR! to avoid using REVERSE. * rdms.scm (combine-primary-keys): Removed primary-limit restriction. 2003-10-17 Aubrey Jaffer * byte.scm (substring-write, substring-read!): Added. * random.scm (random:chunk): Changed from using arrays to bytes. 2003-10-16 Aubrey Jaffer * byte.scm (read-bytes!): Return number of bytes read. (read-bytes): Shorten returned bytes to number of bytes read. 2003-10-13 * Makefile (efiles): bytenumb.scm was called out twice. 2003-10-12 * byte.scm (write-bytes, write-byte, make-bytes): Fixed @args. 2003-10-09 Aubrey Jaffer * bytenumb.scm (IEEE-byte-decollate!, IEEE-byte-collate!) (integer-byte-collate!): Return byte-vector. 2003-10-08 Aubrey Jaffer * bytenumb.scm (ieee-double->bytes, ieee-float->bytes): Added. (integer-byte-collate!, integer-byte-collate, IEEE-byte-collate!) (IEEE-byte-decollate!, IEEE-byte-collate, IEEE-byte-decollate): Added. 2003-10-04 Aubrey Jaffer * differ.scm (fp:compare): Use negative p-lim for no-limit. * sort.scm (sorted?, sort!, sort): Generalized to arrays. * differ.scm: Always require SORT. (diff:longest-common-subsequence, diff:edits) (diff:edit-length): Moved all but argument handling out. (diff2lcs, diff2edits, diff2editlen): Schlepable top-levels. (diff:order-edits): Coded sign reversal in DO loop. (diff:divide-and-conquer): Allocate and fp:init! fp array. (check-cost): Pulled out of diff:divide-and-conquer. (fp:init!): Added. (fp:compare): fp passed in. (diff2edits): MAXDX was off-by-one. (diff:divide-and-conquer, diff2et, diff2ez): Reuse passed fp. Initialize only used segment of fp. (diff2edits): Allocate just one CCRR and pass to procedures. (diff:order-edits): Converted vector usage to arrays. (diff2ez, diff2et, diff:divide-and-conquer): Reuse passed CCRR. (fp:init!): Take fill argument. 2003-09-30 Aubrey Jaffer * collectx.scm: Expand automatically from collect.scm. * Makefile (collectx.scm): Build target using created collect.sc. * collect.scm (object): Added (require 'object) for collectx.scm. * macwork.scm (mw:suffix-character): Replaced non-R5RS-compliant #\| with #\!. * slib.texi (Exact Random Numbers, Inexact Random Numbers): Made independent packages. * randinex.scm: Separated package random-inexact from random. (random:normal-vector!): Made *2pi internal. * random.scm (random): Now does only exact integers. * htmlform.scm (get-foreign-choices): Moved from db2html.scm in order to eliminate circular require. 2003-09-25 Aubrey Jaffer * matfile.scm (matfile:read-matrix): Version 4 MAT-file endianness cannot be detected from just the first word; ambiguous when 0. Converted to use 'byte-number functions. (matfile:read, matfile:load): Improved error handling. * slib.texi (Byte): Schmoozed. (Byte/Number Conversions): Added. * Makefile (efiles, txiscms, txifiles): Added bytenumb. * byte.scm (bytes-copy, bytes-reverse, bytes-reverse!) (read-bytes, write-bytes): Added. * bytenumb.scm: Added: Byte/integer and IEEE floating-point conversions. 2003-09-21 Ivan Shmakov * pnm.scm (pnm:array-write, pnm:type-dimensions): Fixed 'typo'. * schmooz.scm (schmooz-tops): Replaced #\tab with slib:tab. * yasyn.scm (print, size): ! replaces | in identifiers. 2003-09-21 Aubrey Jaffer * dirs.scm (transact): Eliminated require circularity. * glob.scm (call-with-tmpnam): Moved from transact.scm. String arguments taken as suffixes for tmpnams. * lineio.scm (system->line): Moved from transact.scm. (display-file): Removed. * scanf.scm (sscanf): No longer calls string-port export. (stdio:scan-and-set): Moved call-with-input-string from sscanf. 2003-09-14 Aubrey Jaffer * ncbi-dna.scm (ncbi:read-DNA-sequence): Discard to end of ORIGIN line (which can have chromosome location). 2003-09-09 Aubrey Jaffer * matfile.scm (ieee-float->bytes): Added. * sort.scm (sort, sort!, sorted?): Generalized to strings. 2003-08-31 Aubrey Jaffer * top-refs.scm: Footnote closing brace on @end line chokes texi2html. * Makefile: Moved documentation targets after txifiles definition so dependencies work correctly. 2003-08-29 Aubrey Jaffer * slib.texi (Relational Infrastructure): Collected internal details of database operations. 2003-08-26 Aubrey Jaffer * dbutil.scm (open-table, open-table!): Added. (create-database): Expanded documentation. require-if 'compiling 'alist-table. * slib.texi (Relational Database Objects, Database Operations): Deprecated in favor of section "Using Databases". 2003-08-26 dai inukai * transact.scm (emacs-lock:certificate): "ls -ld" is more portable [GNU, FreeBSD, Vine Linux, Debian Linux] than "ls -o". 2003-08-22 Aubrey Jaffer * dbrowse.scm (browse:display-dir): Keys can be other than strings or symbols. 2003-08-18 Aubrey Jaffer * dbutil.scm (create-database): Gracefully return #f when (not (assq type *base-table-implementations*)). 2003-08-17 Aubrey Jaffer * pnm.scm (pnm:read+integer): Replaced by READ. 2003-08-09 Aubrey Jaffer * slib.texi (Basic Operations on Weight-Balanced Trees): wt-tree? removed because it isn't exported. 2003-07-25 Aubrey Jaffer * scanf.scm (stdio:scan-and-set): Fixed scope of (return). * manifest.scm (feature->exports): Added; returns simple list. (feature->export-alist): Renamed from feature->exports. (feature->requires): Don't cons feature onto list. * slib.texi (Configuration): Use /usr/local/lib/scm/ in examples. * vet.scm (vet-slib): Use feature->exports. 2003-07-24 Aubrey Jaffer * mklibcat.scm (http, color, ncbi-dna): Are defmacro features. * schmooz.scm (schmooz:read-word): Replaced single use of scanf. * pnm.scm (pnm:array-write): Removed use of printf. (pnm:read+integer): Removed use of scanf. * scanf.scm (stdio:scan-and-set): Minor cleanup. * slib.texi (Module Conventions): Added macro rules. 2003-07-23 Aubrey Jaffer * Template.scm (defmacro:expand*): Don't export. * defmacex.scm (defmacro:expand*): Exported. * mklibcat.scm: Added DEFMACRO for many 'scanf users. * slib.texi (Syntax-Case Macros): Added @findex define-structure. (Spectra): Added @findex load-ciexyz. (Color Conversions): Added color:linear-transform. (Collections): Added @findex for gen-keys, gen-elts. * Makefile (bfiles): Added collectx.scm. * yasyn.scm (size, print): Replaced with macro expansions. (pormat): Coded out printf. Moved all define-syntax forms to end. * top-refs.scm (top-refs:expression): Handle WITH-SYNTAX; Don't give up on ... in let* bindings. * schmooz.scm (schmooz-top): Fixed typo in error call. * manifest.scm (feature->exports): Handle aliases. Warn, not err. * transact.scm, uri.scm: Always require 'scanf since it needs defmacro. * vet.scm (slib:catalog): Static SLIB part of *catalog*. (vet-slib): Fixed handling of aggregate entries' exports. * collectx.scm: Copy of collect.scm where DEFINE-OPERATIONs are replaced with macros-that-work expansions. * collect.scm: Cleaned up error messages and aliases. 2003-07-22 Aubrey Jaffer * slib.texi (Promises): Added delay macro. 2003-07-17 Aubrey Jaffer * manifest.scm: Shuffled functions; added examples. * slib.texi (Module Conventions): Clarified. Added example of ;@. (Require): SLIB:IN-CATALOG? renamed from SLIB:FEATURE->PATH. * require.scm (slib:in-catalog?): Renamed from slib:feature->path. Internal aliases defined from advertised functions. SRFIs number over 40; test using SLIB:EVAL. * vet.scm (vet-slib): Improved output formatting. Shuffled functions. * synclo.scm: Added ";@" export notations. 2003-07-16 Aubrey Jaffer * collect.scm: Added ";@" export notations for define-operation. * slib.texi (Coding Guidelines): Circular requires now handled. (Feature): Added mention of catalog:read. * getopt.scm (getopt:opt): Export for getparam.scm. * vet.scm (top-refs<-files, requires<-file, requires<-files) (definitions<-files, exports<-files): Added multi-file functions. * manifest.scm (load->path): Moved from top-refs.scm; exported. (file->loads): Added; finds all loads. (file->definitions): Handle define-operation. * Makefile (release): make pdf. * top-refs.scm (top-refs:expression): Handle define-syntax. (arglist:flatten): Pulled up to top-level. (top-refs:expression): Handle syntax-rules and syntax-case. (top-refs:top-level): Handle define-operation. * solid.scm (solid-color->sRGB): Inlined logical calls. (pi/180): Defined in terms of atan. * require.scm (slib:require): Provide _before_ load. * random.scm (random:chunk): Export for randinex.scm. * randinex.scm (random:uniform1): Export for random.scm. 2003-07-15 Aubrey Jaffer * top-refs.scm (top-refs:binding): Scan for all internal defines before doing top-refs:expression. * uri.scm (uri:make-path): Document and export. * slib.texi (Coding Guidelines): Expanded and updated. (Porting): Improved formating. (Installation): Added @cindex. (Module Semantics): Discuss compiling "provided?" calls. Removed @refills. * README (USING SLIB): Section replaces CODING GUIDELINES. * alist.scm, lineio.scm: Removed @refill texinfo commands. * Template.scm, vscm.init, umbscheme.init, scsh.init, pscheme.init, guile.init, STk.init, RScheme.init, t3.init, scheme48.init, scheme2c.init, s48-0_57.init, mitscheme.init, macscheme.init, gambit.init, elk.init, chez.init, bigloo.init, Template.scm (rNrs): Renamed from revN-report feature. 2003-07-15 From: Sven Hartrumpf * srfi-1.scm (%cars+cdrs, %cars+cdrs/no-test, %cdrs) (any, filter, filter!, list-copy, list-index, map!) (pair-for-each, partition, remove, remove!, span): Adapted from the reference implementation by + removing all check-arg calls + expanding all uses of 'receive' + extending 'remove' by a test to stay compatible with comlist:remove 2003-07-14 Aubrey Jaffer * glob.scm, getparam.scm: Schmoozed documentation into. * daylight.scm (pi pi/180): Define. * html4each.scm (prefix-ci?): Added. (require 'string-port). * http-cgi.scm (coerce->list): Fixed. Added missing requires. * logical.scm (logical:ones): Export. * mkclrnam.scm (load-rgb-txt): Removed lone printf. * repl.scm: Always require 'values. * slib.texi (Bit-Twiddling): Documented logical:ones (Vicinity): Documented vicinity:suffix? * tzfile.scm: Replaced ASH with quotient. * uri.scm (path->uri): Needed (require 'directory). * top-refs.scm (vet-slib): Move to "vet.scm". (exports<-info-index): Can do several sections per call. (top-refs:expression): Fixed let* with internal defines. * vet.scm (vet-slib): Given own file. * color.scm (convert-color, color->string): Fixed handling of optional whitepoint argument. * slib.texi (Trace): Added trackf, stackf, untrackf, unstackf. (Getopt): Used @code{getopt--} to get correct symbol indexed. * top-refs.scm (vet-slib): Vets definitions and documentation against each other -- way cool! * slib.texi (Spectra): Added temperature->chromaticity * manifest.scm (file->definitions): Added. * differ.scm (fp:step-check, smooth-costs): Commented out orphans. * dirs.scm (make-directory): Replaced sprintf with string-append. * slib.texi (Command Intrinsics, Table Operations) (Database Operations): Changed to @defop. Always bracket type-arguments to @def*s. 2003-07-12 Aubrey Jaffer * require.scm (slib:report-locations): Replace 'implementation with type and version symbols. 2003-07-11 Aubrey Jaffer * manifest.scm (file->exports): Added BEGIN support. * top-refs.scm: Added; list top-level variable references. * Makefile (txiscms): Added hashtab.scm, chap.scm. * slib.texi (Hash Tables, Chapter Ordering): Moved documentation to schmooz comments in source. * object.texi: Renamed from objdoc.txi; so isn't confused with schmooz-generated file. * hashtab.scm: Schmoozed documentation into. (hash-rehasher): Documented. * withfile.scm, trnscrpt.scm: Added ";@" export notations. 2003-07-10 Aubrey Jaffer * alist.scm, comparse.scm, chap.scm: Schmoozed documentation into. * slib.texi (Color Difference Metrics): Reorganized. * glob.scm: Added ";@" export notations. Removed "glob:" aliases for exports. * rdms.scm (catalog:view-proc-pos, domains:type-param-pos) (rdms:warn): Commented out unused definitions. * db2html.scm (make-defaulter): Moved near its only use. (get-foreign-choices): Moved here and documented. * Makefile (txiscms): Added ratize.scm, modular.scm, comparse.scm, alist.scm. * slib.texi (Array Mapping, Cyclic Checksum, Directories, Fast Fourier Transform, Portable Image Files, Priority Queues, Queues, Rationalize, Modular Arithmetic, Command Line, Association Lists): Moved documentation to schmooz comments in source. * schmooz.scm (schmooz-fun): Use "deffn Procedure" if procedure name ends in "!". * color.scm: Added ";@" export notations; removed collision-prone aliases. * qp.scm (qp): Removed aliases; added ";@" export notations. * arraymap.scm, queue.scm, priorque.scm, pnm.scm, dirs.scm, ratize.scm, modular.scm: Schmoozed documentation into. * slib.texi (Token definition): Added tok:bump-column. * hash.scm (hashv): Cleaned; Added ";@" export notations. * logical.scm, guile.init: "logical:" prefixes for internal use only (except logical:rotate). * slib.texi (Time Zone): Documented tz:std-offset; used in "psxtime.scm". * uri.scm (uri:path->keys): Documented; used by command:modify-table in "db2html.scm". * random.scm: Commented-out unused random:random. * htmlform.scm (html:delimited-list): Documented; used in command->p-specs example. 2003-07-09 Aubrey Jaffer * strsrch.scm, strport.scm, strcase.scm, scanf.scm, sc4opt.scm, rdms.scm, printf.scm, mbe.scm, fluidlet.scm, dynwind.scm, byte.scm: Added ";@" export notations. * comlist.scm: "comlist:" prefixes for internal use only. * srfi-1.scm (cons*, take, drop, take-right, drop-right, last, reverse!, find, find-tail): Dropped comlist: prefixes. * scmacro.scm (base:load): Unused; removed. * scainit.scm: Put SLIB:LOADs at top-level so codewalk finds them. * macwork.scm (mw:every, mw:union, mw:remove-if-not): Local copies of common-list-functions. * dbutil.scm (add-domain): Documented. 2003-07-08 Aubrey Jaffer * mklibcat.scm: Converted associations to proper lists. * require.scm (slib:require): Corrected subtle logic problems. (catalog:resolve): Accept and convert proper lists associations. * recobj.scm (field:position): Private name for CL function. * object.scm: Added export notations: ";@". * factor.scm (primes-gcd?): Inlined single use of NOTEVERY. (primes<): Renamed from prime:primes<. 2003-07-07 Aubrey Jaffer * slib.texi (Module Semantics): Added. 2003-07-06 Aubrey Jaffer * slib.texi (Catalog Creation): Added catalog:read. * mklibcat.scm: Use catalog:resolve. * require.scm (catalog:resolve, catalog:read): Added. 2003-07-05 Aubrey Jaffer * factor.scm (prime:factor, prime:primes>, prime:primes<): eliminated orphans. * tree.scm: Moved documentation from slib.texi. * srfi-2.scm (and-let*): Guarded LET* special form. * Makefile (txiscms, txifiles): Added srfi-2. 2003-07-03 Aubrey Jaffer * Makefile (*files): Reorganized to eliminate duplications. * srfi-9.scm (define-record-type): Syntax wrapper for 'record. * srfi-8.scm (receive): Added. * schmooz.scm (def->args): Fixed for syntax-rules. 2003-07-02 Aubrey Jaffer * slib.texi (Feature): Added feature-eval. (Require): Added require-if. (Database Reports): Removed. * manifest.scm: Examples added. * array.scm (make-array): Alias of create-array. * manifest.scm: List SLIB module requires and exports; useful for compiling. * Makefile (txifiles, txiscms): Added tsort. * slib.texi (Topological Sort): Moved docs to "tsort.scm". * tsort.scm: Moved documentation from slib.texi into. * require.scm (feature-eval): Abstracted from slib:provided? * cring.scm: Added export notations: ";@". 2003-07-01 Aubrey Jaffer * require.scm (slib:require-if): Added. (slib:provided?): Accepts expressions with AND, OR, and NOT. 2003-06-30 Aubrey Jaffer * Makefile (txiscms): sed script seems not to work. * slib.texi (Top): Universal SLIB Procedures (was Built-in Support) moved to Top. (Feature Require): Fixed bad craziness. (About this manual): Moved to "About SLIB". * require.scm: All "require:" prefixes changed to "slib:". (*modules*): Removed. 2003-06-29 Aubrey Jaffer * formatst.scm, fmtdoc.txi, format.scm: Removed because not reentrant. * FAQ: Added "What happened to FORMAT?" * Makefile (txiscms): Generated from txifiles. * yasyn.scm: Changed from FORMAT to PRINTF-based (pormat). * prec.scm (prec:trace): Removed. * solid.scm, solid.scm, timezone.scm, uri.scm, admin.scm, alistab.scm, batch.scm, colorspc.scm, db2html.scm, dbutil.scm, differ.scm, getparam.scm, html4each.scm, obj2str.scm, printf.scm, psxtime.scm, repl.scm, transact.scm, format.scm, matfile.scm, ncbi-dna.scm: Added conditional top-level REQUIRE for each dynamic REQUIRE. 2003-06-28 Aubrey Jaffer * Makefile (MKNMDB): mkclrnam.scm split from colornam.scm. * colornam.scm (load-rgb-txt): Database creation moved to mkclrnam.scm. * mkclrnam.scm (load-rgb-txt): Database creation moved from colornam.scm. * priorque.scm (heap:test): Removed. * crc.scm (cksum-string): Moved to example in "slib.texi" (Cyclic Checksum). 2003-06-27 Felix Winkelmann * minimize.scm (golden-section-search): eqv? --> =. * mklibcat.scm (scanf): Is defmacro package. 2003-06-20 Aubrey Jaffer * require.scm (*SLIB-VERSION*): Bumped from 2d5 to 2d6. * array.scm (make-array): Removed legacy procedures. 2003-06-18 Aubrey Jaffer * differ.scm (diff:order-edits): Interleave inserts and deletes when adjacent. 2003-06-16 Aubrey Jaffer * differ.scm (diff2ebc diff2ebr): Removed; 3% not worth it. * logical.scm (gray-code->integer): * pnm.scm (pnm:array-write): * slib.texi (Yasos examples, Commutative Rings): * subarray.scm (array-trim): error -> slib:error. * charplot.scm (histobins): Gracefully return when no data. 2003-06-11 Aubrey Jaffer * differ.scm (diff:mid-split): Replaces diff:best-split. (diff2ebr): Fixed RR polarity; now works with diff:mid-split. 2003-06-07 Aubrey Jaffer * differ.scm (diff:longest-common-subsequence): Call DIFF:ORDER-EDITS only when there are edits. (diff:divide-and-conquer): Inlined diff->costs; allocate CC and RR out of the same array. 2003-06-05 Aubrey Jaffer * differ.scm (diff2ebc, diff2el): Inlined insert and delete. (diff:order-edits): take sign argument. (diff:edits, diff:longest-common-subsequence): Handle argument order. (diff2ebc, diff2ebr): Handle insertions and deletes; not matches. 2003-06-04 Aubrey Jaffer * differ.scm (diff2el): Simplified by half. (diff:order-edits): Returns; edits were almost right order. (diff->costs): smooth-costs not needed. (diff2ebc, diff2ebr): Moved conditional swap to diff2et. (diff:order-edits): Figure LEN-A and LEN-B from EDITS. (diff:best-split): Simplified using passed expected COST. 2003-06-02 Aubrey Jaffer * differ.scm (diff2el): Removed never-used LEN-B = 0 case. (diff:divide-and-conquer): Pass cost to diff2ebr, diff2ebc. (diff2ebc): Fixed insert order; P-LIM when B gets shorter than A. (diff:order-edits): Removed -- edits are now generated in order. (diff2edits): Check returned cost. (diff2el): Handle LEN-A = P-LIM case. 2003-06-01 Aubrey Jaffer * differ.scm Reordered procedures and changed some argument names to match paper. (diff2e*): INSERT and DELETE replaced with EDITS, EDX, and EPO. 2003-05-28 Aubrey Jaffer * differ.scm (edits2lcs): Pass in editlen in pursuit of schlepability. 2003-05-26 Aubrey Jaffer * soundex.scm (SOUNDEX): Character lookups use ASSV and MEMV. * strsrch.scm (substring?, substring-ci?): Bum simple cases. (subskip): Split out common code from substring?, substring-ci?. (subloop): Old non-table-driven code for short substring?s. (substring?, substring-ci?): Compared measurements of subskip vs subloop; set breakpoint at STRLEN < CHAR-CODE-LIMIT/2 + 2*PATLEN. (substring-ci?, substring?): Refined; subloop for PATLEN <= 4. 2003-05-25 Steve VanDevender * strsrch.scm (substring?, substring-ci?): Rewrote, improving performance and fixing (substring-ci? "a" "An apple") ==> 3 bug. 2003-05-24 Aubrey Jaffer * differ.scm (diff:order-edits): Added; returns correct order. 2003-05-23 Aubrey Jaffer * differ.scm (edits2lcs): Removed editlen argument. * ncbi-dna.scm: Read and manipulate NCBI-format nucleotide sequences. 2003-05-12 Aubrey Jaffer * differ.scm (diff2el): Handle all (zero? p-lim) cases. 2003-05-06 Aubrey Jaffer * differ.scm: Reorganized diff2* functions. Leading and trailing runs of matches now trimmed from all edits-producing comparisons. (smooth-costs): Correct cost jumps left by fp:compare [which visits only a few (x,y)]. (diff->costs): Check that each adjacent CC pair differs by +/-1. (diff:divide-and-conquer): Disable SHAVE pending bug resolution. (diff2ebr, diff2ebc): Split diff2eb; end-run optimization only works for half inheriting middle insertions. (diff:divide-and-conquer): Moved fp:check-cost into. 2003-05-03 Aubrey Jaffer * differ.scm (diff:shave): Removed cdx+1; now cdx. Keep track of endb in insert loop. 2003-05-01 Aubrey Jaffer * differ.scm (diff:shave): Also trim matches with decreasing CC from ends; nets 27% speed. 2003-04-27 Aubrey Jaffer * guile.init (port?): Had argument name mismatch. 2003-04-06 Aubrey Jaffer * db2html.scm (command:make-editable-table, command:modify-table): Improved null-keys treatment to work with multiple primaries. 2003-04-05 Aubrey Jaffer * qp.scm (qp:qp): Distinguish #f and 0 values for *qp-width*. 2003-03-30 Aubrey Jaffer * differ.scm (diff:divide-and-conquer): Trim based on CC alone. (diff:best-split): Extracted from diff:divide-and-conquer. (diff:shave): Abstracted from diff:divide-and-conquer. 2003-03-29 Aubrey Jaffer * differ.scm (fp:compare): Use smaller fp if p-lim supplied. 2003-03-27 Aubrey Jaffer * differ.scm (diff:divide-and-conquer): Find longest optimal run. (diff2edits): Initialize edits array to prevent type error. (diff:divide-and-conquer): Split nearest to midpoint within longest run. (diff:divide-and-conquer): Split into 3 parts if consecutive inserts are discovered in bestrun. (diff:divide-and-conquer): No need to check both CC and RR for linearity; tcst being constant guarantees it. 2003-03-25 Aubrey Jaffer * solid.scm (scene:viewpoint): Simplified; fixed pitch. (solid:extract-colors): Fixed color/elevations alignment. (solid:extract-colors, solid:extract-elevations): Fixed row-major. 2003-03-24 Aubrey Jaffer * solid.scm (solid:basrelief): Added VRML ElevationGrid. (solid:bry): Added "solid FALSE" and missing alternative clause. 2003-03-23 Aubrey Jaffer * html4each.scm (html-for-each): Rewrote for full quote hair. Removed require string-search; uses own multi-char version. 2003-03-16 Aubrey Jaffer * html4each.scm (html-for-each): "unterminated HTML entity" warning infinitely looped; changed to error. (htm-fields): Recover from HTML errors. 2003-03-15 Aubrey Jaffer * uri.scm (uri->tree, make-uri): Fixed confusion of #f and "". * db2html.scm (command:make-editable-table): foreign-choice-lists now opens the table. 2003-03-07 Aubrey Jaffer * slib.texi: Fixed database examples. * dbutil.scm (solidify-database): Fixed lock handling. 2003-03-02 Aubrey Jaffer * fft.scm (fft:shuffle&scale): Use bit-reverse from 'logical. * arraymap.scm (array-for-each): Use set-car! instead of reverse. 2003-02-17 Aubrey Jaffer * slib.texi (Getopt): Fixed double dashes. * transact.scm (transact-file-replacement): Accept (string) path to backup file in place of backup-style symbol. 2003-01-27 Aubrey Jaffer * phil-spc.scm (hilbert-coordinates->integer): Converted to tail-recursive internal define. * slib.texi (Peano-Hilbert Space-Filling Curve): Renamed from "Hilbert Space-Filling Curve". * phil-spc.scm: Renamed from "fhilbert.scm". 2003-01-25 Aubrey Jaffer * fhilbert.scm (integer->hilbert-coordinates): Made index processing symmetrical with hilbert-coordinates->integer. 2003-01-13 Aubrey Jaffer * bigloo.init (scheme-implementation-version): *bigloo-version* (implementation-vicinity): *default-lib-dir*/. (library-vicinity): Check couple of places using DIRECTORY?. 2003-01-11 Aubrey Jaffer * slib.texi (Plotting): Updated examples. 2003-01-06 Aubrey Jaffer * fhilbert.scm (hilbert-coordinates->integer) (integer->hilbert-coordinates): Reference rank now 0 (was 2). 2003-01-05 Aubrey Jaffer * fhilbert.scm (hilbert-coordinates->integer): Fixed nBits. (integer->hilbert-coordinates): Simplified. * DrScheme.init (defmacro): Restore for mzscheme-202. 2003-01-05 Ivan Shmakov * queue.scm (dequeue-all!): Added. 2003-01-05 L.J. Buitinck * comlist.scm (comlist:subset?): Added. 2003-01-04 Aubrey Jaffer * fhilbert.scm: Added Hilbert Space-Filling Functions. * logical.scm (logical:logcount, logical:integer-length): Made tail-recursive. (logical:logxor, logical:logior, logical:logand): Made tail-recursive. 2002-12-29 Aubrey Jaffer * logical.scm (logical:ones): Return 0 for 0 argument. (gray-code->integer): Improved running time from O(b^2) to O(b*log(b)). 2002-12-26 Aubrey Jaffer * batch.scm (*operating-system*): gnu-win32 renamed from cygwin32. * slib.texi (String Search): State search order for string-subst. 2002-12-25 Aubrey Jaffer * html4each.scm (htm-fields): Parses markup string. (html-for-each): Handle comments as markups. * strsrch.scm (count-newlines): Added. * comlist.scm (comlist:list*): Make letrec top-level. 2002-12-25 L.J. Buitinck * comlist.scm (comlist:union): Make letrec top-level. 2002-12-17 Aubrey Jaffer * solid.scm (scene:viewpoints): Restored Up and Down views. * slib.texi (Rule Types): Split from Precedence Parsing Overview. (Precedence Parsing Overview): Describe binding power concept. 2002-12-11 Aubrey Jaffer * batch.scm (*operating-system*): Detect MINGW32 (gcc on MS-DOS) as CYGWIN. 2002-12-09 W. Garrett Mitchener * Makefile (catalogs): Make mzscheme new-catalog -g (case-sensitive) so *SLIB-VERSION* symbol upper-cased. 2002-12-08 L.J. Buitinck * slib.texi (Destructive list operations): Fixed SOME example. MAP instead of MAPCAR in nconc example. 2002-12-06 Aubrey Jaffer * random.scm (random): Streamlined. (seed->random-state, random:chunk): Replaced BYTE with ARRAY. 2002-12-05 Aubrey Jaffer * random.scm (random): Don't get extra chunk when modu is integer multiple of 256. 2002-12-02 Aubrey Jaffer * html4each.scm (html:read-title): Added optional LIMIT (word-count) argument. * slib.texi (Getopt, Getopt Parameter lists): * getparam.scm (getopt->arglist, getopt->parameter-list): * getopt.scm (getopt, getopt--): Global variable *argv* replaces argc, argv arguments. Not the best solution -- but at least its consistent. * slib.texi (Lists as sets): Updated UNION examples. * comlist.scm (comlist:union): Optimized for list lengths. 2002-12-01 Aubrey Jaffer * html4each.scm (html:read-title): Added. (html-for-each): Accept input-port for FILE argument. (html:read-title): Added check for first char being '<'. * uri.scm (absolute-uri?): Added. 2002-11-30 Aubrey Jaffer * uri.scm (uri->tree): Corrected documentation. * dbutil.scm (mdbm:report): Show lock certificates. (create-database, write-database, syncify-database, close-database): Lock database file for writing. (create-database): Allow initial #f filename. * slib.texi (Copyrights): Fixed TeX formatting. 2002-11-29 Aubrey Jaffer * DrScheme.init: Added (provide 'fluid-let). (call-with-input-string): Corrects bug in /usr/local/lib/plt/collects/slibinit/init.ss. 2002-11-26 Aubrey Jaffer * require.scm (*SLIB-VERSION*): Bumped from 2d4 to 2d5. 2002-11-26 dai inukai * srfi-1.scm (drop-right, take-right): Were swapped. 2002-11-26 Aubrey Jaffer * DrScheme.init: Ported for VERSIONs >= "200". * Template.scm, vscm.init, umbscheme.init, t3.init, STk.init, scsh.init, scheme2c.init, s48-0_57.init, RScheme.init, macscheme.init, gambit.init, elk.init, chez.init, bigloo.init (slib:warn): Put spaces between arguments. * slib.texi (Database Macros): Section added. * dbcom.scm (define-*commands*): Added; supports define-command. 2002-11-26 Ivan Shmakov * scheme48.init (slib:warn): Match S48-ERROR format. * dbsyn.scm (within-database, define-table, define-command): Added new file. 2002-11-22 Aubrey Jaffer * slib.texi (Portable Image Files): Added cindexes. * pnm.scm (pnm:read-bit-vector!): Fixed for odd width pbms. (pnm:image-file->array): Takes optional comment string arguments. 2002-11-21 Aubrey Jaffer * Makefile (docfiles, efiles): nclients.* renamed transact.*. * transact.scm: Renamed from nclients.scm. * nclients.scm (emacs:backup-name): Added. (transact-file-replacement): Now does backup files. 2002-11-20 Aubrey Jaffer * guile.init (define-module, eval): Condition on version. * slib.texi (Transactions): Replaces net-clients section. * vscm.init, umbscheme.init, Template.scm, t3.init, STk.init, scsh.init, scheme48.init, scheme2c.init, s48-0_57.init, RScheme.init, pscheme.init, macscheme.init, gambit.init, elk.init, DrScheme.init, chez.init, bigloo.init (browse-url): Added. * nclients.scm (user-email-address): Split into pieces. (transact-file-replacement): Replaces call-with-replacement-file. 2002-11-17 Aubrey Jaffer * uri.scm (path->uri, absolute-path?, null-directory?) (glob-pattern?, parse-ftp-address): Moved from nclients.scm. * dirs.scm (current-directory, make-directory): Moved from nclients.scm. 2002-11-15 Aubrey Jaffer * dirs.scm: Added. 2002-11-11 Aubrey Jaffer * slib.texi (Space-Filling Curves): Section added. (Bit-Twiddling): Added logical:rotate. * logical.scm (logical:rotate): Added. (logical:ones): Added so correct with limited-precision integers. 2002-11-03 Aubrey Jaffer * nclients.scm (file-lock-owner): Also check emacs-lock. (word-lock:certificate): Name3 missing also triggered length error. * db2html.scm (crc:hash-obj): Added. * slib.texi (Cyclic Checksum): Rewritten. * Makefile (slib$(VERSION).info): Ignore makeinfo-4.1 bailing on colons in names. * crc.scm: Replaces makcrc.scm. 2002-10-27 Aubrey Jaffer * solid.scm (scene:viewpoint): Corrected translation/rotation order. 2002-10-14 Aubrey Jaffer * DrScheme.init: Corrected mis-attribution 2002-10-09 Aubrey Jaffer * pnm.scm (pnm:read-bit-vector!): Read pbm-raw correctly. 2002-09-24 Aubrey Jaffer * pnm.scm (pnm:image-file->array): Correctly handle array type when max-pixval > 256. 2002-08-17 Aubrey Jaffer * dbcom.scm (make-command-server): Handle lacking domain-checkers. 2002-08-14 Aubrey Jaffer * makcrc.scm (make-port-crc): Default based on number-size of implementation. 2002-07-22 Aubrey Jaffer * differ.scm (diff:divide-and-conquer): Limit p-lim of sub-diffs to those computed at mid-a, mid-b. 2002-07-19 Aubrey Jaffer * differ.scm (diff:divide-and-conquer): Rewrote edit-sequence and longest common subsequence generation. 2002-06-28 Aubrey Jaffer * array.scm (create-array): Fixed scales calculation. 2002-06-23 Aubrey Jaffer * modular.scm (modular:normalize): Test (provided? 'bignum) once. 2002-06-18 Aubrey Jaffer * differ.scm (fp->lcs): Use argument array type for returned array. 2002-06-17 Aubrey Jaffer * slib.texi (Parsing HTML): Added. 2002-06-09 Aubrey Jaffer * html4each.scm: HTML scan calls procedures for word, tag, whitespac, and newline. 2002-05-31 Aubrey Jaffer * nclients.scm (file=?): Added. 2002-05-30 Aubrey Jaffer * chez.init (*features*): random is not. 2002-05-28 Aubrey Jaffer * slib.texi (net-clients): Updated. * nclients.scm (file-lock-owner, file-lock!, file-unlock!, system->line): Added. 2002-05-27 Aubrey Jaffer * nclients.scm (call-with-replacement-file): Added emacs-aware procedure to read-modify-write file. * slib.texi (Vicinity): Clarified make-vicinity. 2002-05-18 Aubrey Jaffer * slib.texi (Command Example): Corrected. * cvs.scm (cvs-repository): Added. (cvs-set-root!, cvs-vet): Rewritten to handle absolute paths in CVS/Repository files. 2002-05-16 Aubrey Jaffer * cvs.scm (cvs:vet): Added CVS structure checker. 2002-05-09 Aubrey Jaffer * differ.scm (diff:edits): Return array of signed integers. Broke functions into schlepable chunks; reorganized functions. 2002-05-08 Aubrey Jaffer * differ.scm (diff:make-differ): Abstracted operations. 2002-05-06 Aubrey Jaffer * differ.scm (fp->edits): Was forgetting some first deletes. * differ.scm (fp->edits): Fixed off-by-one; last delete was lost. (diff:edit-length): Array fp was uninitialized. 2002-05-02 Aubrey Jaffer * cvs.scm (cvs-directories, cvs-root, cvs-set-root!): Added. * require.scm (pathname->vicinity): Removed "Go up one level if PATHNAME ends in a vicinity suffix" behavior. 2002-04-28 Aubrey Jaffer * htmlform.scm (html:head): Use second argument (backlink) verbatim if it contains

. 2002-04-26 Aubrey Jaffer * require.scm (pathname->vicinity): Added. * slib.texi (Vicinity): Added pathname->vicinity. 2002-04-24 Aubrey Jaffer * db2html.scm (db->html-files): Fixed for #f argument DIR. 2002-04-21 Aubrey Jaffer * mitscheme.init (sort!): Accepts only vectors; set it to SORT. 2002-04-18 Aubrey Jaffer * http-cgi.scm (make-query-alist-command-server): Don't assume query-alist is non-false. 2002-04-18 Chris Hanson * mitscheme.init (char-code-limit, defmacro, *features*): Corrected. 2002-04-17 Aubrey Jaffer * require.scm (software-type): Removed vestigal conversion from msdos -> ms-dos. 2002-04-17 Chris Hanson * mitscheme.init: Updated for versions 7.5 .. 7.7. 2002-04-14 Aubrey Jaffer * require.scm (*SLIB-VERSION*): Bumped from 2d3 to 2d4. * slib.texi (CVS): Added. * batch.scm (*operating-system*): Renamed from *current-platform*. 2002-04-11 Aubrey Jaffer * batch.scm (batch:operating-system): Added. (batch:write-header-comment): Take parms argument. (batch:call-with-output-script): Corrected platform. 2002-04-07 Aubrey Jaffer * Makefile (efiles): Added cvs.scm. * mklibcat.scm (cvs): Added for cvs.scm. * htmlform.scm (html:select, form:delimited): Added newlines. * batch.scm (batch:platform): Handles cygwin unames. (batch:call-with-output-script): /bin/rc is PLAN9 shell. * cvs.scm: Functions to enumerate files under CVS control. 2002-04-03 Aubrey Jaffer * batch.scm (operating-system): Added plan9. 2002-03-31 Aubrey Jaffer * colorspc.scm (spectrum->chromaticity, temperature->chromaticity): Added. 2002-03-30 Aubrey Jaffer * require.scm (sub-vicinity): Support for PLAN9. * nclients.scm (user-email-address, current-directory): PLAN9. 2002-03-29 Aubrey Jaffer * slib.texi (Color Names, The Short List): Saturate replaces hollasch. * mklibcat.scm: Saturate color dictionary replaces hollasch. * colornam.scm (load-rgb-txt): parses saturate dictionary. (make-slib-color-name-db): Saturate dictionary replaces hollasch. * saturate.txt: Saturated colors from "Approximate Colors on CIE Chromaticity Diagram" * resenecolours.txt: "dictionary", not "software". 2002-03-20 Aubrey Jaffer * comlist.scm (comlist:list-of??): Replaced calls to EVERY with calls to COMLIST:EVERY. * slib.texi (Spectra): Added new functions and constants. * colorspc.scm (CIEXYZ:A, CIEXYZ:B, CIEXYZ:C, CIEXYZ:E): Added. (CIEXYZ:D65): Derive from e-sRGB so (color->e-srgb 16 d65) works. (chromaticity->whitepoint): Added. (chromaticity->CIEXYZ): Normalize to 1=x+y+z. (wavelength->chromaticity, wavelength->CIEXYZ): Added. 2002-03-16 Aubrey Jaffer * Makefile (docfiles): Added recent schmooz-generated files. 2002-03-11 Aubrey Jaffer * slib.texi (Color Names): Added resenecolours.txt license. * Makefile (catalogs): Added scripts for 5 implementations. (clrnamdb.scm): Tries up to 5 implementations. * mklibcat.scm (catpath): Delete slibcat if exists. * slib.spec (%post): Improved catalog-building scripts. Make clrnamdb.scm. * Makefile (gfiles): Added resenecolours.txt. (clrnamdb.scm): Depends on colornam.scm. * colornam.scm (load-rgb-txt): Added m4c to read resenecolours.txt without "Resene " prefix. * resenecolours.txt: Removed "Resene " prefix. 2002-03-11 Karen Warman * resenecolours.txt: (Citrine White): Supplied missing value. (Copyright): Accepted license change to allow modifications. 2002-03-01 Aubrey Jaffer * db2html.scm (command:make-editable-table): require database-commands. * colornam.scm (load-rgb-txt): Made method names be symbols. 2002-02-26 Aubrey Jaffer * slib.texi (Lists as sets): Corrected description of MEMBER-IF. Improved example. 2002-02-23 Bill Wood * format.scm (Iteration Directive): Modified iteration directive code to respect configuration variables format:iteration-bounded and format:max-iterations. (Configuration Variables): Added format:iteration-bounded, default #t, and format:max-iterations, default 100. * fmtdoc.txi: Added documentation of changes and additions. 2002-02-20 Aubrey Jaffer * slib.texi (Color): Added tags for Color nodes. * guile.init (expt): Fixed (expt 2 -1). (port?, call-with-open-ports): Added. 2002-02-18 Aubrey Jaffer * slib.texi (Motivations): Removed to DBManifesto.html. * bigloo.init, chez.init, elk.init, mitscheme.init, RScheme.init, scheme2c.init, scheme48.init, scsh.init, STk.init, Template.scm, vscm.init (home-vicinity): ELSE clause was missing. * guile.init (home-vicinity): Case-sensitive case was hosing. 2002-02-14 Aubrey Jaffer * scheme48.init: (asin) is totally busted in Scheme-48-0.45. * colorspc.scm (pi): Added. (multiarg/and-): Required. Scheme-48-0.45 chokes on 1e1. * daylight.scm: Scheme-48-0.45 chokes on 1e1. Quoted vectors. * solid.scm: Scheme-48-0.45 chokes on 1e1. * slib.texi (multiarg/and-): Fixed typo. 2002-02-11 Aubrey Jaffer * require.scm (*SLIB-VERSION*): Bumped from 2d2 to 2d3. * batch.scm (batch:write-header-comment): Include batch:platform in message. 2002-01-31 Aubrey Jaffer * guile.init (create-array, Ac64, Ac32, Ar64, Ar32, As64, As32, As16, As8, Au64, Au32, Au16, Au8, At1): Added new SLIB arrays. * charplot.scm, differ.scm, pnm.scm, fft.scm: Changed to use create-array. * arraymap.scm (array-indexes): * matfile.scm (matfile:read-matrix): Changed to use create-array. * array.scm: (Ac64, Ac32, Ar64, Ar32, As64, As32, As16, As8, Au64, Au32, Au16, Au8, At1): Added prototype makers. * pnm.scm (pnm:image-file->uniform-array): Removed. (pnm:array-write): Changed away from using *-uniform-*. 2002-01-28 Aubrey Jaffer * array.scm (create-array): 1-element fill only. 2002-01-26 Aubrey Jaffer * subarray.scm (subarray0, array-align): Added. * slib.texi (Input/Output): Added call-with-open-ports, port? (Installation): How to make color-name database. (Byte): Added note about opening binary files. * matfile.scm (matfile:read): * tzfile.scm (tzfile:read): * pnm.scm (pnm:type-dimensions, pnm:image-file->array): (pnm:array-write): Converted to use CALL-WITH-OPEN-PORTS and OPEN-FILE for binary files. * *.init, Template.scm (call-with-open-ports, port?): Added. * slib.texi (Color Names): Added Resene and Hollasch dictionaries. * Makefile (clrnamdb.scm): Make using most portable method; "<". * mklibcat.scm (hollasch, resene): Added color-name-dictionary features. * require.scm (require:require): Use feature name for color-dictionary define. * colornam.scm (make-slib-color-name-db): Added. * dbutil.scm (open-database!): OK if database is already open for writing. 2002-01-25 Aubrey Jaffer * slib.texi (Input/Output): Open-file MODES argument now symbol. * Template.scm, *.init (open-file): Modes argument now symbol. 2002-01-23 Radey Shouman * subarray.scm (subarray): Trailing indices can now be elided, as in the rautil.scm version. 2002-01-22 Aubrey Jaffer * slib.texi (Input/Output): Changed procedures returning values to @defun. * mklibcat.scm (display*): Added to reduce code size. * dbutil.scm (make-exchanger): Removed; now in *.init files. * slib.texi (Miscellany): Renamed from Legacy. Added make-exchanger, open-file, and close-port. * guile.init (make-exchanger): Added. * STk.init, vscm.init, umbscheme.init, t3.init, scsh.init, scheme48.init, scheme2c.init, s48-0_57.init, pscheme.init, mitscheme.init, macscheme.init, gambit.init, elk.init, chez.init, bigloo.init, Template.scm, RScheme.init, DrScheme.init (make-exchanger, open-file, close-port): Added. 2002-01-21 Aubrey Jaffer * solid.scm (direction->vrml-field): Corrected angle errors due to having only one buggy viewer. (scene:sun): FreeWRL-0.30 sun disappears even closer than lookat. 2002-01-19 Aubrey Jaffer * slib.texi (Relational Database): Reorganized. Feature `database-utilities' renamed `databases'. * dbutil.scm (close-database, write-database, open-database, open-database!, create-database): Changed errors to warnings. Added (schmooz) documentation. * slib.texi (Base Table): Added introduction. Listed alist-table and wb-table features. (Database Utilities): Moved documentation to "dbutil.scm". * dbutil.scm (mdbm:report): Added. (open-database!, open-database, write-database, sync-database, solidify-database, close-database): will accept database or filename. Rewrote using dynamic-wind to protect mdbm:*databases*. * rdms.scm (close-database): Fixed return value. (write-database, sync-database): Made conditional on MUTABLE. (solidify-database): Added method to change mutable to unmutable. 2002-01-18 Radey Shouman * pnm.scm: Fixed pbm read for the case when 0 and 1 characters are not separated by whitespace (Ghostscript does this). 2002-01-17 Aubrey Jaffer * slib.texi (Database Utilities): Updated dbutil changes. * dbutil.scm (close-database, sync-database, write-database): Added. (create-database, open-database!, open-database): Rewritten to support database sharing. 2002-01-13 Aubrey Jaffer * rdms.scm (filename): Added database method for retrieving. * scsh.init, chez.init, bigloo.init, scheme2c.init (scheme-implementation-home-page): Updated. 2002-01-10 Aubrey Jaffer * Makefile (clrnamdb.scm): Added target to build resene color-dictionary. * require.scm (require:require): Added color-names loader. * colornam.scm (load-dictionary, make-slib-color-db): Added. 2002-01-08 Aubrey Jaffer * determ.scm (matrix:inverse, matrix:product, transpose, matrix->array, matrix->lists): Added. * slib.texi (Matrix Algebra): Renamed from Determinant. Schmooz documentation from determ.scm. * array.scm (create-array): Default to vector for non-array prototypes. 2002-01-07 Aubrey Jaffer * colornam.scm (load-rgb-txt): Allows multiple names per color. Added support for multi-lingual "color_names.txt". 2002-01-06 Aubrey Jaffer * colorspc.scm (e-sRGB-log, e-sRGB-exp): Abstracted and corrected. (CIEXYZ:D65, CIEXYZ:D50): Compute from CIE chromaticities. (e-sRGB:from-matrix): http://www.pima.net/standards/it10/PIMA7667/PIMA7667-2001.PDF gives matrix identical to sRGB:from-matrix, but colors drift under repeated conversions to and from CIEXYZ. Instead use computed inverse of e-sRGB:into-matrix. 2002-01-05 Aubrey Jaffer * colorspc.scm (CIE:Y/Yn->L*, CIE:L*->Y/Yn): Abstracted CIE luminance <-> lightness conversions. (ab-log, ab-exp): Abstracted a*, b* nonlinearities. (L*u*v*->CIEXYZ): Simplified. * slib.texi (Spectra): Features cie1964, cie1931, and ciexyz. * colorspc.scm (spectrum->XYZ, wavelength->XYZ): Require 'ciexyz. * mklibcat.scm (cie1964, cie1931, spectral-tristimulus-values): Added. * require.scm (require:require): Added spectral-tristimulus-values loader. * cie1964.xyz: Added. 2002-01-03 Aubrey Jaffer * slib.texi (MAT-File Format): Added node. * matfile.scm (matfile:read-matrix): Dispatch per binary format; only IEEE currently. Added schmooz documentation. 2002-01-01 Aubrey Jaffer * subarray.scm (subarray, array-trim): Added easier ways to make subarrays. * array.scm (array=?): Fixed example. * charplot.scm (charplot:data->lists): Fixed for 1-dimensional array. * matfile.scm (bytes->double): Corrected mantissa scale. 2001-12-21 Aubrey Jaffer * matfile.scm: Added; reads MAT-File Format version 4 (MATLAB). 2001-12-13 Aubrey Jaffer * scainit.scm (syncase:sanity-check): Had too many ".scm" suffi. 2001-12-12 Aubrey Jaffer * solid.scm (scene:sphere): Major rewrite. Now works, I think. * daylight.scm (sunlight-spectrum): Added and debugged calculation from http://www.cs.utah.edu/vissim/papers/sunsky/sunsky.pdf. * colorspc.scm (xyY:normalize-colors): Added optional argument to control luminence scaling. 2001-12-11 Ivan Shmakov * s48-0_57.init (system): Removed code that set! system to #f. 2001-12-09 Aubrey Jaffer * solid.scm (light:ambient, light:directional, light:dispersion, light:point, light:spot): Added light sources. * slib.texi (Plotting): Updated documentation. 2001-12-08 Aubrey Jaffer * charplot.scm: Major cleanup; raster conversion replaced by array of chars; y coordinate lists rendered with distinct characters. (coordinate-extrema): Added; computes extrema for lists of coordinates of any rank. (histograph): Added. 2001-12-05 Aubrey Jaffer * Makefile ($(dvidir)slib.dvi): Depend on Schmoozed files. 2001-12-04 Aubrey Jaffer * charplot.scm (charplot:plot!): Accept lists for second coordinates; plot all against first coordinates. * colornam.scm (file->color-dictionary): Added format for data from Resene spreadsheetd. * colorspc.scm (xyY:normalize-colors): Added. * daylight.scm: Added mathematical model of sky colors. 2001-12-01 Aubrey Jaffer * logical.scm (logical:integer-expt): Merged logical:ipow-by-squaring into. * modular.scm (mod, rem): Added Common-Lisp functions. (modular:r, modular:expt): Removed dependence on logical package. 2001-11-29 Aubrey Jaffer * solid.scm (solid:pyramid): Added. 2001-11-28 Aubrey Jaffer * solid.scm (scene:panorama, scene:sphere): Added backgrounds. (solid:cylinder, solid:disk, solid:cone): Added. (solid:arrow): Rewritten in terms of solid primitives. 2001-11-25 Aubrey Jaffer * solid.scm (solid:texture): Added. (vrml-append): Added; puts newlines between strings. * colorspc.scm (chromaticity->CIEXYZ, spectrum->CIEXYZ, temperature->CIEXYZ): Added; useful for making whitepoints. 2001-11-24 Aubrey Jaffer * slib.texi (Database Utilities): Added description of *base-table-implementations*. * colornam.scm (load-rgb-txt): Added many data formats. Internal function parse-rgb-line clobbers itself with method the first time a method works. * colorspc.scm (spectrum->xyz): Now accepts vector (or list) and bounds. Now compensates for number of samples. (blackbody-spectrum): Made public. Takes optional SPAN argument. (XYZ->xyY, xyY->XYZ): Corrected; it really is just Y. (CIE:L*): Y->L* conversion abstracted into function. 2001-11-23 Aubrey Jaffer * charplot.scm (charplot:iplot!): Fixed 9-year old fencepost bug. (charplot:iplot!): Coordinates standardized to lists, rather than pairs. PLOT will accept either. (plot): Dispatches to plot! or plot-function!. (plot-function): Added alias for plot. 2001-11-17 Aubrey Jaffer * colornam.scm (load-rgb-txt): Added "order" index field. * scsh.init, scheme48.init, scheme2c.init, mitscheme.init, guile.init, elk.init, chez.init, bigloo.init, Template.scm, STk.init, s48-0_57.init (home-vicinity): Now assures trailing "/". * colornam.scm (grey): Added X11 numbered greys. 2001-11-17 Ivan Shmakov * scsh.init, scheme48.init, scheme2c.init, mitscheme.init, guile.init, elk.init, chez.init, bigloo.init, Template.scm, STk.init, s48-0_57.init (home-vicinity): (getenv "HOME") Was evaluated at compile time, thus returning the installer's home directory! Instead, call when HOME-VICINITY is called. * dbcom.scm (add-command-tables): The argument of set-car! function must be mutable, but (quote xxx) isn't in Scheme48. 2001-11-16 Aubrey Jaffer * colornam.scm: Rewritten. * slib.texi (Color Names): Moved to end of color section. * alistab.scm (open-base): Check that first line starts with ";;". 2001-11-15 Aubrey Jaffer * colornam.scm: Added. * slib.texi (Database Utilities): Reorganized. (Color Names): Added. * alistab.scm: Put *SLIB-VERSION* in header. Set *base-table-implementations*. * dbcom.scm: Split rdb command extensions from dbutil.scm. (wrap-command-interface, add-command-tables): Added * require.scm (*base-table-implementations*): Added. * dbutil.scm (open-database!, open-database): Use *base-table-implementations* to dispatch on db-file type. 2001-11-11 Aubrey Jaffer * slib.texi (Bit-Twiddling): Added "Bit order and Lamination". (Bit-Twiddling): Added "Gray code". * logical.scm (bit-reverse integer->list list->integer booleans->integer bitwise:laminate bitwise:delaminate): Added bit order and lamination functions. (integer->gray-code gray-code->integer gray-code? gray-code>=?): Added Gray code functions. 2001-11-07 Aubrey Jaffer * colorspc.scm (xRGB): Renamed from sRGBi. * color.scm (CIEXYZ->color, RGB709->color, L*a*b*->color, L*u*v*->color, L*C*h->color, sRGB->color, xRGB->color, e-sRGB->color): Added. * slib.texi: Fixed comparison function documentation. 2001-11-04 Aubrey Jaffer * color.scm (color->string, string->color): Added. (color:L*u*v*, color:L*a*b*, color:L*C*h): White-point must be XYZ. * colorspc.scm (L*C*h->L*a*b*): Fixed angle polarity. 2001-11-03 Aubrey Jaffer * color.scm (color:white-point): Return default if no parameter. * colorspc.scm (temperature->xyz): Optimized. * solid.scm (solid:color): Hooked to use SLIB color data-type. * slib.texi (Spectra): Replaced "White Point". Groups procedures for spectrum conversions. * colorspc.scm (temperature->xyz, XYZ:normalize-colors): Added. 2001-11-02 Aubrey Jaffer * colorspc.scm (XYZ->xyY, xyY->XYZ): Added. 2001-11-01 Aubrey Jaffer * colorspc.scm (XYZ->chromaticity): Added. (wavelength->xyz): Added. 2001-10-31 Aubrey Jaffer * color.scm (color->L*C*h): Added. (color->L*u*v*, color->L*a*b*): Fixed white-point arguments. (color:RGB709, color:CIEXYZ): Relaxed bounds 0.001. (color:white-point): Depends on color:encoding. * colorspc.scm (L*a*b*->L*C*h): Normalize angle positive. 2001-10-21 Aubrey Jaffer * getparam.scm (getopt-barf): Replace calls to slib:warn with lines written to current-error-port; to dovetail better with the call to parameter-list->getopt-usage immediately after. 2001-10-14 Aubrey Jaffer * nclients.scm (ftp-upload): Removed (to docupage). * prec.scm (tok:bump-column, prec:parse): Fluid-let prec:token whenever *prec:port* is. 2001-10-11 Aubrey Jaffer * cie1931.xyz: Added. * color.scm: Reorganized documentation. * colorspc.scm (read-ciexyz!, spectrum->xyz): Added. 2001-10-09 Mikael Djurfeldt * guile.init (guile:wrap-case-insensitive): Simplified. 2001-10-07 Aubrey Jaffer * color.scm: Color data type supporting CIEXYZ, RGB709, sRGB, e-sRGB, L*a*b*, L*u*v*, and L*C*h. Added smooze documentation. (color-white-point): Fixed wrapping. * colorspc.scm (CMC:DE): CMC:DE is designed only for small color-differences. But try to do something reasonable for large differences. Use bisector (h*) of the hue angles if separated by less than 90.o; otherwise, pick h of the color with larger C*. (e-sRGB:into-matrix): Fixed missing '-'. Moved error checking to "color.scm". 2001-10-06 Aubrey Jaffer * colorspc.scm (CIE:DE, CIE:DE*94, CMC:DE): Added color difference metrics. * slib.texi (Color Spaces): Section added. * colorspc.scm (e-sRGB->e-sRGB): Added. (CIE:DE, CIE:DE*94): Color difference functions added. Input range checking added to most functions. 2001-09-25 Aubrey Jaffer * strsrch.scm (string-index, string-index-ci, string-reverse-index, string-reverse-index-ci): Optimized. 2001-09-23 Aubrey Jaffer * guile.init: Replaces guile/ice-9/slib.scm. (array-indexes, array-copy!, copy-bit, bit-field, copy-bit-field): Added missing procedures. (slib:load, read): Wrapped with guile:wrap-case-insensitive; fixes symbol-case problems. * logical.scm (bitwise-if): Was missing. * array.scm (create-array): Added function allowing transparent support for uniform-arrays. (make-array): Defined in terms of create-array. 2001-09-22 Aubrey Jaffer * array.scm (array-shape): Fixed confusion with array:shape. 2001-09-12 Aubrey Jaffer * slib.texi (Color Spaces): Documentation for colorspc.scm. * tek41.scm, tek40.scm: Removed very old modules not in catalog. 2001-09-11 Aubrey Jaffer * strcase.scm (StudlyCapsExpand): Added. 2001-09-09 Aubrey Jaffer * colorspc.scm: Added -- CIE, sRGB, e-sRGB color-space transforms. * solid.scm (solid:rotation): Added. 2001-09-06 Aubrey Jaffer * solid.scm (solid:sphere, solid:spheroid, solid:center-row-of, solid:center-array-of, solid:center-pile-of): Added. 2001-09-05 Aubrey Jaffer * solid.scm (solid:color, solid:scale, solid:box): Generalized and documented. 2001-09-04 Aubrey Jaffer * solid.scm: Added VRML97 solid-modeling package. * pnm.scm, nclients.scm, htmlform.scm: Use \\n (not \n) for #\newline in printf strings. 2001-09-01 Aubrey Jaffer * slib.texi (RnRS): Added subsection. * null.scm: Added. * Makefile (revfiles): Added "null.scm" * mklibcat.scm: Added support for AGGREGATE. (r2rs, r3rs, r4rs, r5rs): Added aggregate features. * require.scm (require:require): Added AGGREGATE *catalog* format. * slib.texi (Library Catalogs): Added AGGREGATE *catalog* format. Fri Jul 27 19:54:00 EDT 2001 Aubrey Jaffer * require.scm (*SLIB-VERSION*): Bumped from 2d1 to 2d2. 2001-07-27 Aubrey Jaffer * s48-0_57.init: Added. 2001-07-24 Aubrey Jaffer * array.scm (make-shared-array): Fixed offset. * record.scm: Changed identifiers containing VECTOR to VECT or VCT (but no help for scheme48-0.57). 2001-07-18 Aubrey Jaffer * slib.texi (Collections, Lists as sets, Multi-argument / and -, Multi-argument Apply): Improved procedure templates. * comlist.scm: Replaced single-letter identifier names to improve readability. * slib.texi (Lists as sequences): Updated examples per change to comlist.scm. * comlist.scm (comlist:union, comlist:intersection, comlist:set-difference, comlist:remove-if, comlist:remove-if-not, comlist:remove-duplicates): Earlier tail-recursion enhancements changed the element order; which broke things. Order restored. 2001-07-16 Aubrey Jaffer * array.scm: Rewritten to sidestep license issues. (array=?): Added. * slib.texi (Arrays): Documentation integrated with array.scm. 2001-06-28 Aubrey Jaffer * tree.scm (tree:subst): Rewritten; takes optional equality predicate argument. 2001-06-21 Aubrey Jaffer * Makefile (docfiles): Added "COPYING". 2001-06-19 Aubrey Jaffer * mitcomp.pat: Unmaintained; removed. * RScheme.init: Put in the public domain. 2001-06-11 Jacques Mequin * gambit.init: (set-case-conversion! #t) 2001-06-07 Aubrey Jaffer * Makefile (slib48): Simplified: scheme48 < scheme48.init * scheme48.init (slib-primitives): Pipe into scheme48, not load. Scheme48-0.45 the only version which runs jacal successfully. 2001-06-05 Jacques Mequin * scheme48.init (defmacro): Defmacro in terms of define-syntax using defmacro:expand*. 1998-09-28 Wade Humeniuk * yasyn.scm, object.scm, recobj.scm: Placed in public domain. 2001-05-31 Aubrey Jaffer * scmactst.scm: Removed for lack of license. * struct.scm, structst.scm: Removed. struct.scm lacks license. 2001-05-29 Aubrey Jaffer * scheme48.init (atan): Added workaround. * Makefile (slib48-0.55): Makes slib48, but fluid-let broken. 2001-05-28 Aubrey Jaffer * format.scm (mutliarg/and-): Requires. * mularg.scm (two-arg:/, two-arg:-): Added. * scheme48.init (*features*): Doesn't support multiarg/and-. * Makefile (slib48-0.45): Added ",load-package floatnums". 2001-05-23 Aubrey Jaffer * slib.texi (Installation): Added specific instructions for DrScheme, MIT-Scheme, and Guile. * guile.init: Added. 2001-05-19 Aubrey Jaffer * require.scm (program-vicinity): Improved error message. * slib.texi (Installation): Explicit instructions for MzScheme. 2001-05-15 Aubrey Jaffer * Makefile (pdf): Added target for creating $(htmldir)slib.pdf. 2001-04-26 Aubrey Jaffer * slib.texi (Installation): Expanded instructions. 2001-04-15 Aubrey Jaffer * bigloo.init, RScheme.init, STk.init (*features*): Provide srfi. * Template.scm, *.init (*features*): Put into consistent form. * require.scm (srfi): Detect presence of srfi-0 through srfi-30. 2001-04-12 Aubrey Jaffer * srfi-1.scm: Added. * comlist.scm (comlist:remove): Returns don't disturb order. 2001-04-10 Aubrey Jaffer * array.scm: Generalized so strings and vectors are arrays. * slib.texi (Standard Formatted Output): %b was missing. 2001-04-05 Aubrey Jaffer * slib.texi (Sorting and Searching): Section split from "Procedures". * differ.scm (diff:longest-common-subsequence): Added. (diff:longest-common-subsequence, diff:edits, diff:edit-length): Optional third argument is equality predicate. 2001-04-04 Aubrey Jaffer * differ.scm: An O(NP) Sequence Comparison Algorithm. 2001-03-29 Aubrey Jaffer * srfi.scm (cond-expand): Added. 2001-03-23 Aubrey Jaffer * wttree.scm (error:error): Replaces error. 2001-03-21 Aubrey Jaffer * dbutil.scm (make-defaulter): number defaults to 0. 2001-03-18 Aubrey Jaffer * Makefile (rpm): Fixed dependencies. Thu Mar 15 20:52:30 EST 2001 Aubrey Jaffer * require.scm (*SLIB-VERSION*): Bumped from 2c9 to 2d1. 2001-03-15 Aubrey Jaffer * Makefile (rpm): Added to dist target. (mfiles): Added slib.spec. 2001-03-15 Radey Shouman * slib.spec: Added spec file to generate a .rpm file. Largely based on that of Dr. Robert J. Meier 2001-03-13 Aubrey Jaffer * Makefile (docfiles): Added all the *.txi. * db2html.scm (HTML editing tables): Replaced "record" with "row". * http-cgi.scm (query-alist->parameter-list): Null string --> #f. 2001-03-12 Aubrey Jaffer * coerce.scm (type-of): Removed 'null; broke (coerce '() 'string). 2001-03-09 Aubrey Jaffer * htmlform.scm (html:meta, html:http-equiv): Added. 2001-03-04 Aubrey Jaffer * htmlform.scm (html:meta-refresh): Added. 2001-02-28 Aubrey Jaffer * http-cgi.scm (query-alist->parameter-list): Only separate words for nary parameters. * getparam.scm (getopt->parameter-list): Accomodate positional arguments, both ends. (getopt->parameter-list, getopt->arglist): Take optional description strings. 2001-02-27 Aubrey Jaffer * db2html.scm (command:make-editable-table): Added optional arguments passed to command:modify-table. (command:modify-table): Added null-keys argument; removed pkl. * http-cgi.scm (http:forwarding-page): Added. 2001-02-25 Aubrey Jaffer * htmlform.scm (html:text-area): fixed. * http-cgi.scm (coerce->list): Added. * paramlst.scm (check-arities): Generate warning for wrong arity. * db2html.scm (command:make-editable-table): Deduce arities. * comlist.scm (comlist:list-of??): Added. 2001-02-24 Aubrey Jaffer * coerce.scm (coerce, type-of): Extracted from comlist.scm. 2001-02-16 Aubrey Jaffer * uri.scm (uri:path->keys): Takes list of type-symbols. * simetrix.scm (SI:unit-infos): bit is "bit" (not b). 2001-02-12 Aubrey Jaffer * uri.scm (uri:decode-path, uri:path->keys): Now take path-list instead of path. Fixes bug when '/' was in URI path. * http-cgi.scm (make-query-alist-command-server): Renamed from make-uriencoded-command-server; takes query-alist instead of query-string. Diagnostics can use query-alist without recreating. * db2html.scm (html:linked-row-converter): If a field has a foreign-key of "*catalog-data*", then link to foreign table. (catalog->html, table->linked-html): Put caption at BOTTOM. 2001-02-11 Aubrey Jaffer * htmlform.scm (command->p-specs): Renamed from command->html because it has changed so much. No longer does mapper argument. 2001-02-08 Aubrey Jaffer * db2html.scm (command:make-editable-table): Returns editing-row procedure. * htmlform.scm (html:select, html:buttons, form:element, form:delimited): value-list and visibles arguments combined. * dbutil.scm (get-foreign-choices): extracted from command->html. (make-defaulter): Added. 2001-02-07 Aubrey Jaffer * strcase.scm (symbol-append): Added. * http-cgi.scm (make-uriencoded-command-server): Only apply comval if arglist worked. * htmlform.scm (command->html): Big change; returns list of results of application of (new) MAPPER argument. (form:delimited, form:tabled): Added MAPPER procedures. * db2html.scm (html:editable-row-converter): Check for edit-converter being #f. (command:make-editable-table): *keys*, *row-hash* NOT optional. 2001-02-06 Aubrey Jaffer * htmlform.scm (form:element): Extracted from html:generate-form. * db2html.scm (html:editable-row-converter): Added. (command:modify-table): Handle case all fields are primary keys. 2001-02-04 Aubrey Jaffer * db2html.scm (command:modify-table, command:make-editable-table): (HTML editing tables): Added. * htmlform.scm (form:submit): Enhanced. 2001-01-30 Aubrey Jaffer * uri.scm (uri:decode-authority, make-uri): en/decode userinfo. (uri:make-path): Added. (read-anchor-string): Removed; just use paths for combined keys. * slib.texi (Lists as sets): Examples had incorrect order in returned lists. * uri.scm (html:base, html:isindex): Added. (uri->tree): Optional base-tree argument added for relative URI. Brought into full conformance with RFC 2396 test cases. 2001-01-28 Aubrey Jaffer * uri.scm (html:anchor, html:link uri->tree make-uri): Added. (uri:split-fields, uri:decode-query): Moved and renamed from http-cgi.scm. * htmlform.scm (form:image): Added. 2001-01-27 Aubrey Jaffer * uri.scm: Added collected URI functions from "http-cgi.scm" and "db2html.scm". 2001-01-25 Aubrey Jaffer * makcrc.scm (make-port-crc): Added CRC-16 default. Can now take just generator argument. * db2html.scm (html:linked-row-converter, table->linked-html, table->linked-page, db->html-files, db->html-directory): more evocative names. (html:catalog-row-converter): Stripped down version for catalog. * pp.scm (pretty-print->string): Added. (pp:pretty-print): Use (output-port-width port) for width. * genwrite.scm (genwrite:newline-str): abstracted. * htmlform.scm (html:pre): Improved HTML formatting. 2001-01-24 Aubrey Jaffer * http-cgi.scm (query-alist->parameter-list): Made robust for unexpected option-names; and generates warning. 2001-01-23 Aubrey Jaffer * db2html.scm: Fixed HTML per http://validator.w3.org/check. 2001-01-20 Aubrey Jaffer * simetrix.scm (SI:conversion-factor): Negative return codes. 2001-01-16 Aubrey Jaffer * simetrix.scm (SI:unit-infos): Added katal. Replaced bel (B) with decibel (dB). (SI:prefix-exponents): Added [IEC 60027-2] binary prefixes. (SI:unit-infos): Added bit and byte (B). 2001-01-15 Aubrey Jaffer * simetrix.scm (SI:unit-infos): Updated eV and u from CODATA-1998. (SI:solidus): Abstracted parse functions. 2001-01-14 Aubrey Jaffer * simetrix.scm: SI Metric Interchange Format for Scheme Added. 2001-01-11 Aubrey Jaffer * scanf.scm (stdio:scan-and-set read-ui): Fixed dependence on LET evaluation order. 2001-01-04 Ben Goetter * pscheme.init: Revised. 2001-01-04 Lars Arvestad * gambit.init (*features*): Gambit 3.0 provides call-with-input-string and call-with-output-string. 2000-12-21 Aubrey Jaffer * schmooz.texi: Split out from slib.texi. 2000-12-13 Radey Shouman * printf.scm (stdio:parse-float): Adjust so %e format prints an exponent of zero for 0.0 2000-12-12 Aubrey Jaffer * dbutil.scm (dbutil:list-table-definition): Added. 2000-12-11 Aubrey Jaffer * db2html.scm (html:caption): Split out from html:table. 2000-12-04 Aubrey Jaffer * rdms.scm (sync-database): Added. 2000-10-30 Aubrey Jaffer * pnm.scm (pnm:array-write): PGMs were always being written with 15 for maxval. 2000-10-22 Aubrey Jaffer * http-cgi.scm (make-urlencoded-command-server): Uses the value of *suggest* if *command* is not in the query-string; if neither uses literal *default*. * htmlform.scm (html:form html:hidden html:checkbox html:text html:text-area html:select html:buttons form:submit form:reset): Procedures documented. No longer builds in
tags. 2000-10-16 Aubrey Jaffer * htmlform.scm (html:blank): Added. (html:plain): Returns non-break-space for html:blank. (html:select html:buttons command->html html:generate-form): Added support for VISIBLE-NAME field for foreign-key domains. 2000-10-14 Aubrey Jaffer * debug.scm (for-each-top-level-definition-in-file): define-syntax is a top-level-definition too. * makcrc.scm (make-port-crc): Converted to use read-byte. 2000-10-12 Aubrey Jaffer * htmlform.scm (html:generate-form): was ignoring method. Sat Oct 7 23:09:40 EDT 2000 Aubrey Jaffer * require.scm (*SLIB-VERSION*): Bumped from 2c8 to 2c9. 2000-10-07 Aubrey Jaffer * slib.texi (Installation): Instructions cataloged by implementation. 2000-10-03 Aubrey Jaffer * DrScheme.init: Added support for DrScheme. 2000-09-28 Aubrey Jaffer * http-cgi.scm (form:split-lines): Don't return empty strings. 2000-09-27 Aubrey Jaffer * http-cgi.scm (form-urlencoded->query-alist): Don't convert empty strings to #f. 2000-09-26 Aubrey Jaffer * http-cgi.scm (make-urlencoded-command-server): Unifies form-urlencoded->query-alist, serve-query-alist-command, and invoke-command-on-parameter-list. * paramlst.scm (remove-parameter): Added. 2000-09-25 Aubrey Jaffer * http-cgi.scm (cgi:serve-query): Added. * Makefile, README, mklibcat.scm: Added http-cgi.scm * http-cgi.scm: Split off from htmlform.scm. 2000-09-15 Aubrey Jaffer * randinex.scm (random:solid-sphere!): Return radius. 2000-09-10 Aubrey Jaffer * htmlform.scm: Major rewrite. html: procedures now return strings. * db2html.scm: Moved html table functions from htmlform.scm. 2000-08-06 Aubrey Jaffer * htmlform.scm (html:checkbox): Rectified number of arguments conflict. (html:hidden): Added. (html:text, html:checkbox, html:dt-strong-doc): Added functional procedures; renamed previous with appended `!'. * dbutil.scm (make-command-server): *default* command added. (dbutil:check-domain): Abstracted to top-level procedure. 2000-08-03 Aubrey Jaffer * charplot.scm (find-scale): Pick arbitrary scale when data has range of zero. (plot-function!): Added. 2000-06-24 Colin Walters * comlist.scm (comlist:intersection, comlist:set-difference, comlist:remove, comlist:remove-if, comlist:remove-if-not, comlist:butlast, comlist:butnthcdr): Fixed functions which weren't properly tail recursive. 2000-06-26 Aubrey Jaffer * pnm.scm: PNM image file functions added. 2000-06-25 Aubrey Jaffer * charplot.scm (charplot:iplot!): Fixed label and axis bug. Sat Jun 3 21:26:32 EDT 2000 Aubrey Jaffer * require.scm (*SLIB-VERSION*): Bumped from 2c7 to 2c8. 2000-05-30 Aubrey Jaffer * scsh.init vscm.init umbscheme.init t3.init scheme48.init scheme2c.init mitscheme.init macscheme.init gambit.init chez.init bigloo.init (find-ratio find-ratio-between): Added rationalize adjunct procedures. * ratize.scm (find-ratio-between find-ratio): Advertised procedures return list of numerator and denominator. 2000-05-17 Aubrey Jaffer * schmooz.scm (schmooz-tops): Removed gratuitous newlines in texi output. 2000-04-22 Aubrey Jaffer * alistab.scm (ordered-for-each-key, map-key, for-each-key delete*): Added primary-limit and column-type-list to arguments. * rdms.scm (create-database): Removed warning "file exists". (open-table): Replaced lone call to make-list. (for-each-row, row:delete*, get*): Added primary-limit and column-type-list to arguments. 2000-04-02 Aubrey Jaffer * htmlform.scm (html:start-table): Don't force full width. (http:serve-uri): Added. * db2html.scm: Added. 2000-03-28 Lars Arvestad * minimize.scm (golden-section-search): Added. 2000-03-20 Aubrey Jaffer * genwrite.scm (generic-write, generic-write): Down-cased QUOTE symbol names (for guile). 2000-02-14 Radey Shouman * schmooz.scm (schmooz-tops): Now reads (and ignores) #! comments. 2000-02-05 Aubrey Jaffer * trace.scm (untrack, unstack): Added. (print-call-stack): Protected bindings. 2000-01-27 * Makefile (slib.info): Conditionalize infobar. 2000-01-26 Aubrey Jaffer * require.scm (require:provided?): Don't catalog:get if not *catalog*. 2000-01-24 Radey Shouman * defmacex.scm (defmacro:expand*): Avert MAP error in case input code has a DEFMACRO with an improper list as argument list. (The DEFMACRO still does not take effect). 2000-01-22 Aubrey Jaffer * schmooz.scm (schmooz): replaced non-portable calls to OPEN-FILE. (schmooz): Fixed behavior when filename has no suffix; discard up to first semicolon in file. 2000-01-08 Aubrey Jaffer * trace.scm (call-stack-news?): Fixed polarity error. (debug:trace-procedure): made counts 1-based. 2000-01-02 Aubrey Jaffer * Template.scm, *.init (slib:error, slib:warn): print-call-stack. * trace.scm (print-call-stack, call-stack-news?): Added. * break.scm (debug:breakpoint): print-call-stack. 1999-12-29 Aubrey Jaffer * trace.scm (track, stack): Added ability to maintain call stack of selected procedures. * debug.scm (trace-all, break-all): Now accept multiple (file) arguments. * Makefile (tagfiles): *.init files added. 1999-12-18 Aubrey Jaffer * mklibcat.scm: Added jfilter. * slib.texi (Extra-SLIB Packages): Added jfilter. Sun Dec 5 19:54:35 EST 1999 Aubrey Jaffer * require.scm (*SLIB-VERSION*): Bumped from 2c6 to 2c7. 1999-12-04 Aubrey Jaffer * charplot.scm (charplot:number->string): printf %g gets rid of microscopic fractions. * printf.scm (%g): Make precision threshold work for both fractions and integers. 1999-12-03 Aubrey Jaffer * nclients.scm (browse-url-netscape): Try running netscape in background. 1999-11-14 Aubrey Jaffer * batch.scm (write-batch-line): Added slib:warn. 1999-11-01 Aubrey Jaffer * paramlst.scm (check-parameters): Improved warning. 1999-10-31 Aubrey Jaffer * batch.scm (batch:command): Renamed from batch:system. (batch:try-command): Renamed from batch:try-system. (batch:try-chopped-command): Added. (batch:apply-chop-to-fit): Removed. 1999-09-29 Radey Shouman * glob.scm (replace-suffix): Now works. 1999-09-17 Aubrey Jaffer * slib.texi: Put description and URL into slib_toc.html. Sun Sep 12 22:45:01 EDT 1999 Aubrey Jaffer * require.scm (*SLIB-VERSION*): Bumped from 2c5 to 2c6. 1999-07-08 Aubrey Jaffer * format.scm (format:string-capitalize-first): Renamed from string-capitalize-first. (format:list-head): Renamed from list-head. (string-index): Removed. 1999-06-07 Radey Shouman * printf.scm (stdio:parse-float): Now handles strings representing complex numbers in polar form. (stdio:parse-float): Now parses non-real numbers written in rectangular form. (stdio:iprintf): Inexact formats work on non-real numbers assuming NUMBER->STRING outputs a rectangular format. Inexact formats given a string or symbol rather than a number output "???" if the string cannot be parsed as an inexact number. 1999-06-06 Aubrey Jaffer * fft.scm (fft fft-1): Added. 1999-06-05 Radey Shouman * glob.scm (glob:substitute??, glob:substitute-ci??): Now accept a procedure or string as template argument, for more general transformations. 1999-05-28 Gary T. Leavens * chez.init: Updated for Chez Scheme 6.0a. * bigloo.init: Added. 1999-05-18 Aubrey Jaffer * printf.scm (stdio:iprintf): Extra arguments are *not* a bug. 1999-05-08 Aubrey Jaffer * lineio.scm (read-line!): fixed to eat trailing newline when line length equals string length. 1999-05-08 Ben Goetter * pscheme.init: String-ports added for version Pscheme 0.3.6. 1999-05-07 * charplot.scm (plot-function): Added. (charplot:plot!): Now will accept array argument. 1999-05-02 Jim Blandy * format.scm (format:format): If the first argument is the format string, stick a #f on the front of it, so it is now a valid CL format argument list. This is easier than changing everyplace else (like the error formatter) that expects it to be in CL form. The other clause which explicitly tests for this case is now dead code; remove it. (format:format-work): Allow `@' and `:' in either order, as per modern CL behavior. (format:num->cardinal): Don't assume that an elseless if returns '() when the condition is false. 1999-04-22 Radey Shouman * root.scm (secant:find-root): Replaced hack to decide on accepting regula-falsi step with a modified regula-falsi in which the weight of an "old" function value is repeatedly decreased each time it is retained. 1999-04-13 Radey Shouman * root.scm (secant:find-root): Now checks that a step is actually of nonzero length, otherwise small tolerances lead to not stopping. Tuned for the case that one starting point is much closer to the root than the other. 1999-04-08 Ben Goetter * pscheme.init: updated with defmacro for version 0.3.3. 1999-04-04 Aubrey Jaffer * lineio.scm: Fixed @args command in documentation-comment. 1999-03-27 Aubrey Jaffer * strsrch.scm (find-string-from-port?): Fixed so procedure argument is called at most once per character. 1999-03-11 Radey Shouman * fluidlet.scm: Added (require 'common-list-functions), for MAKE-LIST. 1999-03-08 Aubrey Jaffer * RScheme.init, STk.init, Template.scm, chez.init, elk.init, gambit.init, macscheme.init, mitscheme.init, pscheme.init, scheme2c.init, scheme48.init, scsh.init, t3.init, vscm.init: Added scheme-implementation-home-page definition 1999-03-04 radey * root.scm (secant:find-bracketed-root): Added, requires (f x0) and (f x1) to have opposite signs. 1999-03-03 Radey Shouman * printf.scm (stdio:printf): Tweaks to %k format so that the precision indicates the number of significant digits, as in %g format. 1999-03-02 Radey Shouman * printf.scm (stdio:printf): %k format now uses %f instead of %g to format the scaled number. * root.scm (secant:find-root): Added. 1999-02-25 Radey Shouman * printf.scm (stdio:iprintf): Fixed bug in %f format, (printf "%.1f" 0.001) printed "0", now prints "0.0" 1999-02-12 Hakan L. Younes * batch.scm, slib.texi: amiga-gcc port. 1999-02-10 Radey Shouman * printf.scm (stdio:iprintf): K format now prints no prefix if exponent is beyond the range of the specified prefixes. (stdio:iprintf): Added and corrected SI prefixes, ref http://physics.nist.gov/cuu/Units/prefixes.html . (stdio:iprintf): Added numerical format specifiers %K and %k, which format like %g, except that an SI prefix is output after the number, which is scaled accordingly. %K outputs a space between number and prefix, %k does not. It would be good to allow %f and %e like formatting, but it's not clear how to fit this into the format string syntax. 1999-02-09 Aubrey Jaffer * rdms.scm (domains:init-data): added number domain. 1999-01-30 Matthew Flatt * mbe.scm (hyg:untag-quasiquote): Added to fix quasiquote in output. 1999-01-30 Dorai Sitaram * mbe.scm (mbe:ellipsis-sub-envs, mbe:append-map): Modified to fix multiple ellipses problem. 1999-01-26 Erick Gallesio * STk.init: The actual file. 1999-01-25 Aubrey Jaffer * RScheme.init: added; content is from http://www.rscheme.org/rs/pg1/RScheme.scm 1999-01-24 Aubrey Jaffer * STk.init: added; content is from http://kaolin.unice.fr/STk/FAQ/FAQ-1.html#ss1.9 1999-01-23 Aubrey Jaffer * alistab.scm (open-base): Check file exists before opening it. 1999-01-21 Aubrey Jaffer * htmlform.scm (html:start-page): Extra arguments printed in HEAD (for META tags). 1999-01-20 Aubrey Jaffer * htmlform.scm (make-atval make-plain): use object->string for non-atomic arguments. 1999-01-19 Radey Shouman * printf.scm (stdio:iprintf): Now reports wrong number of arguments instead of silently ignoring extra arguments or taking the CAR of the empty list. Sun Jan 17 12:33:31 EST 1999 Aubrey Jaffer * require.scm (*SLIB-VERSION*): Bumped from 2c4 to 2c5. 1999-01-12 Aubrey Jaffer * mitscheme.init (char-code-limit): Added. Builtin char-code-limit is 65536 (NOT!) in MITScheme Version 8.0. 1999-01-11 Aubrey Jaffer * batch.scm (batch:apply-chop-to-fit): fixed off-by-1 error. 1999-01-10 Aubrey Jaffer * randinex.scm: moved (schmooz) documentation here from scm.texi. (random:uniform1): Renamed from random:uniform. (random:uniform): Added (takes optional state argument). (random:normal): Made reentrant. * random.scm: moved (schmooz) documentation here from scm.texi. 1999-01-09 Aubrey Jaffer * random.scm (seed->random-state): added. 1999-01-08 Aubrey Jaffer * mitscheme.init (object->limited-string): Added. * random.scm (random:random): Fixed embarrassingly stupid bug. 1999-01-07 Aubrey Jaffer * alistab.scm (supported-key-type?): number now allowed. 1998-12-22 Radey Shouman * printf.scm (stdio:round-string): Makes sure result has at least STRIP-0S characters after the implied decimal point if STRIP-0S is not false. Fixes bug associated with engineering notation in SCM. 1998-12-18 Aubrey Jaffer * schmooz.scm (schmooz): Converted from replace-suffix to filename:substitute??. 1998-12-16 Radey Shouman * glob.scm (glob:make-substituter): Made to handle cases where PATTERN and TEMPLATE have different numbers of literal sections. * glob.scm (glob:pattern->tokens, glob:make-matcher): (glob:make-substituter): Fixed to accept null strings as literals to match, for REPLACE-SUFFIX. There is no way to write a glob pattern that produces such a token, should there be? 1998-12-15 Radey Shouman * glob.scm (glob:substitute??) renamed from glob:transform?? (filename:substitute??) identical to glob:substitute?? 1998-12-14 Radey Shouman * glob.scm (glob:pattern->tokens): Separated from GLOB:MAKE-MATCHER. (glob:make-transformer): (glob:transform??): (glob:transform-ci??): Added. (replace-suffix): Rewritten using GLOB:TRANSFORM?? 1998-12-09 Aubrey Jaffer * yasyn.scm: Restored to SLIB. yasos.scm removed. * object.scm: Restored to SLIB * recobj.scm: Restored to SLIB 1998-12-08 Aubrey Jaffer * slib.texi (Copyrights): Added HTML anchor for Copying information. (Installation): Added HTML anchor for Installation instructions. 1998-12-02 Aubrey Jaffer * fluidlet.scm (fluid-let): Rewritten as defmacro. 1998-11-30 Radey Shouman * fluidlet.scm (fluid-let): Changed macro definition so that it doesn't depend on being able to combine input from two different ellipsis patterns. Now produces a nice expansion with macro-by-example so that one can see exactly what goes wrong. 1998-11-29 Aubrey Jaffer * htmlform.scm (table->html): Table conversion functions added. 1998-11-27 Aubrey Jaffer * nclients.scm (glob-pattern?): Added. 1998-11-24 Aubrey Jaffer * htmlform.scm (html:href-heading): simplified. 1998-11-16 Aubrey Jaffer * htmlform.scm (html:comment): No longer puts `>' alone on line. (make-plain make-atval): renamed from html:plain and html:atval; html: functions now all output HTML. * nclients.scm (user-email-address): Ported to W95 and WNT. (make-directory): added. * dbrowse.scm (browse:display-table): Column-foreigns restored. * htmlform.scm (html:atval html:plain): Now accept numbers. (html:pre): Added. (html:start-page html:end-page): Updated to HTML 3.2. HTML header added. * rdms.scm (make-relational-system): column-foreign-list split into column-foreign-check-list and column-foreign-list. 1998-11-12 Aubrey Jaffer * lineio.scm (display-file): added. Schmoozed docs. 1998-11-12 Radey Shouman * schmooz.scm (schmooz-top): No longer emits @defun lines for definitions not separated by blank lines unless they have associated @body comment lines. 1998-11-11 Radey Shouman * fluidlet.scm (fluid-let): Redone to restore variable values even if a continuation captured in the body is invoked. Now agrees with MIT Scheme documentation. 1998-11-11 Aubrey Jaffer * nclients.scm: Added net-clients. * require.scm (vicinity:suffix?): Abstracted from program-vicinity. 1998-11-04 Aubrey Jaffer * comlist.scm (remove-duplicates): added. (adjoin): memq -> memv. Tue Nov 3 17:47:32 EST 1998 Aubrey Jaffer * require.scm (*SLIB-VERSION*): Bumped from 2c3 to 2c4. 1998-10-24 Aubrey Jaffer * cring.scm: Added procedures to create and manipulate rulesets. * cring.scm (cring:db): Distributing / over + led to infinite loops. Now only distribute *. 1998-10-19 amu@mit.edu * timezone.scm (tzfile:vicinity): Linux RH 5.x moved zoneinfo to /usr/share and didn't bother to leave a symlink behind. This caused ctime to print out things in GMT, instead of using the local time. 1998-10-01 Aubrey Jaffer * factor.scm: Moved documentation to schmooz format. (prime:prime< prime:prime>): written. (prime:prngs): added. (Solovay-Strassen??): No longer tries `1'. (prime:products): Added list of prime products smaller than most-positive-fixnum. (prime:sieve): added to test for primes smaller than largest prime in prime:products. (prime:factor): wrapper rewritten. Code cleaned up. * primes.scm: removed. 1998-09-29 Aubrey Jaffer * paramlst.scm (check-parameters): Now generates slib:warn when parameter is wrong type. * debug.scm (for-each-top-level-definition-in-file): Now discards `magic-number' first line of files when first character is `#'. * batch.scm (batch:port parms): enabled warning. 1998-09-28 Aubrey Jaffer * scheme2c.init scsh.init t3.init chez.init, vscm.init, scheme48.init, mitscheme.init, macscheme.init, gambit.init, elk.init, Template.scm: Placed in public domain to make distributing modified versions easier. * schmooz.scm, htmlform.scm, admin.scm, glob.scm, ChangeLog: Cleaned a bit. 1998-09-28 Aubrey Jaffer * slib.texi (most-positive-fixnum): fixed description. 1998-09-22 Ortwin Gasper * random.scm (random:random): Removed one-parameter call to logand. 1998-09-22 Radey Shouman * schmooz.scm: Changed all references to #\nl to #\newline. Removed all references to #\cr. Trailing whitespace no longer prevents issuing a defunx for an additional definition form. 1998-09-21 Aubrey Jaffer * primes.scm: Eliminated use of 1+. (probably-prime?): #f for negative numbers. 1998-09-19 Jorgen Schaefer * glob.scm (glob:match?? glob:match-ci??): fixed wrappers. 1998-09-11 Aubrey Jaffer * Makefile (release): Uploads SLIB.html. * require.scm (*SLIB-VERSION*): Bumped from 2c2 to 2c3. * slib.texi (Filenames): documented pattern strings. * Makefile: Added $srcdir to TEXINPUTS for TeX. 1998-09-10 Radey Shouman * schmooz.scm (schmooz): Added @args markup command. 1998-09-09 Radey Shouman * schmooz.scm (schmooz): Now tries harder to determine whether a definition is of a procedure or non-procedure variable. Recognizes DEFMACRO, DEFINE-SYNTAX. 1998-09-06 Aubrey Jaffer * slib.texi (Schmooz): Added documentation. * Makefile (info htmlform.txi): made smarter about when to run schmooz. 1998-09-03 Radey Shouman * schmooz.scm (scheme-args->macros): Now passed either a symbol, for variable definition, or a possibly improper list, for function/macro definition. For the variable definition case generates @var{... for @0 instead of @code{... Now uses APPEND to be more readable. 1998-09-03 Aubrey Jaffer * slib.texi (Format): documentation moved to fmtdoc.txi. * glob.scm (filename:match?? filename:match-ci??): aliases added. 1998-09-02 Radey Shouman * glob.scm: Added. 1998-09-01 Aubrey Jaffer * primes.scm (primes:prngs): added to reduce likelyhood of reentrant random calls. 1998-08-31 Aubrey Jaffer * random.scm: rewritten using new seedable RNG. * randinex.scm (random:uniform): Rewritten for new RNG. 1998-08-27 Aubrey Jaffer * primes.scm (primes:dbsp?): Now requires 'root and uses integer-sqrt for sqrt on platforms not supporting inexacts. 1998-08-25 * record.scm (rtd-name): Fixed so record rtds print. 1998-08-16 Aubrey Jaffer * cring.scm (*): Number distribution requires separate treatment. 1998-08-11 Aubrey Jaffer * factor.scm (prime:factor): (factor 0) now returns '(0) rather than infinite-looping. 1998-08-09 Aubrey Jaffer * cring.scm (*): Added check for (* -1 (- )) case. 1998-07-08 Aubrey Jaffer * prec.scm (prec:warn): now takes arbitrary number of arguments. (prec:nofix): (prec:postfix): extra arguments are appended to the rules list; not bound. * qp.scm (qp:qp): *qp-width* set to #f now the same as *qp-width* set to 0 -- the full expressions are printed. 1998-07-05 Aubrey Jaffer * prec.scm (prec:nofix): Added . binds args, which are combined with *syn-rules*. 1998-06-12 Aubrey Jaffer * Makefile (dist): Added cvs flag command to dist target. 1998-06-08 Aubrey Jaffer * htmlform.scm (html:start-form): added rest of METHOD types. (html:generate-form command->html): regularized argument order to `command method action'. * dbutil.scm (add-domain): Changed from row:insert to row:update. * rdms.scm (write-database): was not returning status. 1998-06-07 Aubrey Jaffer * strcase.scm (string-ci->symbol): added. * htmlform.scm ((command->html rdb command-table command method action)): renamed from commands->html. Method argument added. (query-alist->parameter-list): now removes whitespace between symbols. Fri Jun 5 16:01:26 EDT 1998 Aubrey Jaffer * require.scm (*SLIB-VERSION*): Bumped from 2c1 to 2c2. 1998-06-04 Aubrey Jaffer * schmooz.scm: Top-level procedure names changed to have `schmooz' in them. * htmlform.scm: Schmooz documentation added for more procedures. 1998-06-03 Aubrey Jaffer * schmooz.scm (document-args->macros): fixed for `rest arglists'. (document-fun): fixed for `rest arglists'. * strsrch.scm (string-subst): added. * htmlform.scm (html:text-subst): removed. References changed to STRING-SUBST. 1998-06-02 radey * Makefile: Added schmooz.scm to ffiles. * schmooz.scm: Texinfo document generator for Scheme programs. 1998-06-02 Aubrey Jaffer * htmlform.scm: Added documentation. (http:send-error-page): scope of fluid-let was wrong. * paramlst.scm (check-parameters): now returns status rather than signal error. 1998-05-30 Aubrey Jaffer * batch.scm (write-batch-line): added. (batch:write-comment-line): added so that batch:call-with-output-script and batch:comment could share code. (batch:write-header-comment): abstracted from batch:call-with-output-script. 1998-05-29 Aubrey Jaffer * htmlform.scm: Added http stuff. 1998-05-24 Aubrey Jaffer * cring.scm (make-rat rat-*): Removed support for rational numbers. 1998-05-14 Radey Shouman * logical.scm ((bit-field n start end)): Renamed from BIT-EXTRACT. ((bitwise-if mask n0 n1)): ((logical:copy-bit index to bool)): ((logical:copy-bit-field to start end from)): added. Tue Apr 14 16:28:20 EDT 1998 Aubrey Jaffer * require.scm (*SLIB-VERSION*): Bumped from 2c0 to 2c1. 1998-04-14 Aubrey Jaffer * byte.scm (bytes-length): added synonym for string-length. 1998-04-14 * printf.scm ((stdio:iprintf out format-string . args)): Added %b descriptor -- outputs a binary number representation. 1998-03-31 * printf.scm ((stdio:iprintf out format-string . args)): Floating point formatting implemented. ((stdio:parse-float str)): ((stdio:round-string str ndigs strip-0s)): Added. 1998-03-11 Radey Shouman * require.scm (program-vicinity): Now gives more informative error message when called from non-loading context. 1998-02-10 William D Clinger * mwexpand.scm (mw:case exp): added. * mwdenote.scm (mw:denote-of-case): added. 1998-02-12 Aubrey Jaffer * eval.scm (eval): Dynamic-binding was not the right paradigm. Changed eval to simply bind identifiers around form to eval. 1998-02-11 Aubrey Jaffer * slib.texi (Top): (Extra-SLIB Packages): Converted to use of new texinfo feature @url. 1998-02-08 Aubrey Jaffer * eval.scm (interaction-environment): fixed. 1998-02-02 Aubrey Jaffer & Radey Shouman * eval.scm (scheme-report-environment): implemented for version arguments of 4 and 5. 1998-02-01 Aubrey Jaffer * eval.scm (eval): R5RS proposed EVAL implemented. Sun Dec 7 22:34:50 1997 Aubrey Jaffer * getparam.scm (getopt->parameter-list getopt->arglist parameter-list->getopt-usage): moved from paramlst.scm. * htmlform.scm (commands->html cgi:serve-command): added. Thu Dec 4 20:00:05 1997 Aubrey Jaffer * timezone.scm (read-tzfile): Now can fail without signaling an error. (tzfile:vicinity): moved here from "tzfile.scm" so we don't have to load "tzfile.scm" to load a non-existant file. Sat Nov 29 22:55:23 1997 Aubrey Jaffer * paramlst.scm (parameter-list->getopt-usage): split out of getopt->parameter-list. Wed Nov 26 23:49:53 1997 Aubrey Jaffer * printf.scm (stdio:sprintf): Now creates and returns string if first argument is #f or an integer (which bounds string). Fixed some bugs. Sun Nov 23 12:31:27 1997 Aubrey Jaffer * Bev2slib.scm: created. Converts Stephen Bevan's "*.map" files to SLIB catalog entries. * require.scm (require:require): Calls catalog:get instead of require:feature->path so symbol-redirected feature names are added to *features* when file is loaded. Mon Nov 17 21:05:59 1997 Aubrey Jaffer * dbrowse.scm (browse): changed default table to #f so that full *catalog-data* can be browsed. Documented. Sat Nov 15 00:15:33 1997 Aubrey Jaffer * cltime.scm (decode-universal-time encode-universal-time): corrected for (now working) timezones. * tzfile.scm (tzfile-read tz-index): added to read Linux (sysV ?) timezone files. * byte.scm: added `bytes', arrays of small integers. Thu Nov 13 22:28:15 1997 Aubrey Jaffer * record.scm (display write): Records now display and write as #. Sun Nov 9 23:45:46 1997 Aubrey Jaffer * timezone.scm: added. Processes TZ environment variable to timezone information. (tzset): takes optional string or timezone argument and returns the current timezone. (time-zone): creates and returns a timezone from a string filename or TZ spec *without* setting global variables. (daylight? *timezone* tzname): Posix (?) global variables are set but SLIB code doesn't depend on them. * psxtime.scm (time:gmktime time:gtime): added to fill out orthogonal function set. The local time functions (localtime mktime ctime) now all take optional timezone arguments. (time:localtime): cleaned interface to timezone.scm: just calls to tzset and tz:params. Mon Oct 20 22:18:16 1997 Radey Shouman * arraymap.scm (array-index-map!): Added. (array-indexes): implemented with array-index-map! Sun Nov 2 22:59:59 1997 Aubrey Jaffer * require.scm (*SLIB-VERSION*): Bumped from 2b3 to 2c0. * require.scm (catalog:get): Now loads "homecat" and "usercat" catalogs in HOME and current directories. (catalog/require-version-match?): debugged for dumped executables. ((require #f)): resets *catalog*. ((require 'new-catalog)): builds new catalog. * mklibcat.scm: Rewrote to output headers and combine implementation and site specific catalogs into "slibcat". * slib.texi (The Library System): Added chapter. Totally reorganized the Manual. Wed Oct 29 22:49:15 1997 Aubrey Jaffer * Template.scm *.init (home-vicinity): added. * require.scm (catalog:try-read): split off from catalog:try-impl-read; useful for reading catalogs from other vicinities. Thu Oct 23 23:14:33 1997 Eric Marsden * factor.scm (prime:product): added EXACT? test. Mon Oct 20 19:33:41 1997 Aubrey Jaffer * slib.texi (Database Utilities): Rewrote and expanded command-line parser example. * paramlst.scm (getopt->parameter-list): Added "Usage" printer for strange option chars. * comlist.scm (coerce): Added 'integer as an alias for 'number. Sat Oct 18 13:03:24 1997 Aubrey Jaffer * strsrch.scm (string-index-ci string-reverse-index-ci substring-ci): added. * comlist.scm (comlist:butnthcdr): added by analogy with butlast. Sun Oct 5 15:16:17 1997 Aubrey Jaffer * scsh.init: Added (thanks to Tomas By). Fri Oct 3 20:50:32 1997 Aubrey Jaffer * comparse.scm (read-command): now correctly handles \^M^J (continued lines). (read-options-file): added. Parses multi-line files of options. Fri Sep 19 22:52:15 1997 Aubrey Jaffer * paramlst.scm (fill-empty-parameters getopt->arglist): defaults argument renamed to defaulters; documentation corrected. Tue Aug 26 17:41:39 1997 Aubrey Jaffer * batch.scm: Changed sun to sunos as platform name. Mon Aug 25 12:40:45 1997 Aubrey Jaffer * require.scm (catalog:version-match?): Now checks and issues warning when *SLIB-VERSION* doesn't match first form in "require.scm". Sun Aug 24 23:56:07 1997 Aubrey Jaffer * require.scm (catalog:version-match?): added to automatically rebuild slibcat when SLIB with new version number is installed. * mklibcat.scm: *SLIB-VERSION* association now included in slibcat. Sat Aug 23 11:35:20 1997 Aubrey Jaffer * selfset.scm: added. (define a 'a) .. (define z 'z). Sat Aug 23 09:32:44 EDT 1997 Aubrey Jaffer * require.scm (*SLIB-VERSION*): Bumped from 2b2 to 2b3. Thu Aug 21 10:20:21 1997 Aubrey Jaffer * determ.scm (determinant): added. Mon Jun 30 10:09:48 1997 Aubrey Jaffer * require.scm: "Supported by all implementations" section removed. * chez.init (defmacro:eval): Chez 5.0 no longer can support defmacro; added SLIB autoload defmacro:expand*. Sun Jun 29 19:36:34 1997 Aubrey Jaffer * cring.scm (cring:db): cring now works for -, /, and ^. Thu Jun 26 00:19:05 1997 Aubrey Jaffer * cring.scm (expression-< x y): added to sort unreduced expressions. Tue Jun 24 13:33:40 1997 Aubrey Jaffer * cring.scm: Added 'commutative-ring feature; extend + and * to non-numeric types. (cring:define-rule): Defines rules for + and * reduction of non-numeric types. Mon Jun 23 22:58:44 EDT 1997 Aubrey Jaffer * require.scm (*SLIB-VERSION*): Bumped from 2b1 to 2b2. Sat Jun 21 23:20:29 1997 Aubrey Jaffer * alistab.scm (map-key for-each-key ordered-for-each-key): Now take match-key argument. (delete*): added. delete-assoc created to *not* accept wildcards in delete keys. * rdms.scm (get* row:delete* row:remove*): Now take match-key arguments, normalize them, and pass to base-table routines. Thu Jun 19 13:34:36 1997 Aubrey Jaffer * alistab.scm (assoc* make-assoc* delete-assoc* assoc*-for-each assoc*-map sorted-assoc*-for-each alist-sort!): added. Functions now support partial matches and key wild-carding. (remover kill-table): remover removed. Kill-table uses delete-assoc*. Sat Jun 14 22:51:51 1997 Aubrey Jaffer * alistab.scm (alist-table): Changed table handle from (table-name . TABLE) to (#(table-name key-dim) . TABLE). (alist-table): Changed primary keys from vectors to lists. Wed 28 May 1997 Dave Love * yasos.scm: Remove case-sensitivity (for Guile). Chop the duplicated code. Mon May 26 21:46:45 1997 Bill Nell * strport.scm (call-with-output-string): losing every 512th character fixed. Wed May 21 19:16:03 1997 Aubrey Jaffer * printf.scm (stdio:iprintf): changed integer-pad to integer-convert and unified conversion of non-numeric values. Wed May 14 14:01:02 1997 Aubrey Jaffer * prec.scm (prec:symbolfy): added so that for most user grammar functions, parsing defaults to the triggering token, instead of the symbol @code{?}. Tue May 13 22:46:22 1997 Albert L. Ting * elk.init (slib:error): re-written. Sat May 10 22:00:30 EDT 1997 Aubrey Jaffer * require.scm (*SLIB-VERSION*): Bumped from 2b0 to 2b1. Wed May 7 15:11:12 1997 Aubrey Jaffer * prec.scm: Rewrote nearly all of JACAL parser and moved it here. Now supports dynamic binding of grammar. Tue May 6 16:23:10 1997 Aubrey Jaffer * strsrch.scm (find-string-from-port?): Enhanced: can take char instead of count and search up to char. Given procedure, tests it on every character. Wed 30 Apr 1997 John David Stone * chez.init: Revised for Chez Scheme 5.0c Tue Apr 29 19:55:35 1997 Aubrey Jaffer * require.scm (*SLIB-VERSION*): Bumped from 2a7 to 2b0. * slib.texi (Library Catalog): section added to describe new catalog mechanism. * Makefile (slib48): Now defines library-vicinity and implementation-vicinity from the makefile. "slibcat" support added. Sat Apr 12 23:40:14 1997 Aubrey Jaffer * mklibcat.scm: moved from "require.scm". Rebuilds "slibcat". * require.scm (catalog:get): now caches *catalog* in implementation-vicinity scheme files "slibcat" and "implcat". Wed Apr 9 20:55:31 1997 Dorai Sitaram * mbe.scm (hyg:map*): Added to correct a minor bug in the hygienic half of mbe.scm that shows up only when define-syntax is used in a right-hand pattern inside syntax-rules. * strsrch.scm (string-reverse-index): added. Tue Apr 8 16:46:35 1997 Aubrey Jaffer * yasos.scm: Replaces "yasyn.scm" and "object.scm"; Those and "recobj.scm" were removed because of unclear copyright status. * printf.scm (stdio:iprintf): no longer translates \r to #\return. Sat Aug 10 16:11:15 1996 Mike Sperber * scheme48.init Makefile: Now makes use of module system to access required primitives. Added install48 target to Makefile. Sat Apr 5 13:26:54 1997 Aubrey Jaffer * array.scm (array-dimensions): fixed off-by-1 bug. Sat Mar 8 17:44:34 1997 Aubrey Jaffer * scanf.scm (stdio:scan-and-set): corrected handling of %5c with short input. Fri Mar 7 21:20:57 EST 1997 Aubrey Jaffer * require.scm (*SLIB-VERSION*): Bumped from 2a6 to 2a7. Sat Feb 22 10:18:36 1997 Aubrey Jaffer * batch.scm (system): added stubifier (returns #f) for when system is not provided. (system:success?): added. * wttree.scm (error): (error:wrong-type-argument): (error:bad-range-argument): Stubs added for non-MITScheme implementations. * Template.scm *.init (slib:warn): added. Sun Feb 16 21:55:59 1997 Michael Pope * gambit.init (scheme-implementation-version): updated for Gambit v2.4. Sun Dec 1 00:44:30 1996 Aubrey Jaffer * batch.scm (truncate-up-to): Added to support compiler habbit of putting object files in current-directory. Sat Aug 31 12:17:30 1996 Aubrey Jaffer * scm.init: added for completeness * record.scm (vector?): infinite recursion fixed. * dbutil.scm (make-command-server): Documentation updated. Wed Aug 21 20:38:26 1996 John Gerard Malecki * vscm.init: Implements string ports using `generic ports'. Wed Aug 21 20:38:26 1996 Aubrey Jaffer * record.scm: rewritten to make records disjoint types which are unforgable and uncorruptable by R4RS procedures. Fri Jul 19 11:24:45 1996 Aubrey Jaffer * structure.scm scaoutp.scm scamacr.scm scainit.scm scaglob.scm scaexpp.scm: Added missing copyright notice and terms. Thu Jul 18 17:37:14 1996 Aubrey Jaffer * rbtest.scm rbtree.scm: removed for lack of copying permissions. Wed Jun 5 00:22:33 1996 Aubrey Jaffer * root.scm (newton:find-integer-root integer-sqrt newton:find-root laguerre:find-root laguerre:find-root): added. Wed May 15 09:59:00 1996 Aubrey Jaffer * scanf.scm (stdio:scan-and-set): removed gratuitous char-downcase by changing all (next-format-char) ==> (read-char format-port). Tue Apr 9 19:22:40 1996 Aubrey Jaffer * slib2a5 released. * mwtest.scm: removed from distribution for lack of copyright info. * batch.scm (batch:apply-chop-to-fit): added (batch:try-system): renamed from batch:system. (batch:system): now signals error if line length over limit or system calls fail. Sun Aug 20 19:20:35 1995 Gary Leavens * struct.scm (check-define-record-syntax check-variant-case-syntax): For using the file "struct.scm" with the EOPL book, one has to make 2 corrections. To correct it, there are two places where "-" has to be replaced by "->" as in the code below... Sat Apr 6 14:31:19 1996 Aubrey Jaffer * batch.scm (must-be-first must-be-last): added. * paramlst.scm (check-parameters): made error message more informative. Mon Mar 18 08:46:36 1996 Aubrey Jaffer * modular.scm (modular:*): non-bignum symmetric modulus case was dividing by 0. Algorithm still needs to be fixed. Mon Mar 13 00:41:00 1996 Aubrey Jaffer * slib2a4 released. Sat Mar 9 21:36:19 1996 Mikael Djurfeldt * tsort.scm (topological-sort): Added. Fri Mar 8 19:25:52 1996 Aubrey Jaffer * printf.scm: Removed use of string-ports. Cleaned up error handling. Tue Mar 5 14:30:09 1996 Aubrey Jaffer * printf.scm (%a %A): General scheme output specifier added. Mon Feb 19 15:48:06 1996 Aubrey Jaffer * scanf.scm (stdio:scan-and-set): Removed flush-whitespace from all conversion specifications per suggestion from oleg@acm.org (Oleg Kiselyov). Sat Feb 3 00:02:06 1996 Oleg Kiselyov (oleg@acm.org) * strsrch.scm (string-index substring? find-string-from-port?): added. Mon Jan 29 23:56:33 1996 Aubrey Jaffer * printf.scm (stdio:iprintf): Rewrote for Posix compliance (+ extensions which are both BSD and GNU). Sat Jan 27 09:55:03 1996 Aubrey Jaffer * FAQ: printf vs. format explained. * printf.scm: renamed from "stdio.scm". (require 'printf) now brings in "printf.scm". Sun Jan 14 21:00:17 1996 Aubrey Jaffer * scanf.scm: Rewrote from scratch. Mon Oct 9 22:48:58 1995 Aubrey Jaffer (jaffer@jacal) * modular.scm (modular:invertable?): added. Wed Sep 27 10:01:04 1995 Aubrey Jaffer (jaffer@jacal) * debug.scm: augmented, reorganized, and split. (print): removed. * break.scm: created. * qp.scm: created. Sun Sep 24 22:23:19 1995 Aubrey Jaffer (jaffer@jacal) * require.scm (*catalog*): test.scm removed. Sun Sep 17 21:32:02 1995 Aubrey Jaffer (jaffer@jacal) * modular.scm: rewritten so that if modulus is: positive? -- work as before (Z_modulus) zero? -- perform integer operations (Z) negative? -- perform operations using symmetric representation (Z_(1-2*modulus)) (symmetric:modulus modulus->integer modular:normalize): added. (modular:*): not completed for fixnum-only implementations. Sat Sep 9 16:53:22 1995 Aubrey Jaffer (jaffer@jacal) * slib.texi (Legacy): added for t, nil, last-pair, and identity, which are now required of all implementations. Mon Aug 28 00:42:29 1995 Aubrey Jaffer (jaffer@jacal) * require.scm (require:feature->path require:provided? require:require): cleaned up. feature->path now returns a path, whether the module is loaded or not. Sun Aug 27 11:05:19 1995 Aubrey Jaffer (jaffer@jacal) * genwrite.scm (generic-write): Fixed "obj2str" OBJECT->LIMITED-STRING non-terminating wr-lst for cases like (set-car! foo foo). * obj2str.scm (object->limited-string): uncommented. Sun Aug 20 17:10:40 1995 Stephen Adams * wttest.scm wttree.scm: Weight Balanced Trees added. Sun Aug 20 16:06:20 1995 Dave Love * tree.scm yasyn.scm collect.scm: Uppercase identifiers changed to lower case for compatability with case sensitive implementations. Sat Aug 19 21:27:55 1995 Aubrey Jaffer (jaffer@jacal) * arraymap.scm (array-copy!): added. * primes.scm (primes:primes< primes:primes>): primes:primes split into ascending and descending versions. Sun Jul 16 22:44:36 1995 Aubrey Jaffer (jaffer@jacal) * makcrc.scm (make-port-crc): added. POSIX.2 checksums. Mon Jun 12 16:20:54 1995 Aubrey Jaffer (jaffer@jacal) * synclo.scm (internal-syntactic-environment top-level-syntactic-environment): replaced call to alist-copy. * require.scm (*catalog*): 'schelog, 'primes, and 'batch added. 'prime renamed to 'factor. From: mhc@edsdrd.eds.com (Michael H Coffin) * primes.scm (primes probably-prime?): added. prime.scm renamed to factor.scm. Fri Mar 24 23:35:25 1995 Matthew McDonald * struct.scm (define-record): added field-setters. Sun Jun 11 23:36:55 1995 Aubrey Jaffer (jaffer@jacal) * batch.scm: added * Makefile (schelogfiles): SLIB schelog distribution created. Mon Apr 17 15:57:32 1995 Aubrey Jaffer (jaffer@jacal) * comlist.scm (coerce type-of): added. * debug.scm (debug:qp): with *qp-width* of 0 just `write's. * paramlst.scm (getopt->parameter-list): Now accepts long-named options. Now COERCEs according to types. Sat Apr 15 23:15:26 1995 Aubrey Jaffer (jaffer@jacal) * require.scm (require:feature->path): Returns #f instead of string if feature not in *catalog* or *modules*. Sun Mar 19 22:26:52 1995 Aubrey Jaffer (jaffer@jacal) * getopt.scm (getopt-- argc argv optstring): added wrapper for getopt which parses long-named-options. Tue Feb 28 21:12:14 1995 Aubrey Jaffer (jaffer@jacal) * paramlst.scm (parameter-list-expand expanders parms): added. Mon Feb 27 17:23:54 1995 Aubrey Jaffer (jaffer@jacal) * report.scm (dbutil:print-report): added. * comparse.scm (read-command): added. Reads from a port and returns a list of strings: the arguments (and options). Sat Feb 25 01:05:25 1995 Aubrey Jaffer (jaffer@jacal) * repl.scm (repl:repl): Added loop, conditional on CHAR-READY? being PROVIDED?, which reads through trailing white-space. Sun Feb 5 16:34:03 1995 Aubrey Jaffer (jaffer@jacal) * paramlst.scm ((make-parameter-list parameter-names)): ((fill-empty-parameters defaults parameter-list)): ((check-parameters checks parameter-list)): ((parameter-list->arglist positions arities parameter-list)): ((parameter-list-ref parameter-list i)): ((adjoin-parameters! parameter-list parameters)): Procedures for making, merging, defaulting, checking and converting `parameter lists' (named parameters). ((getopt->parameter-list argc argv optnames arities aliases)): ((getopt->arglist argc argv optnames positions arities defaults checks aliases)): Procedures for converting options and arguments processed by getopt to parameter-list or arglist form. * dbutil.scm ((make-command-server rdb command-table)): added procedure which calls commands and processes parameters. * rdms.scm ((make-relational-system base)): add-domain and delete-domain commands moved to "dbutil.scm" (create-database). Fri Feb 3 11:07:46 1995 Aubrey Jaffer (jaffer@jacal) * debug.scm (debug:tracef debug:untracef): removed (duplicates of code in "trace.scm"). (trace-all): utility to trace all defines in a file added. Thu Jan 19 00:26:14 1995 Aubrey Jaffer (jaffer@jacal) * logical.scm (logbit? logtest): added. Sun Jan 15 20:38:42 1995 Aubrey Jaffer (jaffer@jacal) * dbutil.scm (dbutil:create-database)): Added parameter description tables for "commands". * require.scm (software-type): standardize msdos -> ms-dos. Mon Jan 2 10:26:45 1995 Aubrey Jaffer (jaffer@jacal) * comlist.scm (comlist:atom?): renamed from comlist:atom. * scheme48.init (char->integer integer->char): Now use integers in the range 0 to 255. Fixed several other problems. (modulo): Worked around negative modulo bug. * Makefile (slib48): `make slib48' loads "scheme48.init", `,dump's a scheme48 image file, and creates an `slib48' shell script to invoke it. * hash.scm (hash:hash-number): no longer does inexact->exact to exacts, etc. * trnscrpt.scm (read): no longer transcripts eof-objects. From: johnm@vlibs.com (John Gerard Malecki) * priorque.scm (heap:heapify): internal defines incorrectly dependent on order-of-eval replaced with let*. Thu Dec 22 13:28:16 1994 Aubrey Jaffer (jaffer@jacal) * dbutil.scm (open-database! open-database create-database): This enhancement wraps a utility layer on `relational-database' which provides: * Automatic loading of the appropriate base-table package when opening a database. * Automatic execution of initialization commands stored in database. * Transparent execution of database commands stored in `*commands*' table in database. Wed Dec 21 22:53:57 1994 Aubrey Jaffer (jaffer@jacal) * rdms.scm (make-relational-system base): Now more careful about protecting read-only databases. Mon Dec 19 00:06:36 1994 Aubrey Jaffer (jaffer@jacal) * dbutil.scm (dbutil:define-tables): added utility which provides: Data definition from Scheme lists for any SLIB relational-database. Sat Dec 17 12:10:02 1994 Aubrey Jaffer (jaffer@jacal) * alistab.scm rdms.scm (make-getter row-eval): evaluation of `expression' fields no longer done when retrieved from base tables (which made copying of many tables impossible). * alistab.scm (write-base): rewrote to not use pretty-print. * sc3.scm: removed (only contained last-pair, t, and nil). * Template.scm scheme48.init vscm.init (last-pair t nil): added. Thu Dec 8 00:02:18 1994 Aubrey Jaffer (jaffer@jacal) * mularg.scm pp.scm ratize.scm: copyright line removed from files (still lacking terms) less than 12 lines. From: johnm@vlibs.com (John Gerard Malecki) * sort.scm (sort:sort!): long standing bug in sort! with vector argument fixed. Thu Dec 1 17:10:24 1994 Aubrey Jaffer (jaffer@jacal) * *.scm: Most missing copyright notices supplied. Sun Nov 27 23:57:41 1994 Aubrey Jaffer (jaffer@jacal) * rdms.scm (make-relational-system base): now checks field types when table is opened. Domains table now has foreign-table field. (for-each-row): ordered for-each function added. * alistab.scm (ordered-for-each-key supported-key-type?): added. Thu Oct 27 12:20:41 1994 Tom Tromey * priorque.scm: Renamed everything to conform to coding standards and updated docs. Changed names: heap-extract-max to heap-extract-max!, heap-insert to heap-insert! and heap-size to heap-length. Sat Nov 26 22:52:31 1994 Aubrey Jaffer (jaffer@jacal) * Template.scm *.init (identity): Now required; moved from "comlist.scm". * alistab.scm (alist-table): Converted to representing rows as lists. Non-row operations removed. * rdms.scm (make-relational-system base): Most individual column operations removed. Only get and get* remain. Row operations renamed. Row inserts and updates distinguished. Tue Nov 15 16:37:16 1994 Aubrey Jaffer (jaffer@jacal) * rdms.scm (make-relational-system base): Generalized database system inspired by the Relational Model. * alistab.scm (alist-table): Base table implementation suitable for small databases and testing rdms.scm. Tue Oct 25 22:36:01 1994 Aubrey Jaffer (jaffer@jacal) From: Tommy Thorn * chez.init (scheme-implementation-version): fixed (changed to "?"). (library-vicinity): The definition of library-vicinity used getenv, which was defined later. (slib:chez:quit): The definition of slib:chez:quit was illegal. Fixed. (chez:merge!): had a typo. (defmacro:load): (require 'struct) didn't work, because defmacro:load doesn't add suffix. Workaround: defmacro:load and macro:load is the same as slib:load-source. Wed Oct 19 11:44:12 1994 Aubrey Jaffer (jaffer@jacal) * require.scm time.scm cltime.scm (difftime offset-time): added to allow 'posix-time functions to work with a non-numeric type returned by (current-time). Tue Aug 2 10:44:32 1994 Aubrey Jaffer (jaffer@jacal) * repl.scm (repl:top-level repl:repl): Multiple values at top level now print nicely. Sun Jul 31 21:39:54 1994 Aubrey Jaffer (jaffer@jacal) * cltime.scm (get-decoded-time get-universal-time decode-universal-time encode-universal-time): Common-Lisp time conversion routines created. * time.scm (*timezone* tzset gmtime localtime mktime asctime ctime): Posix time conversion routines created. Mon Jul 11 14:16:44 1994 Aubrey Jaffer (jaffer@jacal) * Template.scm mitscheme.init scheme2c.init t3.init (*features*): trace added. Fri Jul 8 11:02:34 1994 Aubrey Jaffer (jaffer@jacal) * chap.scm ((chap:string did not include the expression and the expression, instead it incorrectly included the expression. (rf. R4RS, 4.2.4) (hyg:tag-lambda): the body of a lambda expression should be generated using hyg:tag-generic instead of hyg:tag-vanilla. This allows expressions within lambda to behave hygienically. (hyg:tag-let): extended to support `named let'. Sun Apr 10 00:22:04 1994 Aubrey Jaffer (jaffer@jacal) * README: INSTALLATION INSTRUCTIONS greatly improved. * Template.scm *.init: Path configurations move to top of files for easier installation. * FAQ: File of Frequently Asked Questions and answers added. Sat Apr 9 21:28:46 1994 Aubrey Jaffer (jaffer@jacal) * slib.texi (Vicinity): scheme-file-suffix removed. Use slib:load or slib:load-source instead. Wed Apr 6 00:55:16 1994 Aubrey Jaffer (jaffer@jacal) * require.scm (slib:report): (slib:report-version): (slib:report-locations): added to display SLIB configuration information. Mon Apr 4 08:48:37 1994 Aubrey Jaffer (jaffer@jacal) * Template.scm *.init (slib:exit): added. Fri Apr 1 14:36:46 1994 Aubrey Jaffer (jaffer@jacal) * Makefile (intro): Added idiot message for those who make. Cleaned up and reorganized Makefile. Wed Mar 30 00:28:30 1994 Aubrey Jaffer (jaffer@jacal) * Template.scm *.init ((slib:eval-load evl)): created to service all macro loads. From: whumeniu@datap.ca (Wade Humeniuk) * recobj.scm yasyn.scm: added. These implement RECORDS and YASOS using object.scm object system. Sun Mar 6 01:10:53 1994 Aubrey Jaffer (jaffer@jacal) From: barnett@armadillo.urich.edu (Lewis Barnett) * gambit.init (implementation-vicinity library-vicinity): Relative pathnames for Slib in MacGambit. From: lucier@math.purdue.edu (Brad Lucier) * random.scm (random:random random:chunks/float): fixed off-by-one and slop errors. Thu Mar 3 23:06:41 1994 Aubrey Jaffer (jaffer@jacal) From: lutzeb@cs.tu-berlin.de (Dirk Lutzebaeck) * format.scm slib.texi: Format 3.0. * format's configuration is rearranged to fit only into SLIB. All implementation dependent configurations are done in the SLIB init files * format's output routines rely on call-with-output-string now if output to a string is desired * The floating point formatting code (formatfl.scm) moved into format.scm so that there is only one source code file; this eliminates the configuration of the load path for the former formatfl.scm and the unspecified scope of the load primitive * floating point formatting doesn't use any floating point operation or procedure except number->string now; all formatting is now based solely on string, character and integer manipulations * major rewrite of the floating point formatting code; use global buffers now * ~f,~e,~g, ~$ may use also number strings as an argument * ~r, ~:r, ~@r, ~:@r roman numeral, and ordinal and cardinal English number printing added (from dorai@cs.rice.edu) * ~a has now a working `colinc' parameter * ~t tabulate directive implemented * ~/ gives a tabulator character now (was ~T in version < 2.4) * ~& fresh line directive implemented * ~@d, ~@b, ~@o and ~@x now has the CL meaning (plus sign printed) automatic prefixing of radix representation is removed * ~i prints complex numbers as ~f~@fi with passed parameters * ~:c prints control characters like emacs (eg. ^C) and 8bit characters as an octal number * ~q gives information and copyright notice on this format implementation ~:q gives format:version * case type of symbol conversion can now be forced (see format:symbol-case-conv in format.scm) * case type of the representation of internal objects can now be forced (see format:iobj-case-conv format.scm) * format error messages are now printed on the current error port if available by the implementation * format now accepts a number as a destination port; the output is then always directed to the current error port if available by the implementation * if format's destination is a string it is regarded as a format string now and output is the current output port; this is a contribution to Scheme->C to use format with the runtime system; the former semantics to append tothe destination string is given up * obj->string syntax change and speedup * tested with scm4d, Elk 2.2, MIT Scheme 7.1, Scheme->C 01Nov91 Wed Mar 2 13:16:37 1994 Aubrey Jaffer (jaffer@jacal) From: Matthias Blume * vscm.init: added. Fri Feb 18 23:51:41 1994 Aubrey Jaffer (jaffer@jacal) From: jjb@isye.gatech.edu (John Bartholdi) * macscheme.init: added. Thu Feb 17 01:19:47 1994 Aubrey Jaffer (jaffer@jacal) * ppfile.scm ((pprint-filter-file inport filter outport)): added. Useful for pre-expanding macros. Preserves top-level comments. Wed Feb 16 12:44:34 1994 Aubrey Jaffer (jaffer@jacal) From: dorai@cs.rice.edu (Dorai Sitaram) * mbe.scm: Macro by Example define-syntax using defmacro. Tue Feb 15 17:18:56 1994 Aubrey Jaffer (jaffer@jacal) From: whumeniu@datap.ca (Wade Humeniuk) * object.scm: Macroless Object System Mon Feb 14 00:48:18 1994 Aubrey Jaffer (jaffer@jacal) * defmacex.scm (defmacro:expand*): replaces "defmacro.scm". Other defmacro functions now supported in all implementations. Sun Feb 13 12:38:39 1994 Aubrey Jaffer (jaffer@jacal) * defmacro.scm (defmacro:macroexpand*): now expands quasiquotes correctly. Sat Feb 12 21:23:56 1994 Aubrey Jaffer (jaffer@jacal) * hashtab.scm ((predicate->hash pred)): moved from hash.scm. Tue Feb 8 01:07:00 1994 Aubrey Jaffer (jaffer@jacal) * Template.scm *.init (slib:load-source slib:load-compiled slib:load): support for loading compiled modules added. Dependence on SCHEME-FILE-SUFFIX removed. * require.scm (require:require): Added support for 'source and 'compiled features. Sat Feb 5 00:19:38 1994 Aubrey Jaffer (jaffer@jacal) * stdio.scm ((stdio:sprintf)): Now truncates printing if you run out of string. Fri Feb 4 00:54:14 1994 Aubrey Jaffer (jaffer@jacal) From: pk@kaulushaikara.cs.tut.fi (Kellom'ki Pertti) * (psd/primitives.scm): Here is a patch removing some problems with psd-1.1, especially when used with Scheme 48. Thanks to Jonathan Rees for poiting them out. The patch fixes two problems: references to an unused variable *psd-previous-line*, and the correct number of arguments to write-char. Fri Jan 14 00:37:19 1994 Aubrey Jaffer (jaffer@jacal) * require.scm (require:require): Now supports (feature . argument-list) associations. Sat Nov 13 22:07:54 1993 (jaffer at jacal) * slib.info (Structures): added. Bug - struct.scm and structure.scm do not implement the same macros. Mon Nov 1 22:17:01 1993 (jaffer at jacal) * array.scm (array-dimensions array-rank array-in-bounds?): added. Sat Oct 9 11:54:54 1993 (jaffer at jacal) * require.scm (*catalog* portable-scheme-debugger): support added for psd subdirectory. Tue Sep 21 11:48:26 1993 Aubrey Jaffer (jaffer at wbtree) * Makefile (lineio.scm rbtree.scm rbtest.scm scmacro.scm sc4sc3.scm scaespp.scm scaglob.scm scainit.scm scamacr.scm scaoutp.scm strcase.scm): hyphens removed from names. Mon Sep 20 00:57:29 1993 (jaffer at jacal) * arraymap.scm (array-map! array-for-each array-indexes): added. Sun Sep 19 19:20:49 1993 (jaffer at jacal) * require.scm (require:feature->path require:require *catalog*): associations of the form (symbol1 . symbol2) in *catalog* look up symbol2 whenever symbol1 is specified. Mon Sep 13 22:12:00 1993 (jaffer at jacal) From: sperber@provence.informatik.uni-tuebingen.de (Michael Sperber) * elk.init: updated to ELK version 2.1. Sat Sep 11 21:17:45 1993 (jaffer at jacal) * hashtab.scm (hash-for-each): fixed and documented (also documented alist.scm). Fri Sep 10 15:57:50 1993 (jaffer at jacal) * getopt.scm (getopt *optind* *optarg*): added. Tue Sep 7 23:57:40 1993 (jaffer at jacal) * slib1d3 released. * comlist.scm: prefixed all functions with "comlist:". Tue Aug 31 23:59:28 1993 (jaffer at jacal) * Template.scm *.init (output-port-height): added. Wed May 26 00:00:51 1993 Aubrey Jaffer (jaffer at camelot) * hashtab.scm (hash-map hash-for-each): added. * alist.scm (alist-map alist-for-each): added. Tue May 25 22:49:01 1993 Aubrey Jaffer (jaffer at camelot) * comlist.scm (delete delete-if atom): renamed as in common lisp. * comlist.scm (delete-if-not): added. * tree.scm: moved tree functions out of comlist.scm Mon May 24 10:28:22 1993 Aubrey Jaffer (jaffer at camelot) From: hanche@ams.sunysb.edu (Harald Hanche-Olsen) * modular.scm: improvements and fixed bug in modular:expt. Fri May 14 01:26:44 1993 Aubrey Jaffer (jaffer at camelot) * slib1d2 released. From: Dave Love * comlist.scm: added some tree functions. * yasos.scm collect.scm: fixed name conflicts and documentation. Tue May 11 01:22:40 1993 Aubrey Jaffer (jaffer at camelot) * eval.scm: removed because all *.init files support it. * hash.scm: made all hash functions case-insensitive. Equal inexact and exact numbers now hash to the same code. From: eigenstr@falstaff.cs.rose-hulman.edu: * slib.texi: revised. Sun May 9 01:43:11 1993 Aubrey Jaffer (jaffer at camelot) From: kend@newton.apple.com (Ken Dickey) * macwork.scm mwexpand.scm mwdenote.scm mwsynrul.scm: Macros no longer expand builtin Scheme forms. From: William Clinger * macwork.scm mwexpand.scm mwdenote.scm mwsynrul.scm: Macros that work added. Sat May 1 23:55:42 1993 Aubrey Jaffer (jaffer at montreux) * random.scm (random:random): sped up for exact arguments. Wed Apr 28 00:24:36 1993 Aubrey Jaffer (jaffer at camelot) From: lutzeb@flp.cs.tu-berlin.de (Dirk Lutzebaeck) * format.scm formatfl.scm formatst.scm slib.texi: Format 2.3. * implemented floating point support ~F,~E,~G,~$ * automatic detection if the scheme interpreter support flonums. * the representation of internal objects can be selected to be #<...> or #[...] or other forms * new/redefintion of configuration variables format:abort, format:floats, format:formatfl-path, format:iobj-pref, format:iobj-post * added string-index * added MIT Scheme 7.1 custom types * for efficiencies reasons the error continuation is only used if format:abort is not available * improved error presentation and error handling * tested with scm4b/c, Elk 2.0, MIT Scheme 7.1, Scheme->C 01Nov91, UMB Scheme 2.5/2.10 Sun Apr 25 22:40:45 1993 Aubrey Jaffer (jaffer at camelot) From: Dave Love * scheme2c.init: corrections and portability improvements. * yasos.scm collect.scm: These correct the scheme2c.init and a couple of other things as well as hiding some non-exported definitions and removing an example from collect.scm to the manual. Sat Apr 3 00:48:13 1993 Aubrey Jaffer (jaffer at camelot) From: eigenstr@cs.rose-hulman.edu (Todd R. Eigenschink) * slib.texi: created. Thu Mar 25 01:47:38 1993 Aubrey Jaffer (jaffer at camelot) From: hanche@ams.sunysb.edu (Harald Hanche-Olsen) * sca-init.scm sca-glob.scm sca-macr.scm sca-outp.scm sca-expp.scm: syntax-case macros added. Wed Mar 24 23:12:49 1993 Aubrey Jaffer (jaffer at camelot) * comlist.scm (some every notany notevery): Now accept multiple arguments. NOTANY added. Wed Mar 3 01:19:11 1993 Aubrey Jaffer (jaffer at camelot) From: "Dan Friedman" * struct.scm structst.scm: added. Tue Mar 2 00:28:00 1993 Aubrey Jaffer (jaffer at camelot) * obj2str (object->string): now handles symbols and number without going to string-port. Sun Feb 28 22:22:50 1993 Aubrey Jaffer (jaffer at camelot) * all files with Jaffer copyright: Now have explicit conditions for use and copying. Fri Feb 26 00:29:18 1993 Aubrey Jaffer (jaffer at camelot) * obj2str: redefined in terms of string ports. * pp2str: eliminated. Mon Feb 22 17:21:21 1993 Aubrey Jaffer (jaffer at camelot) From: dorai@cs.rice.edu (Dorai Sitaram) * strport.scm: string ports. From: Alan@LCS.MIT.EDU (Alan Bawden) * array.scm: functions which implement arrays. Wed Feb 17 00:18:57 1993 Aubrey Jaffer (jaffer at camelot) * repl.scm: split off from sc-macro.scm. * eval.scm *.init Template.scm (eval!): eliminated. From: dorai@cs.rice.edu (Dorai Sitaram) * defmacro.scm: added. Chez, elk, mitscheme, scheme2c, and scm support. Tue Feb 16 00:23:07 1993 Aubrey Jaffer (jaffer at camelot) * require.doc (output-port-width current-error-port tmpnam file-exists? delete-file force-output char-code-limit most-positive-fixnum slib:tab slib:form-feed error):descriptions added. * *.init (tmpnam): now supported by all. From: dorai@cs.rice.edu (Dorai Sitaram) * chez.init elk.init mitscheme.init scheme2c.init (defmacro macro? macro-expand): added. Mon Feb 15 00:51:22 1993 Aubrey Jaffer (jaffer at camelot) * Template.scm *.init (file-exists? delete-file): now defined for all implementations. Sat Feb 13 23:40:22 1993 Aubrey Jaffer (jaffer at camelot) * chez.init (slib:error): output now directed to (current-error-port). Thu Feb 11 01:23:25 1993 Aubrey Jaffer (jaffer at camelot) * withfile.scm (with-input-from-file with-output-from-file): now close file on thunk return. * *.init (current-error-port): added. Wed Feb 10 17:57:15 1993 Aubrey Jaffer (jaffer at camelot) * mitscheme.init (values dynamic-wind): added to *features*. From: mafm@cs.uwa.edu.au (Matthew MCDONALD) * mitcomp.pat: added patch file of definitions for compiling SLIB with MitScheme. Tue Feb 9 10:49:12 1993 Aubrey Jaffer (jaffer at camelot) From: jt@linus.mitre.org (F. Javier Thayer) * t3.init: additions and corrections. Mon Feb 8 20:27:18 1993 Aubrey Jaffer (jaffer at camelot) From: dorai@cs.rice.edu (Dorai Sitaram) * chez.init: added. Wed Feb 3 23:33:49 1993 Aubrey Jaffer (jaffer at camelot) * sc-macro.scm (macro:repl): now prints error message for errors. Mon Feb 1 22:22:17 1993 Aubrey Jaffer (jaffer at camelot) * logical.scm (logor): changed to logior to be compatible with common Lisp. Fri Jan 29 17:15:03 1993 Aubrey Jaffer (jaffer at camelot) From: jt@linus.mitre.org (F. Javier Thayer) * t3.init: modified so it passes most of SCM/test.scm. Sun Jan 24 00:18:13 1993 Aubrey Jaffer (jaffer at camelot) * comlist.scm (intersection): added. Wed Jan 13 19:01:11 1993 Aubrey Jaffer (jaffer at camelot) * debug.scm: (debug:qp): needed to shadow quotient. Sat Jan 9 13:44:44 1993 Aubrey Jaffer (jaffer at camelot) * rb-tree.scm: changed use of '() and NULL? to #f and NOT. * rb-tree.scm (rb-insert! rb-delete!) added ! to names. Fri Jan 8 01:17:16 1993 Aubrey Jaffer (jaffer at camelot) * rb-tree.doc: added. From: pgs@ai.mit.edu (Patrick Sobalvarro) * rb-tree.scm rbt-test.scm: code for red-black trees added. Tue Jan 5 14:57:02 1993 Aubrey Jaffer (jaffer at camelot) From: lutzeb@cs.tu-berlin.de (Dirk Lutzebaeck) * format.scm formatst.scm format.doc: version 2.2 * corrected truncation for fixed fields by negative field parameters inserted a '<' or a '>' when field length was equal to object string length * changed #[...] outputs to #<...> outputs to be conform to SCM's display and write functions * changed #[non-printable-object] output to # * ~:s and ~:a print #<...> messages in strings "#<...>" so that the output can always be processed by (read) * changed implementation dependent part: to configure for various scheme systems define the variable format:scheme-system * format:version is a variable returning the format version in a string * format:custom-types allows to use scheme system dependent predicates to identify the type of a scheme object and its proper textual representation * tested with scm4a14, Elk 2.0 Tue Dec 22 17:36:23 1992 Aubrey Jaffer (jaffer at camelot) * Template.scm *.init (char-code-limit): added. * debug.scm (qp): qp-string had bug when printing short strings when room was less than 3. * random.scm (random:size-int): now takes most-positive-fixnum into account. Wed Nov 18 22:59:34 1992 Aubrey Jaffer (jaffer at camelot) From: hanche@ams.sunysb.edu (Harald Hanche-Olsen) * randinex.scm (random:normal-vector! random:normal random:solid-sphere random:hollow-sphere): new versions fix bug. Tue Nov 17 14:00:15 1992 Aubrey Jaffer (jaffer at Ivan) * str-case.scm (string-upcase string-downcase string-capitalize string-upcase! string-downcase! string-capitalize!): moved from format.scm. Fri Nov 6 01:09:38 1992 Aubrey Jaffer (jaffer at Ivan) * require.scm (require): uses base:load instead of load. * sc-macro.scm (macro:repl): now uses dynamic-wind. Mon Oct 26 13:21:04 1992 Aubrey Jaffer (jaffer at Ivan) * comlist.scm (nthcdr last) added. Sun Oct 25 01:50:07 1992 Aubrey Jaffer (jaffer at Ivan) * line-io.scm: created Mon Oct 19 12:53:01 1992 Aubrey Jaffer (jaffer at camelot) From: dorai@cs.rice.edu * fluidlet.scm: FLUID-LET that works. Thu Oct 8 22:17:01 1992 Aubrey Jaffer (jaffer at camelot) From: Robert Goldman * mitscheme.init: improvements. Sun Oct 4 11:37:57 1992 Aubrey Jaffer (jaffer at camelot) * values.scm values.doc: Documentation rewritten and combined into values.scm Thu Oct 1 23:29:43 1992 Aubrey Jaffer (jaffer at Ivan) * sc-macro.scm sc-macro.doc: documentation improved and moved into sc-macro.doc. Mon Sep 21 12:07:13 1992 Aubrey Jaffer (jaffer at Ivan) * sc-macro.scm (macro:load): now sets and restores *load-pathname*. * eval.scm (slib:eval!): (program-vicinity) now correct during evaluation. * Template.scm, *.init: i/o-redirection changed to with-file. *features* documentation changed. From: Stephen J Bevan * t3.init: new. Fixes problems with require, substring, and <,>,<=,>= with more than 2 arguments. Fri Sep 18 00:10:57 1992 Aubrey Jaffer (jaffer at Ivan) From andrew@astro.psu.edu Wed Sep 16 17:58:21 1992 * dynamic.scm: added. From raible@nas.nasa.gov Thu Sep 17 22:28:25 1992 * fluidlet.scm: added. Sun Sep 13 23:08:46 1992 Aubrey Jaffer (jaffer at Ivan) * sc-macro.scm (macro:repl): moved (require 'debug) into syntax-error. * dynwind.scm, withfile.scm, trnscrpt.scm: created. From kend@data.rain.com Sun Sep 13 21:26:59 1992 * collect.scm: created. * oop.scm => yasos.scm: updated. * oop.doc: removed. From: Stephen J. Bevan 19920912 * elk.init: created Tue Jul 14 11:42:57 1992 Aubrey Jaffer (jaffer at Ivan) * tek41.scm tek40.scm: added. Tue Jul 7 00:55:58 1992 Aubrey Jaffer (jaffer at Ivan) * record.scm record.doc (record-sub-predicate): added. * sc-macro.scm (macro:repl): syntax-errors now return into macro:repl. * debug.scm (qp): removed (newline). Added qpn (qp with newline). Sun Jun 14 22:57:32 1992 Aubrey Jaffer (jaffer at Ivan) * slib1b8 released. Sat Jun 13 17:01:41 1992 Aubrey Jaffer (jaffer at Ivan) * alist.scm ppfile.scm: added. * hash.scm hashtab.scm scheme48.init: added. * sc-macro.scm (macro:repl): created. macro:load now uses eval:eval!. * eval.scm (eval:eval!) created and eval done in terms of it. * prime.scm (prime:prime?) fixed misplaced parenthesis. Wed May 27 16:13:17 1992 Aubrey Jaffer (jaffer at Ivan) From: "Chris Hanson" * synrul.scm (generate-match): fixed for CASE syntax. Wed May 20 00:25:40 1992 Aubrey Jaffer (jaffer at Ivan) * slib1b6 released. * Template.scm gambit.init mitscheme.init scheme2c.init: rearranged *features*. Tue May 19 22:51:28 1992 Aubrey Jaffer (jaffer at Ivan) * scmactst.scm: test cases fixed. From: "Chris Hanson" * r4syn.scm (make-r4rs-primitive-macrology): TRANSFORMER added back in. * require.scm (load): load now passes through additional arguments to *old-load*. Mon May 18 00:59:36 1992 Aubrey Jaffer (jaffer at Ivan) * mulapply.scm (apply): written. * record.scm record.doc (make-record-sub-type): added. Fri May 8 17:55:14 1992 Aubrey Jaffer (jaffer at Ivan) * process.scm: created, but not finished. From: hugh@ear.mit.edu (Hugh Secker-Walker) * comlist.scm (nreverse make-list): non-recursive versions added. * sc2.scm (1+ -1+): versions which capture +. * mularg.scm (- /): created. Wed Apr 8 00:05:30 1992 Aubrey Jaffer (jaffer at Ivan) * require.scm sc-macro.scm (catalog): Now uses macro:load if 'macro is part of catalog entry. From: Andrew Wilcox (awilcox@astro.psu.edu) * queue.scm: created. Sun Mar 15 12:23:06 1992 Aubrey Jaffer (jaffer at Ivan) * comlist.scm (notevery): fixed. Now (not (every ..)). * eval.scm (eval:eval): renamed to slib:eval. * record.scm: replaced with version from From: david carlton . I changed updater => modifier, put record-predicate into the rtd, and bummed code mercilessly. From: plogan@std.mentor.com (Patrick Logan) * sc3.scm (last-pair): changed from testing null? to pair?. slib-3b1/chap.scm0000644001705200017500000001402307776076456011637 0ustar tbtb;;;; "chap.scm" Chapter ordering -*-scheme-*- ;;; Copyright 1992, 1993, 1994, 2003 Aubrey Jaffer ; ;Permission to copy this software, to modify it, to redistribute it, ;to distribute modified versions, and to use it for any purpose is ;granted, subject to the following restrictions and understandings. ; ;1. Any copy made of this software must include this copyright notice ;in full. ; ;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; ;3. In conjunction with products arising from the use of this ;material, there shall be no use of my name in any advertising, ;promotional, or sales literature without prior written consent in ;each case. ;;; The CHAP: functions deal with strings which are ordered like ;;; chapters in a book. For instance, a_9 < a_10 and 4c < 4aa. Each ;;; section of the string consists of consecutive numeric or ;;; consecutive aphabetic characters. (require 'rev4-optional-procedures) ; string-copy ;;@code{(require 'chapter-order)} ;;@ftindex chapter-order ;; ;;The @samp{chap:} functions deal with strings which are ordered like ;;chapter numbers (or letters) in a book. Each section of the string ;;consists of consecutive numeric or consecutive aphabetic characters of ;;like case. ;;@args string1 string2 ;;Returns #t if the first non-matching run of alphabetic upper-case or ;;the first non-matching run of alphabetic lower-case or the first ;;non-matching run of numeric characters of @var{string1} is ;;@code{string= i l1) (not (>= i l2))) ((>= i l2) #f) (else (let ((c1 (string-ref s1 i)) (c2 (string-ref s2 i))) (cond ((char=? c1 c2) (if (ctypep c1) (match-so-far (+ 1 i) ctypep) (delimited i))) ((ctypep c1) (if (ctypep c2) (length-race (+ 1 i) ctypep (char= i l1) (if (>= i l2) def #t)) ((>= i l2) #f) (else (let ((c1 (string-ref s1 i)) (c2 (string-ref s2 i))) (cond ((ctypep c1) (if (ctypep c2) (length-race (+ 1 i) ctypep def) #f)) ((ctypep c2) #t) (else def)))))) (define (ctype c1) (cond ((char-numeric? c1) char-numeric?) ((char-lower-case? c1) char-lower-case?) ((char-upper-case? c1) char-upper-case?) (else #f))) (define (delimited i) (cond ((>= i l1) (not (>= i l2))) ((>= i l2) #f) (else (let* ((c1 (string-ref s1 i)) (c2 (string-ref s2 i)) (ctype1 (ctype c1))) (cond ((char=? c1 c2) (if ctype1 (match-so-far (+ i 1) ctype1) (delimited (+ i 1)))) ((and ctype1 (eq? ctype1 (ctype c2))) (length-race (+ 1 i) ctype1 (char? string1 string2) (chap:string=? string1 string2) (not (chap:stringinteger #\2) (char->integer #\1))) (define (chap:inc-string s p) (let ((c (string-ref s p))) (cond ((char=? c #\z) (string-set! s p #\a) (cond ((zero? p) (string-append "a" s)) ((char-lower-case? (string-ref s (+ -1 p))) (chap:inc-string s (+ -1 p))) (else (string-append (substring s 0 p) "a" (substring s p (string-length s)))))) ((char=? c #\Z) (string-set! s p #\A) (cond ((zero? p) (string-append "A" s)) ((char-upper-case? (string-ref s (+ -1 p))) (chap:inc-string s (+ -1 p))) (else (string-append (substring s 0 p) "A" (substring s p (string-length s)))))) ((char=? c #\9) (string-set! s p #\0) (cond ((zero? p) (string-append "1" s)) ((char-numeric? (string-ref s (+ -1 p))) (chap:inc-string s (+ -1 p))) (else (string-append (substring s 0 p) "1" (substring s p (string-length s)))))) ((or (char-alphabetic? c) (char-numeric? c)) (string-set! s p (integer->char (+ chap:char-incr (char->integer (string-ref s p))))) s) (else (slib:error "inc-string error" s p))))) ;;@args string ;;Returns the next string in the @emph{chapter order}. If @var{string} ;;has no alphabetic or numeric characters, ;;@code{(string-append @var{string} "0")} is returnd. The argument to ;;chap:next-string will always be @code{chap:string (chap:string ; (display s1) ; (display " > ") ; (display s2) ; (newline))))) slib-3b1/chap.txi0000644001705200017500000000302310747237373011644 0ustar tbtb@code{(require 'chapter-order)} @ftindex chapter-order The @samp{chap:} functions deal with strings which are ordered like chapter numbers (or letters) in a book. Each section of the string consists of consecutive numeric or consecutive aphabetic characters of like case. @defun chap:string? string1 string2 @defunx chap:string<=? string1 string2 @defunx chap:string>=? string1 string2 Implement the corresponding chapter-order predicates. @end defun @defun chap:next-string string Returns the next string in the @emph{chapter order}. If @var{string} has no alphabetic or numeric characters, @code{(string-append @var{string} "0")} is returnd. The argument to chap:next-string will always be @code{chap:stringstring x mwid) (define str (sprintf #f "%g" x)) (if (> (string-length str) mwid) (substring str 0 mwid) str)) ;;;SCALE is a list of numerator and denominator. (define charplot:scale-it (if (provided? 'inexact) (lambda (z scale) (inexact->exact (round (/ (* z (car scale)) (cadr scale))))) (lambda (z scale) (quotient (+ (* z (car scale)) (quotient (cadr scale) 2)) (cadr scale))))) ;;; Given the width or height (in characters) and the data-span, ;;; returns a list of numerator and denominator (NUM DEN) suitable for ;;; passing as a second argument to CHARPLOT:SCALE-IT. ;;; ;;; NUM will be 1, 2, 3, 4, 5, 6, or 8 times a power of ten. ;;; DEN will be a power of ten. ;;; ;;; num isize ;;; === < ===== ;;; den delta (define (charplot:find-scale isize delta) (cond ((zero? delta) (set! delta 1)) ((inexact? delta) (set! isize (exact->inexact isize)))) (do ((d 1 (* d 10)) (isize isize (* isize 10))) ((<= delta isize) (do ((n 1 (* n 10)) (delta delta (* delta 10))) ((>= (* delta 10) isize) (list (* n (cond ((<= (* delta 8) isize) 8) ((<= (* delta 6) isize) 6) ((<= (* delta 5) isize) 5) ((<= (* delta 4) isize) 4) ((<= (* delta 3) isize) 3) ((<= (* delta 2) isize) 2) (else 1))) d)))))) (define (charplot:make-array) (let ((height (or (and charplot:dimensions (car charplot:dimensions)) (output-port-height (current-output-port)))) (width (or (and charplot:dimensions (cadr charplot:dimensions)) (output-port-width (current-output-port))))) (define pra (make-array " " height width)) ;;Put newlines on right edge (do ((idx (+ -1 height) (+ -1 idx))) ((negative? idx)) (array-set! pra #\newline idx (+ -1 width))) pra)) ;;;Creates and initializes character array with axes, scales, and ;;;labels. (define (charplot:init-array pra xlabel ylabel xmin xscale ymin yscale) (define plot-height (- (car (array-dimensions pra)) 3)) (define plot-width (- (cadr (array-dimensions pra)) charplot:left-margin 4)) (define xaxis (- (charplot:scale-it ymin yscale))) (define yaxis (- (charplot:scale-it xmin xscale))) (define xstep (if (zero? (modulo (car xscale) 3)) 12 10)) ;;CL is the left edge of WIDTH field (define (center-field str width ln cl) (define len (string-length str)) (if (< width len) (center-field (substring str 0 width) width ln cl) (do ((cnt (+ -1 len) (+ -1 cnt)) (adx (+ (quotient (- width len) 2) cl) (+ 1 adx)) (idx 0 (+ 1 idx))) ((negative? cnt)) (array-set! pra (string-ref str idx) ln adx)))) ;;x and y labels (center-field ylabel (+ charplot:left-margin -1) 0 0) (center-field xlabel (+ -1 charplot:left-margin) (+ 2 plot-height) 0) ;;horizontal borders, x-axis, and ticking (let ((xstep/2 (quotient (- xstep 2) 2))) (define faxis (modulo (+ charplot:left-margin yaxis) xstep)) (define faxis/2 (modulo (+ charplot:left-margin yaxis xstep/2 1) xstep)) (define xfudge (modulo yaxis xstep)) (do ((cl (+ charplot:left-margin -1) (+ 1 cl))) ((>= cl (+ plot-width charplot:left-margin))) (array-set! pra char:xborder 0 cl) (array-set! pra (cond ((eqv? faxis (modulo cl xstep)) char:yaxis) ((eqv? faxis/2 (modulo cl xstep)) char:xtick) (else char:xborder)) (+ 1 plot-height) cl) (if (<= 0 xaxis plot-height) (array-set! pra char:xaxis (- plot-height xaxis) cl))) ;;horizontal coordinates (do ((i xfudge (+ i xstep)) (cl (+ charplot:left-margin xfudge (- xstep/2)) (+ xstep cl))) ((> i plot-width)) (center-field (charplot:number->string (/ (* (- i yaxis) (cadr xscale)) (car xscale)) xstep) xstep (+ 2 plot-height) cl))) ;;vertical borders and y-axis (do ((ht plot-height (- ht 1))) ((negative? ht)) (array-set! pra char:yborder (+ 1 ht) (+ charplot:left-margin -2)) (array-set! pra char:yborder (+ 1 ht) (+ charplot:left-margin plot-width)) (if (< -1 yaxis plot-width) (array-set! pra char:yaxis (+ 1 ht) (+ charplot:left-margin yaxis)))) ;;vertical ticking and coordinates (do ((ht (- plot-height 1) (- ht 1)) (ln 1 (+ 1 ln))) ((negative? ht)) (let ((ystep (if (zero? (modulo (car yscale) 3)) 3 2))) (if (zero? (modulo (- ht xaxis) ystep)) (let* ((v (charplot:number->string (/ (* (- ht xaxis) (cadr yscale)) (car yscale)) (+ charplot:left-margin -2))) (len (string-length v))) (center-field v len ln (- charplot:left-margin 2 len)) ;Actually flush right (array-set! pra char:xaxis ln (+ charplot:left-margin -1)))))) ;;return initialized array pra) (define (charplot:array->list ra) (define dims (array-dimensions ra)) (if (= 2 (length dims)) (do ((idx (+ -1 (car dims)) (+ -1 idx)) (cols '() (cons (do ((jdx (+ -1 (cadr dims)) (+ -1 jdx)) (row '() (cons (array-ref ra idx jdx) row))) ((negative? jdx) row)) cols))) ((negative? idx) cols)) (do ((idx (+ -1 (car dims)) (+ -1 idx)) (cols '() (cons (array-ref ra idx) cols))) ((negative? idx) cols)))) ;;;Converts data to list of coordinates (list). (define (charplot:data->lists data) (cond ((array? data) (case (array-rank data) ((1) (set! data (map list (let ((ra (apply make-array '#() (array-dimensions data)))) (array-index-map! ra identity) (charplot:array->list ra)) (charplot:array->list data)))) ((2) (set! data (charplot:array->list data))))) ((and (pair? (car data)) (not (list? (car data)))) (set! data (map (lambda (lst) (list (car lst) (cdr lst))) data)))) (cond ((list? (cadar data)) (set! data (map (lambda (lst) (cons (car lst) (cadr lst))) data)))) data) ;;;An extremum is a list of the maximum and minimum values. ;;;COORDINATE-EXTREMA returns a rank-length list of these. (define (coordinate-extrema data) (define extrema (map (lambda (x) (list x x)) (car data))) (for-each (lambda (lst) (set! extrema (map (lambda (x max-min) (list (max x (car max-min)) (min x (cadr max-min)))) lst extrema))) data) extrema) ;;;Count occurrences of numbers within evenly spaced ranges; and return ;;;lists of coordinates for graph. (define (histobins data plot-width) (define datcnt (length data)) (define xmax (apply max data)) (define xmin (apply min data)) (if (null? data) '() (let* ((xscale (charplot:find-scale plot-width (- xmax xmin))) (actual-width (- (charplot:scale-it xmax xscale) (charplot:scale-it xmin xscale) -1))) (define ix-min (charplot:scale-it xmin xscale)) (define xinc (/ (- xmax xmin) actual-width)) (define bins (make-vector actual-width 0)) (for-each (lambda (x) (define idx (- (charplot:scale-it x xscale) ix-min)) (if (< -1 idx actual-width) (vector-set! bins idx (+ 1 (vector-ref bins idx))) (slib:error x (/ (* x (car xscale)) (cadr xscale)) (+ ix-min idx)))) data) (map list (do ((idx (+ -1 (vector-length bins)) (+ -1 idx)) (xvl xmax (- xvl xinc)) (lst '() (cons xvl lst))) ((negative? idx) lst)) (vector->list bins))))) ;;;@ Plot histogram of DATA. (define (histograph data label) (if (vector? data) (set! data (vector->list data))) (charplot:plot (histobins data (- (or (and charplot:dimensions (cadr charplot:dimensions)) (output-port-width (current-output-port))) charplot:left-margin 3)) label "" #t)) (define (charplot:plot data xlabel ylabel . histogram?) (define clen (string-length char:curves)) (set! histogram? (if (null? histogram?) #f (car histogram?))) (set! data (charplot:data->lists data)) (let* ((pra (charplot:make-array)) (plot-height (- (car (array-dimensions pra)) 3)) (plot-width (- (cadr (array-dimensions pra)) charplot:left-margin 4)) (extrema (coordinate-extrema data)) (xmax (caar extrema)) (xmin (cadar extrema)) (ymax (apply max (map car (cdr extrema)))) (ymin (apply min (map cadr (cdr extrema)))) (xscale (charplot:find-scale plot-width (- xmax xmin))) (yscale (charplot:find-scale plot-height (- ymax ymin))) (ix-min (- (charplot:scale-it xmin xscale) charplot:left-margin)) (ybot (charplot:scale-it ymin yscale)) (iy-min (+ ybot plot-height))) (charplot:init-array pra xlabel ylabel xmin xscale ymin yscale) (for-each (if histogram? ;;display data bars (lambda (datum) (define x (- (charplot:scale-it (car datum) xscale) ix-min)) (do ((y (charplot:scale-it (cadr datum) yscale) (+ -1 y))) ((< y ybot)) (array-set! pra char:bar (- iy-min y) x))) ;;display data points (lambda (datum) (define x (- (charplot:scale-it (car datum) xscale) ix-min)) (define cdx 0) (for-each (lambda (y) (array-set! pra (string-ref char:curves cdx) (- iy-min (charplot:scale-it y yscale)) x) (set! cdx (modulo (+ 1 cdx) clen))) (cdr datum)))) data) (array-for-each write-char pra) (if (not (eqv? #\newline (apply array-ref pra (map (lambda (x) (+ -1 x)) (array-dimensions pra))))) (newline)))) (define (charplot:plot-function func vlo vhi . npts) (set! npts (if (null? npts) 64 (car npts))) (let ((dats (make-array (A:floR64b) npts 2))) (array-index-map! (make-shared-array dats (lambda (idx) (list idx 0)) npts) (lambda (idx) (+ vlo (* (- vhi vlo) (/ idx (+ -1 npts)))))) (array-map! (make-shared-array dats (lambda (idx) (list idx 1)) npts) func (make-shared-array dats (lambda (idx) (list idx 0)) npts)) (charplot:plot dats "" ""))) ;@ (define (plot . args) (if (procedure? (car args)) (apply charplot:plot-function args) (apply charplot:plot args))) slib-3b1/chez.init0000644001705200017500000003620410733633204012014 0ustar tbtb;;;"chez.init" Initialization file for SLIB for Chez Scheme 6.0a -*-scheme-*- ;;; Authors: dorai@cs.rice.edu (Dorai Sitaram) and Aubrey Jaffer. ;;; ;;; This code is in the public domain. ;;; Adapted to version 5.0c by stone@math.grin.edu (John David Stone) 1997 ;;; Adapted to version 6.0a by Gary T. Leavens , 1999 ;;; (software-type) should be set to the generic operating system type. ;;; UNIX, VMS, MACOS, AMIGA and MS-DOS are supported. (define (software-type) 'unix) ;;; (scheme-implementation-type) should return the name of the scheme ;;; implementation loading this file. (define (scheme-implementation-type) 'chez) ;;; (scheme-implementation-home-page) should return a (string) URI ;;; (Uniform Resource Identifier) for this scheme implementation's home ;;; page; or false if there isn't one. (define (scheme-implementation-home-page) "http://www.scheme.com/") ;;; (scheme-implementation-version) should return a string describing ;;; the version the scheme implementation loading this file. (define (scheme-implementation-version) "6.0a") ;;; (implementation-vicinity) should be defined to be the pathname of ;;; the directory where any auxillary files to your Scheme ;;; implementation reside. (define implementation-vicinity (let ((impl-path (or (getenv "CHEZ_IMPLEMENTATION_PATH") "/usr/unsup/scheme/chez/"))) (lambda () impl-path))) ;;; (library-vicinity) should be defined to be the pathname of the ;;; directory where files of Scheme library functions reside. (define library-vicinity (let ((library-path (or ;; Use this getenv if your implementation supports it. (getenv "SCHEME_LIBRARY_PATH") ;; Use this path if your scheme does not support GETENV ;; or if SCHEME_LIBRARY_PATH is not set. (case (software-type) ((unix) "/usr/local/lib/slib/") ((vms) "lib$scheme:") ((ms-dos) "C:\\SLIB\\") (else ""))))) (lambda () library-path))) ;;; (home-vicinity) should return the vicinity of the user's HOME ;;; directory, the directory which typically contains files which ;;; customize a computer environment for a user. (define (home-vicinity) (let ((home (getenv "HOME"))) (and home (case (software-type) ((unix coherent ms-dos) ;V7 unix has a / on HOME (if (eqv? #\/ (string-ref home (+ -1 (string-length home)))) home (string-append home "/"))) (else home))))) ;@ (define in-vicinity string-append) ;@ (define (user-vicinity) (case (software-type) ((vms) "[.]") (else ""))) (define *load-pathname* #f) ;@ (define vicinity:suffix? (let ((suffi (case (software-type) ((amiga) '(#\: #\/)) ((macos thinkc) '(#\:)) ((ms-dos windows atarist os/2) '(#\\ #\/)) ((nosve) '(#\: #\.)) ((unix coherent plan9) '(#\/)) ((vms) '(#\: #\])) (else (slib:warn "require.scm" 'unknown 'software-type (software-type)) "/")))) (lambda (chr) (and (memv chr suffi) #t)))) ;@ (define (pathname->vicinity pathname) (let loop ((i (- (string-length pathname) 1))) (cond ((negative? i) "") ((vicinity:suffix? (string-ref pathname i)) (substring pathname 0 (+ i 1))) (else (loop (- i 1)))))) (define (program-vicinity) (if *load-pathname* (pathname->vicinity *load-pathname*) (slib:error 'program-vicinity " called; use slib:load to load"))) ;@ (define sub-vicinity (case (software-type) ((vms) (lambda (vic name) (let ((l (string-length vic))) (if (or (zero? (string-length vic)) (not (char=? #\] (string-ref vic (- l 1))))) (string-append vic "[" name "]") (string-append (substring vic 0 (- l 1)) "." name "]"))))) (else (let ((*vicinity-suffix* (case (software-type) ((nosve) ".") ((macos thinkc) ":") ((ms-dos windows atarist os/2) "\\") ((unix coherent plan9 amiga) "/")))) (lambda (vic name) (string-append vic name *vicinity-suffix*)))))) ;@ (define (make-vicinity ) ) ;@ (define with-load-pathname (let ((exchange (lambda (new) (let ((old *load-pathname*)) (set! *load-pathname* new) old)))) (lambda (path thunk) (let ((old #f)) (dynamic-wind (lambda () (set! old (exchange path))) thunk (lambda () (exchange old))))))) ;;@ SLIB:FEATURES is a list of symbols naming the (SLIB) features ;;; initially supported by this implementation. (define slib:features '( source ;can load scheme source files ;(SLIB:LOAD-SOURCE "filename") compiled ;can load compiled files ;(SLIB:LOAD-COMPILED "filename") vicinity srfi-59 srfi-96 ;; Scheme report features ;; R5RS-compliant implementations should provide all 9 features. r5rs ;conforms to eval ;R5RS two-argument eval values ;R5RS multiple values dynamic-wind ;R5RS dynamic-wind macro ;R5RS high level macros delay ;has DELAY and FORCE multiarg-apply ;APPLY can take more than 2 args. char-ready? rev4-optional-procedures ;LIST-TAIL, STRING-COPY, ;STRING-FILL!, and VECTOR-FILL! ;; These four features are optional in both R4RS and R5RS multiarg/and- ;/ and - can take more than 2 args. rationalize transcript ;TRANSCRIPT-ON and TRANSCRIPT-OFF with-file ;has WITH-INPUT-FROM-FILE and ;WITH-OUTPUT-TO-FILE r4rs ;conforms to ieee-p1178 ;conforms to r3rs ;conforms to ;;; rev2-procedures ;SUBSTRING-MOVE-LEFT!, ;SUBSTRING-MOVE-RIGHT!, ;SUBSTRING-FILL!, ;STRING-NULL?, APPEND!, 1+, ;-1+, ?, >=? ;;; object-hash ;has OBJECT-HASH full-continuation ;can return multiple times ;;; ieee-floating-point ;conforms to IEEE Standard 754-1985 ;IEEE Standard for Binary ;Floating-Point Arithmetic. ;; Other common features ;;; srfi-0 ;srfi-0, COND-EXPAND finds all srfi-* ;;; sicp ;runs code from Structure and ;Interpretation of Computer ;Programs by Abelson and Sussman. defmacro ;has Common Lisp DEFMACRO record ;has user defined data structures string-port ;has CALL-WITH-INPUT-STRING and ;CALL-WITH-OUTPUT-STRING sort pretty-print ;;; object->string format ;Common-lisp output formatting trace ;has macros: TRACE and UNTRACE ;;; compiler ;has (COMPILER) ;;; ed ;(ED) is editor system ;posix (system ) getenv ;posix (getenv ) ;;; program-arguments ;returns list of strings (argv) ;;; current-time ;returns time in seconds since 1/1/1970 ;; Implementation Specific features ;;; random ;Not the same as SLIB random fluid-let )) ;;; (OUTPUT-PORT-WIDTH ) returns the number of graphic characters ;;; that can reliably be displayed on one line of the standard output port. (define output-port-width (lambda arg (let ((env-width-string (getenv "COLUMNS"))) (if (and env-width-string (let loop ((remaining (string-length env-width-string))) (or (zero? remaining) (let ((next (- remaining 1))) (and (char-numeric? (string-ref env-width-string next)) (loop next)))))) (- (string->number env-width-string) 1) 79)))) ;;; (OUTPUT-PORT-HEIGHT ) returns the number of lines of text that ;;; can reliably be displayed simultaneously in the standard output port. (define output-port-height (lambda arg (let ((env-height-string (getenv "LINES"))) (if (and env-height-string (let loop ((remaining (string-length env-height-string))) (or (zero? remaining) (let ((next (- remaining 1))) (and (char-numeric? (string-ref env-height-string next)) (loop next)))))) (string->number env-height-string) 24)))) ;;; (CURRENT-ERROR-PORT) (define current-error-port (let ((port (console-output-port))) ; changed from current-output-port (lambda () port))) ;;; (TMPNAM) makes a temporary file name. (define tmpnam (let ((cntr 100)) (lambda () (set! cntr (+ 1 cntr)) (let ((tmp (string-append "slib_" (number->string cntr)))) (if (file-exists? tmp) (tmpnam) tmp))))) ;;; (FILE-EXISTS? ) is built-in to Chez Scheme ;;; (DELETE-FILE ) is built-in to Chez Scheme ;; The FORCE-OUTPUT requires buffered output that has been written to a ;; port to be transferred all the way out to its ultimate destination. (define force-output flush-output-port) (define (make-exchanger obj) (lambda (rep) (let ((old obj)) (set! obj rep) old))) (define (open-file filename modes) (case modes ((r rb) (open-input-file filename)) ((w wb) (open-output-file filename)) (else (slib:error 'open-file 'mode? modes)))) (define (port? obj) (or (input-port? port) (output-port? port))) (define (call-with-open-ports . ports) (define proc (car ports)) (cond ((procedure? proc) (set! ports (cdr ports))) (else (set! ports (reverse ports)) (set! proc (car ports)) (set! ports (reverse (cdr ports))))) (let ((ans (apply proc ports))) (for-each close-port ports) ans)) (define (close-port port) (cond ((input-port? port) (close-input-port port) (if (output-port? port) (close-output-port port))) ((output-port? port) (close-output-port port)) (else (slib:error 'close-port 'port? port)))) (define (browse-url url) (define (try cmd end) (zero? (system (string-append cmd url end)))) (or (try "netscape-remote -remote 'openURL(" ")'") (try "netscape -remote 'openURL(" ")'") (try "netscape '" "'&") (try "netscape '" "'"))) ;;; "rationalize" adjunct procedures. (define (find-ratio x e) (let ((rat (rationalize x e))) (list (numerator rat) (denominator rat)))) (define (find-ratio-between x y) (find-ratio (/ (+ x y) 2) (/ (- x y) 2))) ;;; CHAR-CODE-LIMIT is one greater than the largest integer which can ;;; be returned by CHAR->INTEGER. (define char-code-limit 256) ;;; MOST-POSITIVE-FIXNUM is used in modular.scm ;; Chez's MOST-POSITIVE-FIXNUM is a thunk rather than a number. (if (procedure? most-positive-fixnum) (set! most-positive-fixnum (most-positive-fixnum))) ;;; Return argument (define (identity x) x) ;;; SLIB:EVAL is single argument eval using the top-level (user) environment. (define slib:eval eval) ;;; define an error procedure for the library (define slib:error (let ((error error)) (lambda args (let ((cep (current-error-port))) (if (provided? 'trace) (print-call-stack cep)) (display "Error: " cep) (for-each (lambda (x) (display #\space cep) (write x cep)) args) (error #f ""))))) ;;; define these as appropriate for your system. (define slib:tab #\tab) (define slib:form-feed #\page) ;;; Support for older versions of Scheme. Not enough code for its own file. ;;; last-pair is built-in to Chez Scheme (define t #t) (define nil #f) ;;; Define these if your implementation's syntax can support it and if ;;; they are not already defined. ;;; 1+, -1+, and 1- are built-in to Chez Scheme ;(define (1+ n) (+ n 1)) ;(define (-1+ n) (+ n -1)) ;(define 1- -1+) ;;; Define SLIB:EXIT to be the implementation procedure to exit or ;;; return if exiting not supported. (define slib:chez:quit (let ((arg (call-with-current-continuation identity))) (cond ((procedure? arg) arg) (arg (exit)) (else (exit 1))))) (define slib:exit (lambda args (cond ((null? args) (slib:chez:quit #t)) ((eqv? #t (car args)) (slib:chez:quit #t)) ((eqv? #f (car args)) (slib:chez:quit #f)) ((zero? (car args)) (slib:chez:quit #t)) (else (slib:chez:quit #f))))) ;;; For backward compatability, the SCHEME-FILE-SUFFIX procedure is defined ;;; to return the string ".scm". Note, however, that ".ss" is a common Chez ;;; file suffix. (define scheme-file-suffix (let ((suffix (case (software-type) ((nosve) "_scm") (else ".scm")))) (lambda () suffix))) ;;; (SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever ;;; suffix all the module files in SLIB have. See feature 'SOURCE. (define (slib:load-source f) (load (string-append f ".scm"))) ;;; (SLIB:LOAD-COMPILED "foo") should load the file that was produced ;;; by compiling "foo.scm" if this implementation can compile files. ;;; See feature 'COMPILED. (define slib:load-compiled load) ;;; At this point SLIB:LOAD must be able to load SLIB files. (define slib:load slib:load-source) ;;; If your implementation provides R4RS macros: (define macro:eval slib:eval) ;;; macro:load also needs the default suffix. (define macro:load slib:load-source) ;;; If your implementation provides syntax-case macros: ;;(define syncase:eval slib:eval) ;;(define syncase:load slib:load-source) ;;; The following make procedures in Chez Scheme compatible with ;;; the assumptions of SLIB. ;;; Chez's sorting routines take parameters in the order opposite to SLIB's. ;;; The following definitions override the predefined procedures with the ;;; parameters-reversed versions. See the SORT feature. (define chez:sort sort) (define chez:sort! sort!) (define chez:merge merge) (define chez:merge! merge!) (define sort (lambda (s p) (chez:sort p s))) (define sort! (lambda (s p) (chez:sort! p s))) (define merge (lambda (s1 s2 p) (chez:merge p s1 s2))) (define merge! (lambda (s1 s2 p) (chez:merge! p s1 s2))) ;;; Chez's (FORMAT F . A) corresponds to SLIB's (FORMAT #F F . A) ;;; See the FORMAT feature. (define chez:format format) (define format (lambda (where how . args) (let ((str (apply chez:format how args))) (cond ((not where) str) ((eq? where #t) (display str)) (else (display str where)))))) ;; The following definitions implement a few widely useful procedures that ;; Chez Scheme does not provide or provides under a different name. ;;; CALL-WITH-INPUT-STRING and CALL-WITH-OUTPUT-STRING are the string ;;; port versions of CALL-WITH-INPUT-FILE and CALL-WITH-OUTPUT-FILE. ;;; See the STRING-PORT feature. (define call-with-output-string (lambda (f) (let ((outsp (open-output-string))) (f outsp) (let ((s (get-output-string outsp))) (close-output-port outsp) s)))) (define call-with-input-string (lambda (s f) (let* ((insp (open-input-string s)) (res (f insp))) (close-input-port insp) res))) (define *defmacros* (list (cons 'defmacro (lambda (name parms . body) `(set! *defmacros* (cons (cons ',name (lambda ,parms ,@body)) *defmacros*)))))) (define (defmacro? m) (and (assq m *defmacros*) #t)) (define (macroexpand-1 e) (if (pair? e) (let ((a (car e))) (cond ((symbol? a) (set! a (assq a *defmacros*)) (if a (apply (cdr a) (cdr e)) e)) (else e))) e)) (define (macroexpand e) (if (pair? e) (let ((a (car e))) (cond ((symbol? a) (set! a (assq a *defmacros*)) (if a (macroexpand (apply (cdr a) (cdr e))) e)) (else e))) e)) ;;; According to Kent Dybvig, you can improve the Chez Scheme init ;;; file by defining gentemp to be gensym in Chez Scheme. (define gentemp gensym) (define base:eval slib:eval) (define (defmacro:eval x) (base:eval (defmacro:expand* x))) (define (defmacro:expand* x) (require 'defmacroexpand) (apply defmacro:expand* x '())) (define (defmacro:load ) (slib:eval-load defmacro:eval)) (define slib:warn (lambda args (let ((cep (current-error-port))) (if (provided? 'trace) (print-call-stack cep)) (display "Warn: " cep) (for-each (lambda (x) (display #\space cep) (write x cep)) args)))) ;;; Load the REQUIRE package. (slib:load (in-vicinity (library-vicinity) "require")) ;; end of chez.init slib-3b1/cie1931.xyz0000644001705200017500000000405007361224602012023 0ustar tbtb;;; "cie1931.xyz" CIE XYZ(1931) Spectra from 380.nm to 780.nm. 380 0.0014 0.0000 0.0065 385 0.0022 0.0001 0.0105 390 0.0042 0.0001 0.0201 395 0.0076 0.0002 0.0362 400 0.0143 0.0004 0.0679 405 0.0232 0.0006 0.1102 410 0.0435 0.0012 0.2074 415 0.0776 0.0022 0.3713 420 0.1344 0.0040 0.6456 425 0.2148 0.0073 1.0391 430 0.2839 0.0116 1.3856 435 0.3285 0.0168 1.6230 440 0.3483 0.0230 1.7471 445 0.3481 0.0298 1.7826 450 0.3362 0.0380 1.7721 455 0.3187 0.0480 1.7441 460 0.2908 0.0600 1.6692 465 0.2511 0.0739 1.5281 470 0.1954 0.0910 1.2876 475 0.1421 0.1126 1.0419 480 0.0956 0.1390 0.8130 485 0.0580 0.1693 0.6162 490 0.0320 0.2080 0.4652 495 0.0147 0.2586 0.3533 500 0.0049 0.3230 0.2720 505 0.0024 0.4073 0.2123 510 0.0093 0.5030 0.1582 515 0.0291 0.6082 0.1117 520 0.0633 0.7100 0.0782 525 0.1096 0.7932 0.0573 530 0.1655 0.8620 0.0422 535 0.2257 0.9149 0.0298 540 0.2904 0.9540 0.0203 545 0.3597 0.9803 0.0134 550 0.4334 0.9950 0.0087 555 0.5121 1.0000 0.0057 560 0.5945 0.9950 0.0039 565 0.6784 0.9786 0.0027 570 0.7621 0.9520 0.0021 575 0.8425 0.9154 0.0018 580 0.9163 0.8700 0.0017 585 0.9786 0.8163 0.0014 590 1.0263 0.7570 0.0011 595 1.0567 0.6949 0.0010 600 1.0622 0.6310 0.0008 605 1.0456 0.5668 0.0006 610 1.0026 0.5030 0.0003 615 0.9384 0.4412 0.0002 620 0.8544 0.3810 0.0002 625 0.7514 0.3210 0.0001 630 0.6424 0.2650 0.0000 635 0.5419 0.2170 0.0000 640 0.4479 0.1750 0.0000 645 0.3608 0.1382 0.0000 650 0.2835 0.1070 0.0000 655 0.2187 0.0816 0.0000 660 0.1649 0.0610 0.0000 665 0.1212 0.0446 0.0000 670 0.0874 0.0320 0.0000 675 0.0636 0.0232 0.0000 680 0.0468 0.0170 0.0000 685 0.0329 0.0119 0.0000 690 0.0227 0.0082 0.0000 695 0.0158 0.0057 0.0000 700 0.0114 0.0041 0.0000 705 0.0081 0.0029 0.0000 710 0.0058 0.0021 0.0000 715 0.0041 0.0015 0.0000 720 0.0029 0.0010 0.0000 725 0.0020 0.0007 0.0000 730 0.0014 0.0005 0.0000 735 0.0010 0.0004 0.0000 740 0.0007 0.0002 0.0000 745 0.0005 0.0002 0.0000 750 0.0003 0.0001 0.0000 755 0.0002 0.0001 0.0000 760 0.0002 0.0001 0.0000 765 0.0001 0.0000 0.0000 770 0.0001 0.0000 0.0000 775 0.0001 0.0000 0.0000 780 0.0000 0.0000 0.0000 slib-3b1/cie1964.xyz0000644001705200017500000000405007415472721012040 0ustar tbtb;;; "cie1964.xyz" CIE XYZ(1964) Spectra from 380.nm to 780.nm. 380 0.0002 0.0000 0.0007 385 0.0007 0.0001 0.0029 390 0.0024 0.0003 0.0105 395 0.0072 0.0008 0.0323 400 0.0191 0.0020 0.0860 405 0.0434 0.0045 0.1971 410 0.0847 0.0088 0.3894 415 0.1406 0.0145 0.6568 420 0.2045 0.0214 0.9725 425 0.2647 0.0295 1.2825 430 0.3147 0.0387 1.5535 435 0.3577 0.0496 1.7985 440 0.3837 0.0621 1.9673 445 0.3867 0.0747 2.0273 450 0.3707 0.0895 1.9948 455 0.3430 0.1063 1.9007 460 0.3023 0.1282 1.7454 465 0.2541 0.1528 1.5549 470 0.1956 0.1852 1.3176 475 0.1323 0.2199 1.0302 480 0.0805 0.2536 0.7721 485 0.0411 0.2977 0.5701 490 0.0162 0.3391 0.4153 495 0.0051 0.3954 0.3024 500 0.0038 0.4608 0.2185 505 0.0154 0.5314 0.1592 510 0.0375 0.6067 0.1120 515 0.0714 0.6857 0.0822 520 0.1177 0.7618 0.0607 525 0.1730 0.8233 0.0431 530 0.2365 0.8752 0.0305 535 0.3042 0.9238 0.0206 540 0.3768 0.9620 0.0137 545 0.4516 0.9822 0.0079 550 0.5298 0.9918 0.0040 555 0.6161 0.9991 0.0011 560 0.7052 0.9973 0.0000 565 0.7938 0.9824 0.0000 570 0.8787 0.9556 0.0000 575 0.9512 0.9152 0.0000 580 1.0142 0.8689 0.0000 585 1.0743 0.8256 0.0000 590 1.1185 0.7774 0.0000 595 1.1343 0.7204 0.0000 600 1.1240 0.6583 0.0000 605 1.0891 0.5939 0.0000 610 1.0305 0.5280 0.0000 615 0.9507 0.4618 0.0000 620 0.8563 0.3981 0.0000 625 0.7549 0.3396 0.0000 630 0.6475 0.2835 0.0000 635 0.5351 0.2283 0.0000 640 0.4316 0.1798 0.0000 645 0.3437 0.1402 0.0000 650 0.2683 0.1076 0.0000 655 0.2043 0.0812 0.0000 660 0.1526 0.0603 0.0000 665 0.1122 0.0441 0.0000 670 0.0813 0.0318 0.0000 675 0.0579 0.0226 0.0000 680 0.0409 0.0159 0.0000 685 0.0286 0.0111 0.0000 690 0.0199 0.0077 0.0000 695 0.0138 0.0054 0.0000 700 0.0096 0.0037 0.0000 705 0.0066 0.0026 0.0000 710 0.0046 0.0018 0.0000 715 0.0031 0.0012 0.0000 720 0.0022 0.0008 0.0000 725 0.0015 0.0006 0.0000 730 0.0010 0.0004 0.0000 735 0.0007 0.0003 0.0000 740 0.0005 0.0002 0.0000 745 0.0004 0.0001 0.0000 750 0.0003 0.0001 0.0000 755 0.0002 0.0001 0.0000 760 0.0001 0.0000 0.0000 765 0.0001 0.0000 0.0000 770 0.0001 0.0000 0.0000 775 0.0000 0.0000 0.0000 780 0.0000 0.0000 0.0000 slib-3b1/ciesia.dat0000644001705200017500000000234110130111752012106 0ustar tbtb;;; CIE 15.2-1986 Table 1.1 ;;; Part 1: CIE Standard Illuminant A relative spectral power distribution ;;; 300 nm - 830 nm at 5 nm intervals 0.930483 1.128210 1.357690 1.622190 1.925080 2.269800 2.659810 3.098610 3.589680 4.136480 4.742380 5.410700 6.144620 6.947200 7.821350 8.769800 9.795100 10.899600 12.085300 13.354300 14.708000 16.148000 17.675300 19.290700 20.995000 22.788300 24.670900 26.642500 28.702700 30.850800 33.085900 35.406800 37.812100 40.300200 42.869300 45.517400 48.242300 51.041800 53.913200 56.853900 59.861100 62.932000 66.063500 69.252500 72.495900 75.790300 79.132600 82.519300 85.947000 89.412400 92.912000 96.442300 100.000000 103.582000 107.184000 110.803000 114.436000 118.080000 121.731000 125.386000 129.043000 132.697000 136.346000 139.988000 143.618000 147.235000 150.836000 154.418000 157.979000 161.516000 165.028000 168.510000 171.963000 175.383000 178.769000 182.118000 185.429000 188.701000 191.931000 195.118000 198.261000 201.359000 204.409000 207.411000 210.365000 213.268000 216.120000 218.920000 221.667000 224.361000 227.000000 229.585000 232.115000 234.589000 237.008000 239.370000 241.675000 243.924000 246.116000 248.251000 250.329000 252.350000 254.314000 256.221000 258.071000 259.865000 261.602000 slib-3b1/ciesid65.dat0000644001705200017500000000215010130111775012267 0ustar tbtb;;; CIE 15.2-1986 Table 1.1 ;;; Part 2: CIE Standard Illuminant D65 relative spectral power distribution ;;; 300 nm - 830 nm at 5 nm intervals 0.03410 1.66430 3.29450 11.76520 20.23600 28.64470 37.05350 38.50110 39.94880 42.43020 44.91170 45.77500 46.63830 49.36370 52.08910 51.03230 49.97550 52.31180 54.64820 68.70150 82.75490 87.12040 91.48600 92.45890 93.43180 90.05700 86.68230 95.77360 104.86500 110.93600 117.00800 117.41000 117.81200 116.33600 114.86100 115.39200 115.92300 112.36700 108.81100 109.08200 109.35400 108.57800 107.80200 106.29600 104.79000 106.23900 107.68900 106.04700 104.40500 104.22500 104.04600 102.02300 100.00000 98.16710 96.33420 96.06110 95.78800 92.23680 88.68560 89.34590 90.00620 89.80260 89.59910 88.64890 87.69870 85.49360 83.28860 83.49390 83.69920 81.86300 80.02680 80.12070 80.21460 81.24620 82.27780 80.28100 78.28420 74.00270 69.72130 70.66520 71.60910 72.97900 74.34900 67.97650 61.60400 65.74480 69.88560 72.48630 75.08700 69.33980 63.59270 55.00540 46.41820 56.61180 66.80540 65.09410 63.38280 63.84340 64.30400 61.87790 59.45190 55.70540 51.95900 54.69980 57.44060 58.87650 60.31250 slib-3b1/clrnamdb.scm0000644001705200017500000017776410734523455012514 0ustar tbtb;;; "/usr/local/lib/slib/clrnamdb.scm" SLIB 3a5 alist-table database -*-scheme-*- ( (10 ("black" "sRGB:34/34/34" 267) ("darkgray" "sRGB:85/85/85" 266) ("mediumgray" "sRGB:132/132/130" 265) ("lightgray" "sRGB:185/184/181" 264) ("white" "sRGB:242/243/244" 263) ("grayishpurplishred" "sRGB:145/95/109" 262) ("lightgrayishpurplishred" "sRGB:175/134/142" 261) ("verydarkpurplishred" "sRGB:56/21/44" 260) ("darkpurplishred" "sRGB:103/49/71" 259) ("moderatepurplishred" "sRGB:168/81/110" 258) ("verydeeppurplishred" "sRGB:84/19/59" 257) ("deeppurplishred" "sRGB:120/24/74" 256) ("strongpurplishred" "sRGB:179/68/108" 255) ("vividpurplishred" "sRGB:206/70/118" 254) ("grayishpurplishpink" "sRGB:195/166/177" 253) ("palepurplishpink" "sRGB:232/204/215" 252) ("darkpurplishpink" "sRGB:193/126/145" 251) ("moderatepurplishpink" "sRGB:213/151/174" 250) ("lightpurplishpink" "sRGB:239/187/204" 249) ("deeppurplishpink" "sRGB:222/111/161" 248) ("strongpurplishpink" "sRGB:230/143/172" 247) ("brilliantpurplishpink" "sRGB:255/200/214" 246) ("grayishreddishpurple" "sRGB:131/100/121" 245) ("palereddishpurple" "sRGB:170/138/158" 244) ("verydarkreddishpurple" "sRGB:52/23/49" 243) ("darkreddishpurple" "sRGB:93/57/84" 242) ("moderatereddishpurple" "sRGB:145/92/131" 241) ("lightreddishpurple" "sRGB:183/132/167" 240) ("verydeepreddishpurple" "sRGB:84/25/78" 239) ("deepreddishpurple" "sRGB:112/41/99" 238) ("strongreddishpurple" "sRGB:158/79/136" 237) ("vividreddishpurple" "sRGB:135/0/116" 236) ("purplishblack" "sRGB:36/33/36" 235) ("darkpurplishgray" "sRGB:93/85/91" 234) ("purplishgray" "sRGB:139/133/137" 233) ("lightpurplishgray" "sRGB:191/185/189" 232) ("purplishwhite" "sRGB:232/227/229" 231) ("blackishpurple" "sRGB:41/30/41" 230) ("darkgrayishpurple" "sRGB:80/64/77" 229) ("grayishpurple" "sRGB:121/104/120" 228) ("palepurple" "sRGB:170/152/169" 227) ("verypalepurple" "sRGB:214/202/221" 226) ("verydarkpurple" "sRGB:48/25/52" 225) ("darkpurple" "sRGB:86/60/92" 224) ("moderatepurple" "sRGB:134/96/142" 223) ("lightpurple" "sRGB:182/149/192" 222) ("verylightpurple" "sRGB:213/186/219" 221) ("verydeeppurple" "sRGB:64/26/76" 220) ("deeppurple" "sRGB:96/47/107" 219) ("strongpurple" "sRGB:135/86/146" 218) ("brilliantpurple" "sRGB:211/153/230" 217) ("vividpurple" "sRGB:154/78/174" 216) ("grayishviolet" "sRGB:85/76/105" 215) ("paleviolet" "sRGB:150/144/171" 214) ("verypaleviolet" "sRGB:196/195/221" 213) ("darkviolet" "sRGB:47/33/64" 212) ("moderateviolet" "sRGB:96/78/129" 211) ("lightviolet" "sRGB:140/130/182" 210) ("verylightviolet" "sRGB:220/208/255" 209) ("deepviolet" "sRGB:50/23/77" 208) ("strongviolet" "sRGB:96/78/151" 207) ("brilliantviolet" "sRGB:126/115/184" 206) ("vividviolet" "sRGB:144/101/202" 205) ("grayishpurplishblue" "sRGB:76/81/109" 204) ("palepurplishblue" "sRGB:140/146/172" 203) ("verypalepurplishblue" "sRGB:192/200/225" 202) ("darkpurplishblue" "sRGB:37/36/64" 201) ("moderatepurplishblue" "sRGB:78/81/128" 200) ("lightpurplishblue" "sRGB:135/145/191" 199) ("verylightpurplishblue" "sRGB:179/188/226" 198) ("deeppurplishblue" "sRGB:39/36/88" 197) ("strongpurplishblue" "sRGB:84/90/167" 196) ("brilliantpurplishblue" "sRGB:108/121/184" 195) ("vividpurplishblue" "sRGB:48/38/122" 194) ("bluishblack" "sRGB:32/36/40" 193) ("darkbluishgray" "sRGB:81/88/94" 192) ("bluishgray" "sRGB:129/135/139" 191) ("lightbluishgray" "sRGB:180/188/192" 190) ("bluishwhite" "sRGB:233/233/237" 189) ("blackishblue" "sRGB:32/40/48" 188) ("darkgrayishblue" "sRGB:54/69/79" 187) ("grayishblue" "sRGB:83/104/120" 186) ("paleblue" "sRGB:145/163/176" 185) ("verypaleblue" "sRGB:188/212/230" 184) ("darkblue" "sRGB:0/48/78" 183) ("moderateblue" "sRGB:67/107/149" 182) ("lightblue" "sRGB:112/163/204" 181) ("verylightblue" "sRGB:161/202/241" 180) ("deepblue" "sRGB:0/65/106" 179) ("strongblue" "sRGB:0/103/165" 178) ("brilliantblue" "sRGB:73/151/208" 177) ("vividblue" "sRGB:0/161/194" 176) ("verydarkgreenishblue" "sRGB:0/46/59" 175) ("darkgreenishblue" "sRGB:0/73/88" 174) ("moderategreenishblue" "sRGB:54/117/136" 173) ("lightgreenishblue" "sRGB:102/170/188" 172) ("verylightgreenishblue" "sRGB:156/209/220" 171) ("deepgreenishblue" "sRGB:46/132/149" 170) ("stronggreenishblue" "sRGB:0/119/145" 169) ("brilliantgreenishblue" "sRGB:35/158/186" 168) ("vividgreenishblue" "sRGB:0/133/161" 167) ("verydarkbluishgreen" "sRGB:0/42/41" 166) ("darkbluishgreen" "sRGB:0/75/73" 165) ("moderatebluishgreen" "sRGB:49/120/115" 164) ("lightbluishgreen" "sRGB:102/173/164" 163) ("verylightbluishgreen" "sRGB:150/222/209" 162) ("deepbluishgreen" "sRGB:0/68/63" 161) ("strongbluishgreen" "sRGB:0/122/116" 160) ("brilliantbluishgreen" "sRGB:0/166/147" 159) ("vividbluishgreen" "sRGB:0/136/130" 158) ("greenishblack" "sRGB:30/35/33" 157) ("darkgreenishgray" "sRGB:78/87/85" 156) ("greenishgray" "sRGB:125/137/132" 155) ("lightgreenishgray" "sRGB:178/190/181" 154) ("greenishwhite" "sRGB:223/237/232" 153) ("blackishgreen" "sRGB:26/36/33" 152) ("darkgrayishgreen" "sRGB:58/75/71" 151) ("grayishgreen" "sRGB:94/113/106" 150) ("palegreen" "sRGB:141/163/153" 149) ("verypalegreen" "sRGB:199/230/215" 148) ("verydarkgreen" "sRGB:28/53/45" 147) ("darkgreen" "sRGB:27/77/62" 146) ("moderategreen" "sRGB:59/120/97" 145) ("lightgreen" "sRGB:106/171/142" 144) ("verylightgreen" "sRGB:142/209/178" 143) ("deepgreen" "sRGB:0/84/61" 142) ("stronggreen" "sRGB:0/121/89" 141) ("brilliantgreen" "sRGB:62/180/137" 140) ("vividgreen" "sRGB:0/136/86" 139) ("verydarkyellowishgreen" "sRGB:23/54/32" 138) ("darkyellowishgreen" "sRGB:53/94/59" 137) ("moderateyellowishgreen" "sRGB:103/146/103" 136) ("lightyellowishgreen" "sRGB:147/197/146" 135) ("verylightyellowishgreen" "sRGB:182/229/175" 134) ("verydeepyellowishgreen" "sRGB:0/49/24" 133) ("deepyellowishgreen" "sRGB:0/98/45" 132) ("strongyellowishgreen" "sRGB:68/148/74" 131) ("brilliantyellowishgreen" "sRGB:131/211/125" 130) ("vividyellowishgreen" "sRGB:39/166/76" 129) ("darkgrayisholivegreen" "sRGB:49/54/43" 128) ("grayisholivegreen" "sRGB:81/87/68" 127) ("darkolivegreen" "sRGB:43/61/38" 126) ("moderateolivegreen" "sRGB:74/93/35" 125) ("deepolivegreen" "sRGB:35/47/0" 124) ("strongolivegreen" "sRGB:64/79/0" 123) ("grayishyellowgreen" "sRGB:143/151/121" 122) ("paleyellowgreen" "sRGB:218/223/183" 121) ("moderateyellowgreen" "sRGB:138/154/91" 120) ("lightyellowgreen" "sRGB:201/220/137" 119) ("deepyellowgreen" "sRGB:70/113/41" 118) ("strongyellowgreen" "sRGB:126/159/46" 117) ("brilliantyellowgreen" "sRGB:189/218/87" 116) ("vividyellowgreen" "sRGB:141/182/0" 115) ("oliveblack" "sRGB:37/36/29" 114) ("olivegray" "sRGB:87/85/76" 113) ("lightolivegray" "sRGB:138/135/118" 112) ("darkgrayisholive" "sRGB:54/53/39" 111) ("grayisholive" "sRGB:91/88/66" 110) ("lightgrayisholive" "sRGB:140/135/103" 109) ("darkolive" "sRGB:64/61/33" 108) ("moderateolive" "sRGB:102/93/30" 107) ("lightolive" "sRGB:134/126/54" 106) ("grayishgreenishyellow" "sRGB:185/181/125" 105) ("palegreenishyellow" "sRGB:235/232/164" 104) ("darkgreenishyellow" "sRGB:152/148/62" 103) ("moderategreenishyellow" "sRGB:185/180/89" 102) ("lightgreenishyellow" "sRGB:234/230/121" 101) ("deepgreenishyellow" "sRGB:155/148/0" 100) ("stronggreenishyellow" "sRGB:190/183/46" 99) ("brilliantgreenishyellow" "sRGB:233/228/80" 98) ("vividgreenishyellow" "sRGB:220/211/0" 97) ("darkolivebrown" "sRGB:59/49/33" 96) ("moderateolivebrown" "sRGB:108/84/30" 95) ("lightolivebrown" "sRGB:150/113/23" 94) ("yellowishgray" "sRGB:191/184/165" 93) ("yellowishwhite" "sRGB:240/234/214" 92) ("darkgrayishyellow" "sRGB:161/143/96" 91) ("grayishyellow" "sRGB:194/178/128" 90) ("paleyellow" "sRGB:243/229/171" 89) ("darkyellow" "sRGB:171/145/68" 88) ("moderateyellow" "sRGB:201/174/93" 87) ("lightyellow" "sRGB:248/222/126" 86) ("deepyellow" "sRGB:175/141/19" 85) ("strongyellow" "sRGB:212/175/55" 84) ("brilliantyellow" "sRGB:250/218/94" 83) ("vividyellow" "sRGB:243/195/0" 82) ("darkgrayishyellowishbrown" "sRGB:72/60/50" 81) ("grayishyellowishbrown" "sRGB:126/109/90" 80) ("lightgrayishyellowishbrown" "sRGB:174/155/130" 79) ("darkyellowishbrown" "sRGB:75/54/33" 78) ("moderateyellowishbrown" "sRGB:130/102/68" 77) ("lightyellowishbrown" "sRGB:193/154/107" 76) ("deepyellowishbrown" "sRGB:101/69/34" 75) ("strongyellowishbrown" "sRGB:153/101/21" 74) ("paleorangeyellow" "sRGB:250/214/165" 73) ("darkorangeyellow" "sRGB:190/138/61" 72) ("moderateorangeyellow" "sRGB:227/168/87" 71) ("lightorangeyellow" "sRGB:251/201/127" 70) ("deeporangeyellow" "sRGB:201/133/0" 69) ("strongorangeyellow" "sRGB:234/162/33" 68) ("brilliantorangeyellow" "sRGB:255/193/79" 67) ("vividorangeyellow" "sRGB:246/166/0" 66) ("brownishblack" "sRGB:40/32/28" 65) ("brownishgray" "sRGB:91/80/79" 64) ("lightbrownishgray" "sRGB:142/130/121" 63) ("darkgrayishbrown" "sRGB:62/50/44" 62) ("grayishbrown" "sRGB:99/81/71" 61) ("lightgrayishbrown" "sRGB:149/128/112" 60) ("darkbrown" "sRGB:66/37/24" 59) ("moderatebrown" "sRGB:111/78/55" 58) ("lightbrown" "sRGB:166/123/91" 57) ("deepbrown" "sRGB:89/51/25" 56) ("strongbrown" "sRGB:128/70/27" 55) ("brownishorange" "sRGB:174/105/56" 54) ("moderateorange" "sRGB:217/144/88" 53) ("lightorange" "sRGB:250/181/127" 52) ("deeporange" "sRGB:190/101/22" 51) ("strongorange" "sRGB:237/135/45" 50) ("brilliantorange" "sRGB:253/148/63" 49) ("vividorange" "sRGB:243/132/0" 48) ("darkgrayishreddishbrown" "sRGB:67/48/46" 47) ("grayishreddishbrown" "sRGB:103/76/71" 46) ("lightgrayishreddishbrown" "sRGB:151/127/115" 45) ("darkreddishbrown" "sRGB:62/29/30" 44) ("moderatereddishbrown" "sRGB:121/68/59" 43) ("lightreddishbrown" "sRGB:168/124/109" 42) ("deepreddishbrown" "sRGB:86/7/12" 41) ("strongreddishbrown" "sRGB:136/45/23" 40) ("grayishreddishorange" "sRGB:180/116/94" 39) ("darkreddishorange" "sRGB:158/71/50" 38) ("moderatereddishorange" "sRGB:203/109/81" 37) ("deepreddishorange" "sRGB:170/56/30" 36) ("strongreddishorange" "sRGB:217/96/59" 35) ("vividreddishorange" "sRGB:226/88/34" 34) ("brownishpink" "sRGB:194/172/153" 33) ("grayishyellowishpink" "sRGB:199/173/163" 32) ("paleyellowishpink" "sRGB:236/213/197" 31) ("darkyellowishpink" "sRGB:196/131/121" 30) ("moderateyellowishpink" "sRGB:217/166/169" 29) ("lightyellowishpink" "sRGB:244/194/194" 28) ("deepyellowishpink" "sRGB:230/103/33" 27) ("strongyellowishpink" "sRGB:249/147/121" 26) ("vividyellowishpink" "sRGB:255/183/165" 25) ("reddishblack" "sRGB:40/32/34" 24) ("darkreddishgray" "sRGB:92/80/79" 23) ("reddishgray" "sRGB:143/129/127" 22) ("blackishred" "sRGB:46/29/33" 21) ("darkgrayishred" "sRGB:84/61/63" 20) ("grayishred" "sRGB:144/93/93" 19) ("lightgrayishred" "sRGB:173/136/132" 18) ("verydarkred" "sRGB:63/23/40" 17) ("darkred" "sRGB:114/47/55" 16) ("moderatered" "sRGB:171/78/82" 15) ("verydeepred" "sRGB:92/9/35" 14) ("deepred" "sRGB:132/27/45" 13) ("strongred" "sRGB:188/63/74" 12) ("vividred" "sRGB:190/0/50" 11) ("pinkishgray" "sRGB:193/182/179" 10) ("pinkishwhite" "sRGB:234/227/225" 9) ("grayishpink" "sRGB:196/174/173" 8) ("palepink" "sRGB:234/216/215" 7) ("darkpink" "sRGB:192/128/129" 6) ("moderatepink" "sRGB:222/165/164" 5) ("lightpink" "sRGB:249/204/202" 4) ("deeppink" "sRGB:228/113/122" 3) ("strongpink" "sRGB:234/147/153" 2) ("vividpink" "sRGB:255/181/186" 1) ) (9 (3 #f order #f ordinal) (2 #f color #f string) (1 #t name #f string) ) (8 ("zydeco" "sRGB:32/72/63" 1379) ("zumthor" "sRGB:205/213/213" 1378) ("zuccini" "sRGB:23/70/46" 1377) ("zorba" "sRGB:162/149/137" 1376) ("zombie" "sRGB:221/194/131" 1375) ("zircon" "sRGB:222/227/227" 1374) ("ziggurat" "sRGB:129/166/170" 1373) ("zeus" "sRGB:59/60/56" 1372) ("zest" "sRGB:198/114/59" 1371) ("zanah" "sRGB:178/198/177" 1370) ("zambezi" "sRGB:107/90/90" 1369) ("yuma" "sRGB:199/184/130" 1368) ("yukongold" "sRGB:130/106/33" 1367) ("yourpink" "sRGB:255/197/187" 1366) ("yellowsea" "sRGB:244/159/53" 1365) ("yellowmetal" "sRGB:115/99/62" 1364) ("xanadu" "sRGB:117/135/110" 1363) ("woodybrown" "sRGB:85/69/69" 1362) ("woodybay" "sRGB:51/52/58" 1361) ("woodsmoke" "sRGB:43/50/48" 1360) ("woodrush" "sRGB:69/64/43" 1359) ("woodland" "sRGB:98/103/70" 1358) ("woodburn" "sRGB:70/54/41" 1357) ("woodbark" "sRGB:48/38/33" 1356) ("witchhaze" "sRGB:251/240/115" 1355) ("wistful" "sRGB:162/158/205" 1354) ("wisteria" "sRGB:164/135/139" 1353) ("wisppink" "sRGB:249/232/226" 1352) ("winterhazel" "sRGB:208/195/131" 1351) ("wineberry" "sRGB:82/44/53" 1350) ("windsor" "sRGB:70/44/119" 1349) ("willowgrove" "sRGB:105/117/92" 1348) ("willowbrook" "sRGB:223/230/207" 1347) ("william" "sRGB:83/115/111" 1346) ("wildwillow" "sRGB:190/202/96" 1345) ("wildsand" "sRGB:231/228/222" 1344) ("wildrice" "sRGB:227/212/116" 1343) ("whiterock" "sRGB:212/207/180" 1342) ("whitepointer" "sRGB:218/214/204" 1341) ("whitenectar" "sRGB:248/246/216" 1340) ("whitelinen" "sRGB:238/231/220" 1339) ("whitelilac" "sRGB:231/229/232" 1338) ("whiteice" "sRGB:215/238/228" 1337) ("whisper" "sRGB:239/230/230" 1336) ("whiskeysour" "sRGB:212/145/93" 1335) ("whiskey" "sRGB:210/144/98" 1334) ("wheatfield" "sRGB:223/215/189" 1333) ("wewak" "sRGB:241/145/154" 1332) ("westernred" "sRGB:107/37/44" 1331) ("westar" "sRGB:212/207/197" 1330) ("westside" "sRGB:229/130/58" 1329) ("westcoast" "sRGB:92/81/47" 1328) ("wellread" "sRGB:142/53/55" 1327) ("wedgewood" "sRGB:76/107/136" 1326) ("wepeep" "sRGB:253/215/216" 1325) ("waxflower" "sRGB:238/179/158" 1324) ("watusi" "sRGB:242/205/187" 1323) ("wattle" "sRGB:214/202/61" 1322) ("waterloo" "sRGB:114/114/130" 1321) ("watercourse" "sRGB:0/110/78" 1320) ("waterleaf" "sRGB:182/236/222" 1319) ("wasabi" "sRGB:132/145/55" 1318) ("wanwhite" "sRGB:228/226/220" 1317) ("walnut" "sRGB:121/77/46" 1316) ("waiouru" "sRGB:76/78/49" 1315) ("waikawagrey" "sRGB:91/110/145" 1314) ("wafer" "sRGB:212/187/177" 1313) ("vulcan" "sRGB:54/56/60" 1312) ("voodoo" "sRGB:68/50/64" 1311) ("volcano" "sRGB:78/39/40" 1310) ("vistawhite" "sRGB:227/223/217" 1309) ("vistablue" "sRGB:151/213/179" 1308) ("visvis" "sRGB:249/228/150" 1307) ("viridiangreen" "sRGB:75/95/86" 1306) ("violet" "sRGB:47/38/60" 1305) ("violentviolet" "sRGB:46/34/73" 1304) ("viola" "sRGB:197/143/157" 1303) ("vinrouge" "sRGB:149/82/100" 1302) ("viking" "sRGB:77/177/200" 1301) ("vidaloca" "sRGB:95/146/40" 1300) ("victoria" "sRGB:86/73/133" 1299) ("vesuvius" "sRGB:168/85/51" 1298) ("verdungreen" "sRGB:72/83/26" 1297) ("verdigris" "sRGB:98/96/62" 1296) ("venus" "sRGB:139/125/130" 1295) ("veniceblue" "sRGB:44/87/120" 1294) ("venetianred" "sRGB:91/31/34" 1293) ("varden" "sRGB:253/239/211" 1292) ("vanillaice" "sRGB:235/210/209" 1291) ("vanilla" "sRGB:204/182/155" 1290) ("vancleef" "sRGB:82/57/54" 1289) ("valhalla" "sRGB:42/43/65" 1288) ("valentino" "sRGB:56/44/56" 1287) ("valencia" "sRGB:212/87/78" 1286) ("twine" "sRGB:193/145/86" 1285) ("twilightblue" "sRGB:244/246/236" 1284) ("twilight" "sRGB:218/192/205" 1283) ("tutu" "sRGB:248/228/227" 1282) ("tussock" "sRGB:191/145/75" 1281) ("tusk" "sRGB:227/229/177" 1280) ("tuscany" "sRGB:173/98/66" 1279) ("turtlegreen" "sRGB:54/62/29" 1278) ("turmeric" "sRGB:174/144/65" 1277) ("turkishrose" "sRGB:165/110/117" 1276) ("turbo" "sRGB:245/204/35" 1275) ("tundora" "sRGB:88/84/82" 1274) ("tuna" "sRGB:70/73/78" 1273) ("tumbleweed" "sRGB:75/65/42" 1272) ("tuliptree" "sRGB:227/172/61" 1271) ("tuftbush" "sRGB:249/211/190" 1270) ("tuatara" "sRGB:69/70/66" 1269) ("truev" "sRGB:142/114/199" 1268) ("trout" "sRGB:76/83/86" 1267) ("tropicalblue" "sRGB:174/201/235" 1266) ("trinidad" "sRGB:197/79/51" 1265) ("trendypink" "sRGB:128/93/128" 1264) ("trendygreen" "sRGB:126/132/36" 1263) ("treehouse" "sRGB:60/52/46" 1262) ("treepoppy" "sRGB:226/129/59" 1261) ("travertine" "sRGB:226/221/199" 1260) ("tranquil" "sRGB:221/237/233" 1259) ("tradewind" "sRGB:109/175/167" 1258) ("towergrey" "sRGB:156/172/165" 1257) ("touchwood" "sRGB:58/55/46" 1256) ("totempole" "sRGB:136/53/49" 1255) ("tosca" "sRGB:116/64/66" 1254) ("toryblue" "sRGB:55/78/136" 1253) ("toreabay" "sRGB:53/61/117" 1252) ("topaz" "sRGB:129/124/135" 1251) ("tonyspink" "sRGB:231/158/136" 1250) ("tomthumb" "sRGB:79/99/72" 1249) ("tolopea" "sRGB:45/37/65" 1248) ("toledo" "sRGB:62/38/49" 1247) ("tobago" "sRGB:68/54/45" 1246) ("tobaccobrown" "sRGB:109/88/67" 1245) ("toast" "sRGB:159/113/95" 1244) ("titanwhite" "sRGB:221/214/225" 1243) ("timbergreen" "sRGB:50/67/54" 1242) ("tide" "sRGB:190/180/171" 1241) ("tidal" "sRGB:240/245/144" 1240) ("tiber" "sRGB:24/67/67" 1239) ("tiara" "sRGB:185/195/190" 1238) ("tiamaria" "sRGB:151/66/45" 1237) ("thunderbird" "sRGB:146/56/48" 1236) ("thunder" "sRGB:77/77/75" 1235) ("thistle" "sRGB:199/189/149" 1234) ("thatchgreen" "sRGB:84/78/49" 1233) ("thatch" "sRGB:177/148/143" 1232) ("texasrose" "sRGB:252/176/87" 1231) ("texas" "sRGB:236/230/126" 1230) ("tequila" "sRGB:244/208/164" 1229) ("temptress" "sRGB:60/33/38" 1228) ("tealblue" "sRGB:37/72/85" 1227) ("teak" "sRGB:171/137/83" 1226) ("tea" "sRGB:191/181/162" 1225) ("tepapagreen" "sRGB:43/75/64" 1224) ("taxbreak" "sRGB:73/101/105" 1223) ("tawnyport" "sRGB:100/58/72" 1222) ("taupegrey" "sRGB:137/132/120" 1221) ("tasman" "sRGB:186/192/179" 1220) ("tarawera" "sRGB:37/60/72" 1219) ("tara" "sRGB:222/241/221" 1218) ("tapestry" "sRGB:179/112/132" 1217) ("tapa" "sRGB:124/124/114" 1216) ("tango" "sRGB:212/111/49" 1215) ("tangerine" "sRGB:205/93/52" 1214) ("tangaroa" "sRGB:30/47/60" 1213) ("tana" "sRGB:184/181/161" 1212) ("tamarind" "sRGB:62/47/46" 1211) ("tamarillo" "sRGB:117/43/47" 1210) ("tallow" "sRGB:163/153/119" 1209) ("tallpoppy" "sRGB:133/53/52" 1208) ("tahunasands" "sRGB:216/204/155" 1207) ("tahitigold" "sRGB:220/114/42" 1206) ("tacha" "sRGB:210/185/96" 1205) ("tacao" "sRGB:246/174/120" 1204) ("tabasco" "sRGB:142/58/54" 1203) ("sycamore" "sRGB:146/140/60" 1202) ("swisscoffee" "sRGB:219/208/202" 1201) ("swirl" "sRGB:215/206/197" 1200) ("sweetpink" "sRGB:238/145/141" 1199) ("sweetcorn" "sRGB:249/225/118" 1198) ("swansdown" "sRGB:218/230/221" 1197) ("swamp" "sRGB:37/47/47" 1196) ("suvagrey" "sRGB:139/134/133" 1195) ("sushi" "sRGB:124/159/47" 1194) ("surfiegreen" "sRGB:0/123/119" 1193) ("surfcrest" "sRGB:195/214/189" 1192) ("surf" "sRGB:184/212/187" 1191) ("supernova" "sRGB:255/180/55" 1190) ("sunshade" "sRGB:250/157/73" 1189) ("sunset" "sRGB:192/81/74" 1188) ("sunglo" "sRGB:199/97/85" 1187) ("sunflower" "sRGB:218/192/26" 1186) ("sundown" "sRGB:248/175/169" 1185) ("sundance" "sRGB:196/170/77" 1184) ("sun" "sRGB:239/142/56" 1183) ("summergreen" "sRGB:143/182/156" 1182) ("sulu" "sRGB:198/234/128" 1181) ("sugarcane" "sRGB:238/239/223" 1180) ("submarine" "sRGB:140/156/156" 1179) ("studio" "sRGB:114/74/161" 1178) ("stromboli" "sRGB:64/99/86" 1177) ("strikemaster" "sRGB:148/106/129" 1176) ("straw" "sRGB:218/190/130" 1175) ("stratos" "sRGB:33/38/58" 1174) ("stormgrey" "sRGB:116/120/128" 1173) ("stormdust" "sRGB:101/100/95" 1172) ("stonewall" "sRGB:128/118/97" 1171) ("stinger" "sRGB:141/112/42" 1170) ("stiletto" "sRGB:131/61/62" 1169) ("steelgrey" "sRGB:67/70/75" 1168) ("starship" "sRGB:227/221/57" 1167) ("starkwhite" "sRGB:210/198/182" 1166) ("stardust" "sRGB:160/161/151" 1165) ("stack" "sRGB:133/136/133" 1164) ("sttropaz" "sRGB:50/84/130" 1163) ("squirrel" "sRGB:143/125/107" 1162) ("spunpearl" "sRGB:162/161/172" 1161) ("sprout" "sRGB:184/202/157" 1160) ("springwood" "sRGB:233/225/217" 1159) ("springsun" "sRGB:241/241/198" 1158) ("springrain" "sRGB:163/189/156" 1157) ("springgreen" "sRGB:92/138/100" 1156) ("spray" "sRGB:126/205/221" 1155) ("splash" "sRGB:241/215/158" 1154) ("spindle" "sRGB:179/196/216" 1153) ("spicypink" "sRGB:137/117/120" 1152) ("spicymix" "sRGB:139/95/77" 1151) ("spice" "sRGB:108/79/63" 1150) ("spectra" "sRGB:55/93/79" 1149) ("spanishwhite" "sRGB:222/209/183" 1148) ("spanishgreen" "sRGB:123/137/118" 1147) ("spaceshuttle" "sRGB:75/67/59" 1146) ("soyabean" "sRGB:111/99/75" 1145) ("sourdough" "sRGB:201/181/154" 1144) ("sorrellbrown" "sRGB:157/127/97" 1143) ("sorbus" "sRGB:221/107/56" 1142) ("solitude" "sRGB:233/236/241" 1141) ("solitaire" "sRGB:234/218/194" 1140) ("solidpink" "sRGB:133/73/76" 1139) ("softpeach" "sRGB:238/223/222" 1138) ("softamber" "sRGB:207/190/165" 1137) ("soapstone" "sRGB:236/229/218" 1136) ("snuff" "sRGB:228/215/229" 1135) ("snowymint" "sRGB:214/240/205" 1134) ("snowflurry" "sRGB:234/247/201" 1133) ("snowdrift" "sRGB:227/227/220" 1132) ("smoky" "sRGB:96/93/107" 1131) ("smokeyash" "sRGB:93/89/82" 1130) ("smoketree" "sRGB:187/95/52" 1129) ("smaltblue" "sRGB:73/98/103" 1128) ("slugger" "sRGB:66/52/43" 1127) ("skeptic" "sRGB:157/180/170" 1126) ("sisal" "sRGB:197/186/160" 1125) ("sirocco" "sRGB:104/118/110" 1124) ("siren" "sRGB:105/41/59" 1123) ("sinbad" "sRGB:166/213/208" 1122) ("silvertree" "sRGB:103/190/144" 1121) ("silversand" "sRGB:190/189/182" 1120) ("silverchalice" "sRGB:172/174/169" 1119) ("silk" "sRGB:187/173/161" 1118) ("sidecar" "sRGB:233/217/169" 1117) ("siam" "sRGB:104/107/80" 1116) ("shuttlegrey" "sRGB:97/102/107" 1115) ("shocking" "sRGB:232/153/190" 1114) ("shiraz" "sRGB:132/40/51" 1113) ("shipgrey" "sRGB:78/78/76" 1112) ("shipcove" "sRGB:121/136/171" 1111) ("shinglefawn" "sRGB:116/89/55" 1110) ("shilo" "sRGB:230/178/166" 1109) ("sherwoodgreen" "sRGB:27/70/54" 1108) ("sherpablue" "sRGB:0/73/78" 1107) ("shark" "sRGB:52/54/58" 1106) ("shalimar" "sRGB:248/246/168" 1105) ("shakespeare" "sRGB:96/154/184" 1104) ("shadylady" "sRGB:159/155/157" 1103) ("shadowgreen" "sRGB:154/192/182" 1102) ("serenade" "sRGB:252/233/215" 1101) ("sepia" "sRGB:58/47/45" 1100) ("selago" "sRGB:230/223/231" 1099) ("seaweed" "sRGB:55/65/42" 1098) ("seashell" "sRGB:227/225/224" 1097) ("seance" "sRGB:105/50/110" 1096) ("seagull" "sRGB:119/183/208" 1095) ("seapink" "sRGB:219/129/126" 1094) ("seanymph" "sRGB:138/174/164" 1093) ("seamist" "sRGB:194/213/196" 1092) ("seagreen" "sRGB:31/99/97" 1091) ("seafog" "sRGB:223/221/214" 1090) ("seabuckthorn" "sRGB:239/149/72" 1089) ("scrub" "sRGB:61/64/49" 1088) ("scotchmist" "sRGB:238/231/200" 1087) ("scorpion" "sRGB:106/100/102" 1086) ("scooter" "sRGB:48/142/160" 1085) ("schooner" "sRGB:141/132/120" 1084) ("schist" "sRGB:135/135/111" 1083) ("scarpaflow" "sRGB:107/106/108" 1082) ("scarlett" "sRGB:126/37/48" 1081) ("scarletgum" "sRGB:74/45/87" 1080) ("scandal" "sRGB:173/217/209" 1079) ("scampi" "sRGB:111/99/160" 1078) ("sazerac" "sRGB:245/222/196" 1077) ("sauvignon" "sRGB:244/234/228" 1076) ("saratoga" "sRGB:85/91/44" 1075) ("sapphire" "sRGB:63/82/129" 1074) ("sapling" "sRGB:225/213/166" 1073) ("santefe" "sRGB:169/106/80" 1072) ("santasgrey" "sRGB:153/152/167" 1071) ("sanguinebrown" "sRGB:108/55/54" 1070) ("sangria" "sRGB:130/42/50" 1069) ("sandybeach" "sRGB:254/219/183" 1068) ("sandwisp" "sRGB:222/203/129" 1067) ("sandstone" "sRGB:120/109/95" 1066) ("sandrift" "sRGB:175/147/125" 1065) ("sandal" "sRGB:163/135/106" 1064) ("sanddune" "sRGB:134/118/101" 1063) ("sanmarino" "sRGB:78/108/157" 1062) ("sanjuan" "sRGB:68/87/97" 1061) ("sanfelix" "sRGB:44/110/49" 1060) ("sambuca" "sRGB:59/46/37" 1059) ("saltpan" "sRGB:238/243/229" 1058) ("saltbox" "sRGB:105/98/104" 1057) ("salomie" "sRGB:255/214/123" 1056) ("salem" "sRGB:23/123/77" 1055) ("sail" "sRGB:165/206/236" 1054) ("sahara" "sRGB:183/152/38" 1053) ("sage" "sRGB:152/159/122" 1052) ("saffron" "sRGB:220/159/69" 1051) ("saddlebrown" "sRGB:80/56/30" 1050) ("saddle" "sRGB:93/78/70" 1049) ("rustynail" "sRGB:141/95/44" 1048) ("rusticred" "sRGB:58/24/26" 1047) ("russett" "sRGB:125/101/92" 1046) ("rumswizzle" "sRGB:241/237/212" 1045) ("rum" "sRGB:113/102/117" 1044) ("royalheath" "sRGB:181/75/115" 1043) ("rouge" "sRGB:169/64/100" 1042) ("roti" "sRGB:182/150/66" 1041) ("rosewood" "sRGB:143/62/63" 1040) ("rosewhite" "sRGB:251/238/232" 1039) ("roseofsharon" "sRGB:172/81/45" 1038) ("rosebudcherry" "sRGB:138/45/82" 1037) ("rosebud" "sRGB:254/171/154" 1036) ("rose" "sRGB:211/161/148" 1035) ("rope" "sRGB:142/89/60" 1034) ("roofterracotta" "sRGB:161/71/67" 1033) ("ronchi" "sRGB:234/184/82" 1032) ("romantic" "sRGB:255/198/158" 1031) ("romance" "sRGB:244/240/230" 1030) ("romancoffee" "sRGB:125/103/87" 1029) ("roman" "sRGB:216/98/91" 1028) ("rollingstone" "sRGB:109/120/118" 1027) ("rodeodust" "sRGB:199/163/132" 1026) ("rockspray" "sRGB:157/68/45" 1025) ("rocksalt" "sRGB:230/214/184" 1024) ("rockblue" "sRGB:147/162/186" 1023) ("rock" "sRGB:90/77/65" 1022) ("robinseggblue" "sRGB:158/170/158" 1021) ("robroy" "sRGB:221/173/86" 1020) ("riverbed" "sRGB:85/96/97" 1019) ("riptide" "sRGB:137/217/200" 1018) ("riogrande" "sRGB:183/198/26" 1017) ("richgold" "sRGB:161/82/38" 1016) ("riceflower" "sRGB:239/245/209" 1015) ("ricecake" "sRGB:239/236/222" 1014) ("ribbon" "sRGB:113/51/60" 1013) ("rhino" "sRGB:61/70/83" 1012) ("revolver" "sRGB:55/54/63" 1011) ("resolutionblue" "sRGB:50/63/117" 1010) ("renosand" "sRGB:178/110/51" 1009) ("remy" "sRGB:246/222/218" 1008) ("regentstblue" "sRGB:160/205/217" 1007) ("regentgrey" "sRGB:121/132/136" 1006) ("regalblue" "sRGB:32/63/88" 1005) ("reefgold" "sRGB:169/141/54" 1004) ("reef" "sRGB:209/239/159" 1003) ("redwood" "sRGB:91/52/46" 1002) ("redstage" "sRGB:173/82/46" 1001) ("redrobin" "sRGB:125/65/56" 1000) ("redoxide" "sRGB:93/31/30" 999) ("reddevil" "sRGB:102/42/44" 998) ("reddamask" "sRGB:203/111/74" 997) ("redberry" "sRGB:112/31/40" 996) ("redbeech" "sRGB:161/98/59" 995) ("rebel" "sRGB:69/52/48" 994) ("raven" "sRGB:111/116/123" 993) ("rangoongreen" "sRGB:43/46/37" 992) ("rangitoto" "sRGB:58/65/51" 991) ("rajah" "sRGB:252/174/96" 990) ("rainee" "sRGB:179/193/177" 989) ("raincloud" "sRGB:163/152/129" 988) ("rainforest" "sRGB:102/112/40" 987) ("raffia" "sRGB:220/198/160" 986) ("racinggreen" "sRGB:35/47/44" 985) ("quincy" "sRGB:106/84/69" 984) ("quillgrey" "sRGB:203/201/192" 983) ("quicksand" "sRGB:195/152/139" 982) ("quarterspanishwhite" "sRGB:235/226/210" 981) ("quarterpearllusta" "sRGB:242/237/221" 980) ("putty" "sRGB:205/174/112" 979) ("punga" "sRGB:83/73/49" 978) ("punch" "sRGB:168/50/57" 977) ("pumpkin" "sRGB:171/107/53" 976) ("pumice" "sRGB:186/192/180" 975) ("puertorico" "sRGB:89/186/163" 974) ("pueblo" "sRGB:110/51/38" 973) ("prussianblue" "sRGB:25/47/65" 972) ("provincialpink" "sRGB:246/227/218" 971) ("promenade" "sRGB:248/246/223" 970) ("primrose" "sRGB:228/222/142" 969) ("prim" "sRGB:226/205/213" 968) ("prelude" "sRGB:202/180/212" 967) ("prairiesand" "sRGB:136/60/50" 966) ("powderblue" "sRGB:146/159/162" 965) ("pottersclay" "sRGB:132/92/64" 964) ("potpourri" "sRGB:239/220/212" 963) ("portica" "sRGB:240/213/85" 962) ("portage" "sRGB:139/152/216" 961) ("portafino" "sRGB:244/240/155" 960) ("portgore" "sRGB:59/67/108" 959) ("porsche" "sRGB:223/157/91" 958) ("porcelain" "sRGB:221/220/219" 957) ("pompadour" "sRGB:106/31/68" 956) ("poloblue" "sRGB:138/167/204" 955) ("polar" "sRGB:229/242/231" 954) ("pohutukawa" "sRGB:101/28/38" 953) ("plum" "sRGB:56/26/56" 952) ("planter" "sRGB:98/93/42" 951) ("plantation" "sRGB:62/89/76" 950) ("pizza" "sRGB:191/141/60" 949) ("pizazz" "sRGB:229/127/61" 948) ("pixiegreen" "sRGB:187/205/165" 947) ("pistachio" "sRGB:103/105/39" 946) ("pirategold" "sRGB:186/120/42" 945) ("pippin" "sRGB:252/219/210" 944) ("pipi" "sRGB:245/230/196" 943) ("piper" "sRGB:157/84/50" 942) ("pinkswan" "sRGB:191/179/178" 941) ("pinklady" "sRGB:243/215/182" 940) ("pinklace" "sRGB:246/204/215" 939) ("pinkflare" "sRGB:216/180/182" 938) ("pinetree" "sRGB:42/47/35" 937) ("pineglade" "sRGB:189/192/126" 936) ("pinecone" "sRGB:117/101/86" 935) ("pigeonpost" "sRGB:119/132/142" 934) ("pictonblue" "sRGB:91/160/208" 933) ("pickledbluewood" "sRGB:79/90/95" 932) ("pickledbean" "sRGB:115/85/62" 931) ("pickledaspen" "sRGB:91/100/82" 930) ("picasso" "sRGB:248/234/151" 929) ("pharlap" "sRGB:130/102/99" 928) ("pewter" "sRGB:145/160/146" 927) ("petiteorchid" "sRGB:218/151/144" 926) ("pesto" "sRGB:122/114/41" 925) ("perutan" "sRGB:115/61/31" 924) ("persimmon" "sRGB:239/115/94" 923) ("persianred" "sRGB:79/33/42" 922) ("persianplum" "sRGB:104/51/50" 921) ("periglacialblue" "sRGB:172/182/178" 920) ("perfume" "sRGB:194/169/219" 919) ("perano" "sRGB:172/185/232" 918) ("peppermint" "sRGB:215/231/208" 917) ("pelorous" "sRGB:37/153/178" 916) ("peat" "sRGB:118/109/82" 915) ("pearllusta" "sRGB:234/224/200" 914) ("pearlbush" "sRGB:222/209/198" 913) ("peanut" "sRGB:122/68/52" 912) ("peachschnapps" "sRGB:198/128/89" 911) ("peach" "sRGB:251/229/194" 910) ("peasoup" "sRGB:185/184/128" 909) ("pavlova" "sRGB:186/171/135" 908) ("paua" "sRGB:42/37/81" 907) ("pattensblue" "sRGB:211/229/239" 906) ("patina" "sRGB:99/146/131" 905) ("parsley" "sRGB:48/93/53" 904) ("pariswhite" "sRGB:191/205/192" 903) ("parism" "sRGB:49/39/96" 902) ("parisdaisy" "sRGB:251/235/80" 901) ("parchment" "sRGB:208/200/176" 900) ("paradiso" "sRGB:72/128/132" 899) ("paprika" "sRGB:124/45/55" 898) ("panda" "sRGB:84/79/58" 897) ("pancho" "sRGB:223/185/146" 896) ("panache" "sRGB:235/247/228" 895) ("pampas" "sRGB:234/228/220" 894) ("palmleaf" "sRGB:54/72/47" 893) ("palmgreen" "sRGB:32/57/44" 892) ("paleslate" "sRGB:195/190/187" 891) ("palesky" "sRGB:99/109/112" 890) ("palerose" "sRGB:239/214/218" 889) ("paleprim" "sRGB:249/245/159" 888) ("paleoyster" "sRGB:156/141/114" 887) ("paleleaf" "sRGB:189/202/168" 886) ("padua" "sRGB:126/179/148" 885) ("paco" "sRGB:79/64/55" 884) ("pacifika" "sRGB:102/112/40" 883) ("pablo" "sRGB:122/113/92" 882) ("paarl" "sRGB:134/75/54" 881) ("oysterpink" "sRGB:212/181/176" 880) ("oysterbay" "sRGB:209/234/234" 879) ("oxley" "sRGB:109/154/120" 878) ("oxfordblue" "sRGB:40/53/58" 877) ("outerspace" "sRGB:31/38/59" 876) ("ottoman" "sRGB:211/219/203" 875) ("oslogrey" "sRGB:129/137/136" 874) ("orinoco" "sRGB:210/211/179" 873) ("orientalpink" "sRGB:194/142/136" 872) ("orient" "sRGB:37/91/119" 871) ("oregon" "sRGB:177/108/57" 870) ("orchidwhite" "sRGB:241/235/217" 869) ("orangewhite" "sRGB:234/227/205" 868) ("orangeroughy" "sRGB:168/83/53" 867) ("oracle" "sRGB:57/85/85" 866) ("opium" "sRGB:152/126/126" 865) ("opal" "sRGB:168/195/188" 864) ("onion" "sRGB:72/65/43" 863) ("onahau" "sRGB:194/230/236" 862) ("olivetone" "sRGB:116/112/40" 861) ("olivehaze" "sRGB:136/128/100" 860) ("olivegreen" "sRGB:53/63/42" 859) ("oldcopper" "sRGB:115/80/59" 858) ("oldbrick" "sRGB:138/51/53" 857) ("oiledcedar" "sRGB:102/54/45" 856) ("oil" "sRGB:49/51/48" 855) ("offyellow" "sRGB:250/243/220" 854) ("offgreen" "sRGB:223/240/226" 853) ("oceangreen" "sRGB:76/169/115" 852) ("observatory" "sRGB:0/143/112" 851) ("oasis" "sRGB:252/237/197" 850) ("nutmeg" "sRGB:126/74/59" 849) ("nugget" "sRGB:188/146/41" 848) ("norway" "sRGB:164/184/143" 847) ("nordic" "sRGB:29/57/60" 846) ("nomad" "sRGB:161/153/134" 845) ("nobel" "sRGB:169/157/157" 844) ("nileblue" "sRGB:37/63/78" 843) ("nightclub" "sRGB:106/31/68" 842) ("nightshadz" "sRGB:162/61/84" 841) ("nightrider" "sRGB:51/46/46" 840) ("niagara" "sRGB:41/169/139" 839) ("newyorkpink" "sRGB:221/131/116" 838) ("neworleans" "sRGB:228/195/133" 837) ("newamber" "sRGB:109/59/36" 836) ("nevada" "sRGB:102/111/111" 835) ("neutralgreen" "sRGB:170/165/131" 834) ("nero" "sRGB:37/37/37" 833) ("neptune" "sRGB:119/168/171" 832) ("nepal" "sRGB:147/170/185" 831) ("negroni" "sRGB:238/199/162" 830) ("nebula" "sRGB:184/198/190" 829) ("natural" "sRGB:136/89/49" 828) ("narvik" "sRGB:233/230/220" 827) ("napa" "sRGB:163/154/135" 826) ("nandor" "sRGB:78/93/78" 825) ("mystic" "sRGB:216/221/218" 824) ("mysin" "sRGB:253/174/69" 823) ("mypink" "sRGB:214/139/128" 822) ("mustard" "sRGB:124/103/32" 821) ("mulledwine" "sRGB:82/77/91" 820) ("mulefawn" "sRGB:136/79/64" 819) ("mulberry" "sRGB:94/42/64" 818) ("muesli" "sRGB:158/126/83" 817) ("muddywaters" "sRGB:169/132/79" 816) ("mountainmist" "sRGB:160/159/156" 815) ("mosque" "sRGB:0/95/91" 814) ("mosaic" "sRGB:41/55/65" 813) ("mortar" "sRGB:86/80/81" 812) ("moroccobrown" "sRGB:68/45/33" 811) ("morningglory" "sRGB:158/209/211" 810) ("moonyellow" "sRGB:240/196/32" 809) ("moonraker" "sRGB:192/178/215" 808) ("moonmist" "sRGB:206/205/184" 807) ("moonglow" "sRGB:245/243/206" 806) ("moodyblue" "sRGB:131/120/199" 805) ("monza" "sRGB:134/40/46" 804) ("montecarlo" "sRGB:122/197/180" 803) ("montana" "sRGB:57/59/60" 802) ("monsoon" "sRGB:122/118/121" 801) ("mongoose" "sRGB:165/139/111" 800) ("mondo" "sRGB:85/77/66" 799) ("monarch" "sRGB:107/37/44" 798) ("monalisa" "sRGB:255/152/137" 797) ("mojo" "sRGB:151/70/60" 796) ("mocha" "sRGB:111/55/45" 795) ("moccaccino" "sRGB:88/47/43" 794) ("mobster" "sRGB:96/90/103" 793) ("mistgrey" "sRGB:186/185/169" 792) ("mischka" "sRGB:165/169/178" 791) ("mirage" "sRGB:55/63/67" 790) ("minttulip" "sRGB:198/234/221" 789) ("mintjulep" "sRGB:224/216/167" 788) ("minsk" "sRGB:62/50/103" 787) ("ming" "sRGB:64/117/119" 786) ("mineralgreen" "sRGB:80/99/85" 785) ("mineshaft" "sRGB:55/62/65" 784) ("mindaro" "sRGB:218/234/111" 783) ("mimosa" "sRGB:245/245/204" 782) ("millbrook" "sRGB:89/86/72" 781) ("milkwhite" "sRGB:220/217/205" 780) ("milkpunch" "sRGB:243/229/192" 779) ("milanored" "sRGB:158/51/50" 778) ("milan" "sRGB:246/244/147" 777) ("mikado" "sRGB:63/54/35" 776) ("midnightmoss" "sRGB:36/46/40" 775) ("midnightexpress" "sRGB:33/38/58" 774) ("midnight" "sRGB:33/48/62" 773) ("midgrey" "sRGB:102/106/109" 772) ("mexicanred" "sRGB:155/61/61" 771) ("meteorite" "sRGB:74/59/106" 770) ("meteor" "sRGB:187/116/49" 769) ("metalliccopper" "sRGB:110/61/52" 768) ("metallicbronze" "sRGB:85/74/60" 767) ("merlot" "sRGB:115/52/58" 766) ("merlin" "sRGB:79/78/72" 765) ("merino" "sRGB:225/219/208" 764) ("mercury" "sRGB:213/210/209" 763) ("meranti" "sRGB:107/52/42" 762) ("melrose" "sRGB:195/185/221" 761) ("melanzane" "sRGB:52/41/49" 760) ("melanie" "sRGB:224/183/194" 759) ("mckenzie" "sRGB:140/99/56" 758) ("maverick" "sRGB:200/177/192" 757) ("matterhorn" "sRGB:82/75/75" 756) ("matrix" "sRGB:142/77/69" 755) ("matisse" "sRGB:54/92/125" 754) ("mash" "sRGB:90/76/66" 753) ("masala" "sRGB:87/83/75" 752) ("marzipan" "sRGB:235/200/129" 751) ("martinique" "sRGB:60/55/72" 750) ("martini" "sRGB:183/168/163" 749) ("marshland" "sRGB:43/46/38" 748) ("maroon" "sRGB:64/35/39" 747) ("marlin" "sRGB:54/45/38" 746) ("mariner" "sRGB:66/99/159" 745) ("marigold" "sRGB:184/138/61" 744) ("mardigras" "sRGB:53/34/53" 743) ("manz" "sRGB:228/219/85" 742) ("mantle" "sRGB:150/167/147" 741) ("mantis" "sRGB:127/193/92" 740) ("manhattan" "sRGB:226/175/128" 739) ("mandyspink" "sRGB:245/183/153" 738) ("mandy" "sRGB:205/82/91" 737) ("mandalay" "sRGB:181/123/46" 736) ("mamba" "sRGB:118/109/124" 735) ("malta" "sRGB:165/151/132" 734) ("mallard" "sRGB:58/69/49" 733) ("malibu" "sRGB:102/183/225" 732) ("malachitegreen" "sRGB:151/151/111" 731) ("mako" "sRGB:80/85/85" 730) ("makara" "sRGB:105/95/80" 729) ("maize" "sRGB:227/185/130" 728) ("maire" "sRGB:42/41/34" 727) ("maitai" "sRGB:165/101/49" 726) ("mahogany" "sRGB:73/38/37" 725) ("magnolia" "sRGB:238/232/235" 724) ("madras" "sRGB:71/62/35" 723) ("madison" "sRGB:45/60/84" 722) ("madang" "sRGB:183/227/168" 721) ("mabel" "sRGB:203/232/232" 720) ("lynch" "sRGB:105/125/137" 719) ("luxorgold" "sRGB:171/141/63" 718) ("lusty" "sRGB:120/46/44" 717) ("lunargreen" "sRGB:78/85/65" 716) ("luckypoint" "sRGB:41/45/79" 715) ("lucky" "sRGB:171/154/28" 714) ("loulou" "sRGB:76/51/71" 713) ("lotus" "sRGB:139/80/75" 712) ("lonestar" "sRGB:82/36/38" 711) ("londonhue" "sRGB:174/148/171" 710) ("lola" "sRGB:185/172/187" 709) ("logan" "sRGB:157/156/180" 708) ("logcabin" "sRGB:57/62/46" 707) ("locust" "sRGB:162/165/128" 706) ("lochmara" "sRGB:49/110/160" 705) ("lochinvar" "sRGB:72/144/132" 704) ("loblolly" "sRGB:179/187/183" 703) ("loafer" "sRGB:219/217/194" 702) ("lividbrown" "sRGB:49/42/41" 701) ("lisbonbrown" "sRGB:84/79/58" 700) ("lipstick" "sRGB:150/44/84" 699) ("linkwater" "sRGB:199/205/216" 698) ("linen" "sRGB:186/183/162" 697) ("limerick" "sRGB:137/172/39" 696) ("limedspruce" "sRGB:78/96/94" 695) ("limedoak" "sRGB:140/114/84" 694) ("limedgum" "sRGB:107/91/61" 693) ("limedash" "sRGB:103/109/99" 692) ("limeade" "sRGB:95/151/39" 691) ("lime" "sRGB:183/197/44" 690) ("lima" "sRGB:122/172/33" 689) ("lilywhite" "sRGB:233/238/235" 688) ("lily" "sRGB:193/159/179" 687) ("lilacbush" "sRGB:148/112/196" 686) ("lightningyellow" "sRGB:247/162/51" 685) ("licorice" "sRGB:46/55/73" 684) ("lemongrass" "sRGB:153/154/134" 683) ("lemonginger" "sRGB:150/132/40" 682) ("lemon" "sRGB:217/178/32" 681) ("leather" "sRGB:144/106/84" 680) ("lavender" "sRGB:159/144/208" 679) ("laurel" "sRGB:110/141/113" 678) ("laser" "sRGB:198/169/94" 677) ("laspalmas" "sRGB:198/218/54" 676) ("larioja" "sRGB:186/192/14" 675) ("lapalma" "sRGB:66/137/41" 674) ("kumera" "sRGB:117/91/39" 673) ("kournikova" "sRGB:249/208/84" 672) ("koromiko" "sRGB:254/181/82" 671) ("korma" "sRGB:128/78/44" 670) ("kokoda" "sRGB:123/120/90" 669) ("kobi" "sRGB:224/147/171" 668) ("kingfisherdaisy" "sRGB:88/53/128" 667) ("kimberly" "sRGB:105/93/135" 666) ("killarney" "sRGB:73/118/79" 665) ("kilamanjaro" "sRGB:58/53/50" 664) ("kidnapper" "sRGB:191/192/171" 663) ("keppel" "sRGB:95/182/156" 662) ("kenyancopper" "sRGB:108/50/46" 661) ("kelp" "sRGB:77/80/60" 660) ("kashmirblue" "sRGB:87/109/142" 659) ("karry" "sRGB:254/220/193" 658) ("karaka" "sRGB:45/45/36" 657) ("kangaroo" "sRGB:197/195/176" 656) ("kaitokegreen" "sRGB:36/83/54" 655) ("kabul" "sRGB:108/94/83" 654) ("justright" "sRGB:220/191/172" 653) ("juniper" "sRGB:116/145/142" 652) ("junglemist" "sRGB:176/196/196" 651) ("junglegreen" "sRGB:41/41/36" 650) ("jumbo" "sRGB:135/135/133" 649) ("judgegrey" "sRGB:93/83/70" 648) ("jordyblue" "sRGB:122/170/224" 647) ("jonquil" "sRGB:238/242/147" 646) ("jon" "sRGB:70/61/62" 645) ("joanna" "sRGB:214/209/192" 644) ("jewel" "sRGB:19/104/67" 643) ("jetstream" "sRGB:187/208/201" 642) ("jellybean" "sRGB:68/121/142" 641) ("jazz" "sRGB:95/44/47" 640) ("java" "sRGB:37/151/151" 639) ("jarrah" "sRGB:59/43/44" 638) ("japonica" "sRGB:206/114/89" 637) ("japanesemaple" "sRGB:103/47/48" 636) ("japaneselaurel" "sRGB:47/117/50" 635) ("janna" "sRGB:222/209/183" 634) ("jambalaya" "sRGB:103/72/52" 633) ("jaguar" "sRGB:41/41/47" 632) ("jagger" "sRGB:63/46/76" 631) ("jaggedice" "sRGB:202/231/226" 630) ("jaffa" "sRGB:226/121/69" 629) ("jade" "sRGB:64/114/109" 628) ("jacksonspurple" "sRGB:61/63/125" 627) ("jackobean" "sRGB:65/54/40" 626) ("jacarta" "sRGB:61/50/93" 625) ("jacaranda" "sRGB:54/45/56" 624) ("islandspice" "sRGB:248/237/219" 623) ("ironstone" "sRGB:134/80/64" 622) ("ironsidegrey" "sRGB:112/110/102" 621) ("ironbark" "sRGB:109/77/44" 620) ("iron" "sRGB:203/205/205" 619) ("iroko" "sRGB:91/82/68" 618) ("irishcoffee" "sRGB:98/66/43" 617) ("indochine" "sRGB:156/91/52" 616) ("indiantan" "sRGB:79/48/31" 615) ("illusion" "sRGB:239/149/174" 614) ("iceberg" "sRGB:202/225/217" 613) ("icecold" "sRGB:175/227/214" 612) ("husk" "sRGB:178/153/75" 611) ("hurricane" "sRGB:139/126/119" 610) ("huntergreen" "sRGB:47/49/37" 609) ("hummingbird" "sRGB:206/239/228" 608) ("hottoddy" "sRGB:167/117/44" 607) ("hotpurple" "sRGB:78/46/83" 606) ("hotcurry" "sRGB:129/91/40" 605) ("hotchile" "sRGB:107/37/44" 604) ("horsesneck" "sRGB:109/86/44" 603) ("horizon" "sRGB:100/136/148" 602) ("hopbush" "sRGB:205/109/147" 601) ("honeysuckle" "sRGB:232/237/105" 600) ("honeyflower" "sRGB:92/60/109" 599) ("holly" "sRGB:37/52/43" 598) ("hoki" "sRGB:100/125/134" 597) ("hokeypokey" "sRGB:187/142/52" 596) ("hitpink" "sRGB:253/164/112" 595) ("hitgrey" "sRGB:161/169/168" 594) ("hippiepink" "sRGB:171/73/92" 593) ("hippiegreen" "sRGB:96/138/90" 592) ("hippieblue" "sRGB:73/136/154" 591) ("hintofyellow" "sRGB:246/245/215" 590) ("hintofred" "sRGB:245/239/235" 589) ("hintofgrey" "sRGB:223/221/214" 588) ("hintofgreen" "sRGB:223/241/214" 587) ("himalaya" "sRGB:115/99/48" 586) ("hillary" "sRGB:167/160/126" 585) ("highland" "sRGB:122/148/97" 584) ("highball" "sRGB:146/140/60" 583) ("hibiscus" "sRGB:179/54/84" 582) ("hemp" "sRGB:152/125/115" 581) ("hemlock" "sRGB:105/104/75" 580) ("heavymetal" "sRGB:70/71/62" 579) ("heatheredgrey" "sRGB:148/140/126" 578) ("heather" "sRGB:174/187/193" 577) ("heath" "sRGB:79/42/44" 576) ("hawkesblue" "sRGB:210/218/237" 575) ("hawaiiantan" "sRGB:153/82/43" 574) ("havelockblue" "sRGB:87/132/193" 573) ("havana" "sRGB:59/43/44" 572) ("harvestgold" "sRGB:234/183/106" 571) ("harp" "sRGB:203/206/192" 570) ("hampton" "sRGB:232/212/162" 569) ("halfspanishwhite" "sRGB:230/219/199" 568) ("halfpearllusta" "sRGB:241/234/215" 567) ("halfdutchwhite" "sRGB:251/240/214" 566) ("halfcolonialwhite" "sRGB:242/229/191" 565) ("halfbaked" "sRGB:85/143/147" 564) ("halfandhalf" "sRGB:237/231/200" 563) ("haiti" "sRGB:44/42/53" 562) ("hairyheath" "sRGB:99/53/40" 561) ("hacienda" "sRGB:158/128/34" 560) ("gurkha" "sRGB:152/145/113" 559) ("gunsmoke" "sRGB:122/124/118" 558) ("gunmetal" "sRGB:44/53/57" 557) ("gunpowder" "sRGB:72/71/83" 556) ("gumbo" "sRGB:113/143/138" 555) ("gumleaf" "sRGB:172/201/178" 554) ("gullgrey" "sRGB:164/173/176" 553) ("gulfstream" "sRGB:116/178/168" 552) ("gulfblue" "sRGB:52/63/92" 551) ("guardsmanred" "sRGB:149/46/49" 550) ("greysuit" "sRGB:147/145/160" 549) ("greyolive" "sRGB:161/154/127" 548) ("greynurse" "sRGB:209/211/204" 547) ("greynickel" "sRGB:189/186/174" 546) ("greygreen" "sRGB:82/86/54" 545) ("greychateau" "sRGB:159/163/167" 544) ("grenadier" "sRGB:193/77/54" 543) ("greenstone" "sRGB:36/108/70" 542) ("greenwhite" "sRGB:222/221/203" 541) ("greenwaterloo" "sRGB:44/45/36" 540) ("greenvogue" "sRGB:35/65/78" 539) ("greenspring" "sRGB:169/175/153" 538) ("greensmoke" "sRGB:156/166/100" 537) ("greenpea" "sRGB:38/98/66" 536) ("greenmist" "sRGB:191/194/152" 535) ("greenleaf" "sRGB:82/107/45" 534) ("greenkelp" "sRGB:57/61/42" 533) ("greenhouse" "sRGB:62/99/52" 532) ("gravel" "sRGB:74/75/70" 531) ("grasshopper" "sRGB:122/114/41" 530) ("graphite" "sRGB:56/52/40" 529) ("grape" "sRGB:65/61/75" 528) ("grannysmith" "sRGB:123/148/140" 527) ("grannyapple" "sRGB:197/231/205" 526) ("granitegreen" "sRGB:139/130/101" 525) ("grandis" "sRGB:255/205/115" 524) ("grainbrown" "sRGB:202/184/162" 523) ("governorbay" "sRGB:81/85/155" 522) ("gothic" "sRGB:105/136/144" 521) ("gossip" "sRGB:159/211/133" 520) ("gossamer" "sRGB:57/159/134" 519) ("gorse" "sRGB:253/227/54" 518) ("gordonsgreen" "sRGB:41/51/43" 517) ("gondola" "sRGB:55/51/50" 516) ("goldentainoi" "sRGB:255/193/82" 515) ("goldensand" "sRGB:234/206/106" 514) ("goldenglow" "sRGB:249/215/126" 513) ("goldenfizz" "sRGB:235/222/49" 512) ("goldendream" "sRGB:241/204/43" 511) ("goldenbell" "sRGB:202/129/54" 510) ("goldtips" "sRGB:226/178/39" 509) ("golddrop" "sRGB:213/108/48" 508) ("goblin" "sRGB:52/83/61" 507) ("goben" "sRGB:120/110/76" 506) ("gladegreen" "sRGB:95/129/81" 505) ("glacier" "sRGB:120/177/191" 504) ("givry" "sRGB:235/212/174" 503) ("ginfizz" "sRGB:248/234/202" 502) ("gin" "sRGB:217/223/205" 501) ("gimblet" "sRGB:185/173/97" 500) ("gigas" "sRGB:86/71/134" 499) ("ghost" "sRGB:192/191/199" 498) ("geyser" "sRGB:203/208/207" 497) ("geraldine" "sRGB:231/123/117" 496) ("genoa" "sRGB:49/121/109" 495) ("geebung" "sRGB:197/131/46" 494) ("galliano" "sRGB:216/167/35" 493) ("gallery" "sRGB:220/215/209" 492) ("gablegreen" "sRGB:44/70/65" 491) ("fuscousgrey" "sRGB:60/59/60" 490) ("fungreen" "sRGB:21/99/61" 489) ("funblue" "sRGB:51/80/131" 488) ("fuelyellow" "sRGB:209/144/51" 487) ("fuego" "sRGB:194/214/46" 486) ("fuchsia" "sRGB:123/92/183" 485) ("fruitsalad" "sRGB:75/163/81" 484) ("frostee" "sRGB:219/229/210" 483) ("frostedmint" "sRGB:226/242/228" 482) ("frost" "sRGB:225/228/197" 481) ("froly" "sRGB:229/109/117" 480) ("fringyflower" "sRGB:180/225/187" 479) ("friargrey" "sRGB:134/131/122" 478) ("frenchpass" "sRGB:164/210/224" 477) ("frenchlilac" "sRGB:222/183/217" 476) ("frenchgrey" "sRGB:191/189/193" 475) ("frangipani" "sRGB:255/215/160" 474) ("fountainblue" "sRGB:101/173/178" 473) ("forgetmenot" "sRGB:253/239/219" 472) ("forestgreen" "sRGB:51/66/49" 471) ("foggygrey" "sRGB:167/166/157" 470) ("fog" "sRGB:213/199/232" 469) ("foam" "sRGB:208/234/232" 468) ("flirt" "sRGB:122/46/77" 467) ("flint" "sRGB:113/110/97" 466) ("flax" "sRGB:130/133/98" 465) ("flamingo" "sRGB:225/99/79" 464) ("flamenco" "sRGB:234/134/69" 463) ("flamered" "sRGB:134/40/46" 462) ("flamepea" "sRGB:190/92/72" 461) ("firefly" "sRGB:49/70/67" 460) ("firebush" "sRGB:224/152/66" 459) ("fire" "sRGB:143/63/42" 458) ("fiord" "sRGB:75/90/98" 457) ("finn" "sRGB:105/69/84" 456) ("finlandia" "sRGB:97/117/91" 455) ("finch" "sRGB:117/120/90" 454) ("fijigreen" "sRGB:99/111/34" 453) ("fieryorange" "sRGB:177/89/47" 452) ("feta" "sRGB:219/224/208" 451) ("festival" "sRGB:234/204/74" 450) ("ferra" "sRGB:135/106/104" 449) ("fernfrond" "sRGB:87/94/46" 448) ("fern" "sRGB:54/92/52" 447) ("feijoa" "sRGB:165/215/133" 446) ("fedora" "sRGB:98/86/101" 445) ("fantasy" "sRGB:242/230/221" 444) ("falcon" "sRGB:110/90/91" 443) ("fairpink" "sRGB:243/229/220" 442) ("everglade" "sRGB:38/67/52" 441) ("eveningsea" "sRGB:38/96/79" 440) ("eunry" "sRGB:205/165/156" 439) ("eucalyptus" "sRGB:50/151/96" 438) ("eternity" "sRGB:45/47/40" 437) ("espresso" "sRGB:78/49/45" 436) ("equator" "sRGB:218/177/96" 435) ("envy" "sRGB:139/165/143" 434) ("englishwalnut" "sRGB:71/59/47" 433) ("englishholly" "sRGB:39/66/52" 432) ("energyyellow" "sRGB:245/215/82" 431) ("endeavour" "sRGB:41/89/139" 430) ("empress" "sRGB:124/113/115" 429) ("emperor" "sRGB:80/73/74" 428) ("eminence" "sRGB:110/57/116" 427) ("embers" "sRGB:140/63/48" 426) ("elm" "sRGB:41/123/118" 425) ("elfgreen" "sRGB:27/138/107" 424) ("elephant" "sRGB:36/54/64" 423) ("elsalva" "sRGB:143/78/69" 422) ("elpaso" "sRGB:57/57/44" 421) ("eggwhite" "sRGB:224/200/141" 420) ("eggsour" "sRGB:249/228/197" 419) ("edward" "sRGB:151/164/154" 418) ("edgewater" "sRGB:193/216/197" 417) ("eden" "sRGB:38/98/85" 416) ("ecstasy" "sRGB:201/97/56" 415) ("ecruwhite" "sRGB:214/209/192" 414) ("eclipse" "sRGB:63/57/57" 413) ("echoblue" "sRGB:164/175/205" 412) ("ebonyclay" "sRGB:50/52/56" 411) ("ebony" "sRGB:49/51/55" 410) ("ebb" "sRGB:230/216/212" 409) ("easternblue" "sRGB:0/135/159" 408) ("eastside" "sRGB:170/140/188" 407) ("eastbay" "sRGB:71/82/110" 406) ("earlydawn" "sRGB:251/242/219" 405) ("earlsgreen" "sRGB:184/167/34" 404) ("eagle" "sRGB:176/172/148" 403) ("dutchwhite" "sRGB:240/223/187" 402) ("dustygrey" "sRGB:172/155/155" 401) ("duststorm" "sRGB:229/202/192" 400) ("dune" "sRGB:81/79/74" 399) ("drover" "sRGB:251/235/155" 398) ("driftwood" "sRGB:143/111/72" 397) ("downy" "sRGB:111/210/190" 396) ("downriver" "sRGB:42/52/74" 395) ("dovegrey" "sRGB:119/118/114" 394) ("doublespanishwhite" "sRGB:210/195/163" 393) ("doublepearllusta" "sRGB:233/220/190" 392) ("doublecolonialwhite" "sRGB:228/207/153" 391) ("dorado" "sRGB:110/95/86" 390) ("donkeybrown" "sRGB:129/110/92" 389) ("donjuan" "sRGB:90/79/81" 388) ("domino" "sRGB:108/91/76" 387) ("dolphin" "sRGB:106/104/115" 386) ("dolly" "sRGB:245/241/113" 385) ("dixie" "sRGB:205/132/49" 384) ("disco" "sRGB:137/45/79" 383) ("dingley" "sRGB:96/124/71" 382) ("diesel" "sRGB:50/44/43" 381) ("diserria" "sRGB:212/145/93" 380) ("dew" "sRGB:231/242/233" 379) ("desertstorm" "sRGB:237/231/224" 378) ("desert" "sRGB:161/95/59" 377) ("derby" "sRGB:249/228/198" 376) ("deluge" "sRGB:130/114/164" 375) ("delta" "sRGB:153/155/149" 374) ("dell" "sRGB:72/101/49" 373) ("delrio" "sRGB:181/153/142" 372) ("deepteal" "sRGB:25/68/60" 371) ("deepsea" "sRGB:22/126/101" 370) ("deepoak" "sRGB:61/50/44" 369) ("deepkoamaru" "sRGB:52/52/103" 368) ("deepfir" "sRGB:25/57/37" 367) ("deepcove" "sRGB:58/78/88" 366) ("deepbronze" "sRGB:81/65/45" 365) ("deepblush" "sRGB:227/111/138" 364) ("deco" "sRGB:204/207/130" 363) ("deyork" "sRGB:133/202/135" 362) ("dawnpink" "sRGB:230/214/205" 361) ("dawn" "sRGB:159/157/145" 360) ("darktan" "sRGB:97/45/45" 359) ("darkslate" "sRGB:70/83/82" 358) ("darkrum" "sRGB:69/54/43" 357) ("darkrimu" "sRGB:112/65/40" 356) ("darkoak" "sRGB:85/52/43" 355) ("darkebony" "sRGB:55/49/43" 354) ("danube" "sRGB:91/137/192" 353) ("dallas" "sRGB:102/74/45" 352) ("daisybush" "sRGB:91/62/144" 351) ("dairycream" "sRGB:237/210/164" 350) ("daintree" "sRGB:39/63/65" 349) ("cyprus" "sRGB:15/70/69" 348) ("cuttysark" "sRGB:92/129/115" 347) ("curiousblue" "sRGB:61/133/184" 346) ("cupid" "sRGB:245/178/197" 345) ("cumulus" "sRGB:245/244/193" 344) ("cumin" "sRGB:120/68/48" 343) ("cubantan" "sRGB:54/45/38" 342) ("crusta" "sRGB:243/134/83" 341) ("crusoe" "sRGB:22/91/49" 340) ("cruise" "sRGB:180/226/213" 339) ("crowshead" "sRGB:50/49/46" 338) ("crownofthorns" "sRGB:118/60/51" 337) ("crocodile" "sRGB:112/105/80" 336) ("crete" "sRGB:119/113/43" 335) ("creole" "sRGB:57/50/39" 334) ("cremedebanane" "sRGB:224/193/97" 333) ("creamcan" "sRGB:238/192/81" 332) ("creambrulee" "sRGB:255/227/155" 331) ("craterbrown" "sRGB:77/62/60" 330) ("cranberry" "sRGB:180/56/100" 329) ("crail" "sRGB:166/86/72" 328) ("crabapple" "sRGB:135/56/47" 327) ("cowboy" "sRGB:68/55/54" 326) ("covegrey" "sRGB:52/63/92" 325) ("countygreen" "sRGB:27/75/53" 324) ("cottonseed" "sRGB:191/186/175" 323) ("costadelsol" "sRGB:98/93/42" 322) ("cosmos" "sRGB:252/213/207" 321) ("cosmic" "sRGB:121/77/96" 320) ("corvette" "sRGB:233/186/129" 319) ("cornflower" "sRGB:255/171/160" 318) ("cornharvest" "sRGB:141/112/42" 317) ("cornfield" "sRGB:248/243/196" 316) ("corn" "sRGB:223/170/40" 315) ("cork" "sRGB:90/76/66" 314) ("coriander" "sRGB:187/181/141" 313) ("corduroy" "sRGB:64/77/73" 312) ("coraltree" "sRGB:171/110/103" 311) ("coralcandy" "sRGB:245/208/201" 310) ("coral" "sRGB:192/176/147" 309) ("copperrust" "sRGB:149/82/76" 308) ("coppercanyon" "sRGB:119/66/44" 307) ("contessa" "sRGB:193/111/104" 306) ("conifer" "sRGB:177/221/82" 305) ("congobrown" "sRGB:101/77/73" 304) ("confetti" "sRGB:221/203/70" 303) ("concrete" "sRGB:210/209/205" 302) ("concord" "sRGB:130/127/121" 301) ("conch" "sRGB:160/177/174" 300) ("como" "sRGB:76/120/92" 299) ("comet" "sRGB:99/99/115" 298) ("colonialwhite" "sRGB:233/215/171" 297) ("coldturkey" "sRGB:202/181/178" 296) ("coldpurple" "sRGB:157/138/191" 295) ("cola" "sRGB:60/47/35" 294) ("cognac" "sRGB:154/70/61" 293) ("coffeebean" "sRGB:54/45/38" 292) ("coffee" "sRGB:114/103/81" 291) ("codgrey" "sRGB:45/48/50" 290) ("coconutcream" "sRGB:225/218/187" 289) ("cocoabrown" "sRGB:53/40/30" 288) ("cocoabean" "sRGB:79/56/53" 287) ("cobalt" "sRGB:39/60/90" 286) ("clover" "sRGB:71/86/47" 285) ("cloudy" "sRGB:176/169/159" 284) ("cloudburst" "sRGB:53/62/79" 283) ("cloud" "sRGB:194/188/177" 282) ("clinker" "sRGB:70/54/35" 281) ("clementine" "sRGB:193/79/59" 280) ("clearday" "sRGB:223/239/234" 279) ("claycreek" "sRGB:137/126/89" 278) ("classicrose" "sRGB:244/200/219" 277) ("claret" "sRGB:110/34/51" 276) ("clamshell" "sRGB:210/179/169" 275) ("clairvoyant" "sRGB:104/59/125" 274) ("citrus" "sRGB:159/183/10" 273) ("citron" "sRGB:142/154/33" 272) ("cioccolato" "sRGB:93/59/46" 271) ("cinnamon" "sRGB:123/72/43" 270) ("cinderella" "sRGB:251/215/204" 269) ("cinder" "sRGB:36/42/46" 268) ("cigar" "sRGB:125/78/56" 267) ("chromewhite" "sRGB:202/199/183" 266) ("christine" "sRGB:191/101/46" 265) ("christi" "sRGB:113/169/29" 264) ("christalle" "sRGB:56/33/97" 263) ("chocolate" "sRGB:61/35/39" 262) ("chinook" "sRGB:157/211/168" 261) ("chino" "sRGB:184/173/138" 260) ("chinaivory" "sRGB:251/243/211" 259) ("chileanheath" "sRGB:249/247/222" 258) ("chileanfire" "sRGB:208/94/52" 257) ("chiffon" "sRGB:240/245/187" 256) ("chicago" "sRGB:91/93/86" 255) ("chetwodeblue" "sRGB:102/111/180" 254) ("cherub" "sRGB:245/215/220" 253) ("cherrywood" "sRGB:78/49/46" 252) ("cherrypie" "sRGB:55/45/82" 251) ("cherokee" "sRGB:245/205/130" 250) ("chenin" "sRGB:222/195/113" 249) ("chelseagem" "sRGB:149/83/47" 248) ("chelseacucumber" "sRGB:136/169/91" 247) ("chathamsblue" "sRGB:44/89/113" 246) ("chatelle" "sRGB:179/171/182" 245) ("chateaugreen" "sRGB:65/159/89" 244) ("charm" "sRGB:208/116/139" 243) ("charlotte" "sRGB:164/220/230" 242) ("chardonnay" "sRGB:255/200/120" 241) ("chardon" "sRGB:248/234/223" 240) ("charade" "sRGB:57/64/67" 239) ("chantilly" "sRGB:237/184/199" 238) ("champagne" "sRGB:238/217/182" 237) ("chamois" "sRGB:232/205/154" 236) ("chambray" "sRGB:71/88/119" 235) ("chalky" "sRGB:223/194/129" 234) ("chaletgreen" "sRGB:90/110/65" 233) ("chablis" "sRGB:253/233/224" 232) ("ceramic" "sRGB:223/221/214" 231) ("cement" "sRGB:133/113/88" 230) ("celtic" "sRGB:43/63/54" 229) ("cello" "sRGB:58/78/95" 228) ("celeste" "sRGB:210/210/192" 227) ("celery" "sRGB:180/192/76" 226) ("cedar" "sRGB:70/52/48" 225) ("cesoir" "sRGB:146/113/167" 224) ("cavernpink" "sRGB:224/184/177" 223) ("catskillwhite" "sRGB:224/228/220" 222) ("catalinablue" "sRGB:39/60/90" 221) ("castro" "sRGB:68/35/47" 220) ("casper" "sRGB:170/181/184" 219) ("cashmere" "sRGB:209/179/153" 218) ("cascade" "sRGB:140/168/160" 217) ("casal" "sRGB:63/84/90" 216) ("casablanca" "sRGB:240/178/83" 215) ("carouselpink" "sRGB:248/219/224" 214) ("carnabytan" "sRGB:91/58/36" 213) ("carla" "sRGB:245/249/203" 212) ("carissma" "sRGB:230/128/149" 211) ("careyspink" "sRGB:201/154/160" 210) ("cardinal" "sRGB:138/36/78" 209) ("cardingreen" "sRGB:27/52/39" 208) ("cararra" "sRGB:235/229/213" 207) ("caramel" "sRGB:255/213/154" 206) ("capri" "sRGB:48/67/106" 205) ("caper" "sRGB:175/193/130" 204) ("capepalliser" "sRGB:117/72/47" 203) ("capehoney" "sRGB:254/224/165" 202) ("capecod" "sRGB:78/85/82" 201) ("canvas" "sRGB:163/153/119" 200) ("cannonpink" "sRGB:142/81/100" 199) ("cannonblack" "sRGB:51/44/34" 198) ("candlelight" "sRGB:224/157/55" 197) ("canary" "sRGB:226/230/77" 196) ("cancan" "sRGB:208/138/155" 195) ("camouflage" "sRGB:79/77/50" 194) ("cameo" "sRGB:204/164/131" 193) ("camelot" "sRGB:128/58/75" 192) ("camarone" "sRGB:32/105/55" 191) ("calypso" "sRGB:61/113/136" 190) ("california" "sRGB:233/140/58" 189) ("calico" "sRGB:213/177/133" 188) ("caferoyale" "sRGB:106/73/40" 187) ("cadillac" "sRGB:152/73/97" 186) ("cactus" "sRGB:91/111/85" 185) ("cabbagepont" "sRGB:76/85/68" 184) ("cabaret" "sRGB:205/82/108" 183) ("cabsav" "sRGB:74/46/50" 182) ("butterywhite" "sRGB:241/235/218" 181) ("buttermilk" "sRGB:246/224/164" 180) ("butterflybush" "sRGB:104/87/140" 179) ("butteredrum" "sRGB:157/112/46" 178) ("buttercup" "sRGB:218/148/41" 177) ("bush" "sRGB:37/70/54" 176) ("burntcrimson" "sRGB:88/33/36" 175) ("burningsand" "sRGB:208/131/99" 174) ("burnham" "sRGB:35/69/55" 173) ("burgundy" "sRGB:101/37/37" 172) ("bunting" "sRGB:43/52/73" 171) ("bunker" "sRGB:41/44/47" 170) ("bullshot" "sRGB:117/68/43" 169) ("bulgarianrose" "sRGB:72/36/39" 168) ("buddhagold" "sRGB:188/155/27" 167) ("bud" "sRGB:165/168/143" 166) ("buccaneer" "sRGB:110/81/80" 165) ("bubbles" "sRGB:230/242/234" 164) ("brownpod" "sRGB:60/36/27" 163) ("brownderby" "sRGB:89/69/55" 162) ("brownbramble" "sRGB:83/51/30" 161) ("broom" "sRGB:238/204/36" 160) ("bronzetone" "sRGB:67/76/40" 159) ("bronzeolive" "sRGB:88/76/37" 158) ("bronze" "sRGB:73/59/47" 157) ("bronco" "sRGB:167/151/129" 156) ("brightsun" "sRGB:236/189/44" 155) ("brightred" "sRGB:146/42/49" 154) ("brightgrey" "sRGB:87/89/93" 153) ("bridesmaid" "sRGB:250/230/223" 152) ("bridalheath" "sRGB:248/235/221" 151) ("breakerbay" "sRGB:81/123/120" 150) ("brazil" "sRGB:129/91/40" 149) ("brandyrose" "sRGB:182/133/122" 148) ("brandypunch" "sRGB:192/124/64" 147) ("brandy" "sRGB:220/182/138" 146) ("bracken" "sRGB:91/61/39" 145) ("bourbon" "sRGB:175/108/62" 144) ("bouquet" "sRGB:167/129/153" 143) ("boulder" "sRGB:124/129/124" 142) ("bottlegreen" "sRGB:37/70/54" 141) ("botticelli" "sRGB:146/172/180" 140) ("bostonblue" "sRGB:67/142/172" 139) ("bossanova" "sRGB:76/61/78" 138) ("bordeaux" "sRGB:76/28/36" 137) ("bone" "sRGB:219/194/171" 136) ("bondiblue" "sRGB:38/65/107" 135) ("bonjour" "sRGB:223/215/210" 134) ("bombay" "sRGB:174/174/173" 133) ("bokaragrey" "sRGB:42/39/37" 132) ("blush" "sRGB:181/80/103" 131) ("blumine" "sRGB:48/92/113" 130) ("bluezodiac" "sRGB:60/67/84" 129) ("bluewhale" "sRGB:30/52/66" 128) ("bluestone" "sRGB:22/100/97" 127) ("bluesmoke" "sRGB:120/133/122" 126) ("blueromance" "sRGB:216/240/210" 125) ("bluemarguerite" "sRGB:106/91/177" 124) ("bluelagoon" "sRGB:0/98/111" 123) ("bluehaze" "sRGB:189/186/206" 122) ("bluegem" "sRGB:75/60/142" 121) ("bluedianne" "sRGB:53/81/79" 120) ("bluediamond" "sRGB:75/45/114" 119) ("bluechill" "sRGB:64/143/144" 118) ("bluecharcoal" "sRGB:38/43/47" 117) ("bluechalk" "sRGB:227/214/233" 116) ("bluebell" "sRGB:57/45/115" 115) ("bluebayoux" "sRGB:98/119/126" 114) ("bluebark" "sRGB:30/39/44" 113) ("blossom" "sRGB:223/177/182" 112) ("bleachedcedar" "sRGB:69/70/71" 111) ("bleachwhite" "sRGB:235/225/206" 110) ("blanc" "sRGB:217/208/193" 109) ("blackwood" "sRGB:63/55/46" 108) ("blackcurrant" "sRGB:46/24/59" 107) ("blackberry" "sRGB:67/24/47" 106) ("blackwhite" "sRGB:229/228/219" 105) ("blacksqueeze" "sRGB:229/230/223" 104) ("blackrussian" "sRGB:36/37/43" 103) ("blackrose" "sRGB:83/41/52" 102) ("blackrock" "sRGB:44/45/60" 101) ("blackpepper" "sRGB:60/55/49" 100) ("blackpearl" "sRGB:30/39/44" 99) ("blackmarlin" "sRGB:56/55/64" 98) ("blackmagic" "sRGB:51/44/34" 97) ("blackhaze" "sRGB:224/222/215" 96) ("blackforest" "sRGB:44/50/39" 95) ("blackbean" "sRGB:35/46/38" 94) ("bizarre" "sRGB:231/210/200" 93) ("bitterlemon" "sRGB:210/219/50" 92) ("bitter" "sRGB:136/137/108" 91) ("bisonhide" "sRGB:181/172/148" 90) ("bismark" "sRGB:72/108/122" 89) ("biscay" "sRGB:47/60/83" 88) ("birdflower" "sRGB:208/193/23" 87) ("birch" "sRGB:63/55/38" 86) ("bilobaflower" "sRGB:174/153/210" 85) ("bilbao" "sRGB:62/128/39" 84) ("bigstone" "sRGB:51/64/70" 83) ("bianca" "sRGB:244/239/224" 82) ("berylgreen" "sRGB:188/191/168" 81) ("bermudagrey" "sRGB:111/140/159" 80) ("bermuda" "sRGB:134/210/193" 79) ("beeswax" "sRGB:233/215/171" 78) ("beautybush" "sRGB:235/185/179" 77) ("bean" "sRGB:74/53/49" 76) ("bazaar" "sRGB:143/119/119" 75) ("bayofmany" "sRGB:53/62/100" 74) ("bayleaf" "sRGB:123/177/141" 73) ("battleshipgrey" "sRGB:81/87/79" 72) ("bastille" "sRGB:44/44/50" 71) ("barossa" "sRGB:69/46/57" 70) ("barleywhite" "sRGB:247/229/183" 69) ("barleycorn" "sRGB:182/147/92" 68) ("barberry" "sRGB:210/198/31" 67) ("banjul" "sRGB:52/50/45" 66) ("bandicoot" "sRGB:135/132/102" 65) ("bamboo" "sRGB:186/111/63" 64) ("balticsea" "sRGB:60/61/62" 63) ("balihai" "sRGB:132/156/169" 62) ("bajawhite" "sRGB:240/223/187" 61) ("bahia" "sRGB:169/192/28" 60) ("bahamablue" "sRGB:37/89/127" 59) ("azure" "sRGB:78/105/154" 58) ("aztec" "sRGB:41/52/50" 57) ("azalea" "sRGB:249/192/196" 56) ("axolotl" "sRGB:99/119/90" 55) ("avocado" "sRGB:149/152/107" 54) ("australianmint" "sRGB:239/248/170" 53) ("aubergine" "sRGB:55/37/40" 52) ("auchico" "sRGB:158/103/89" 51) ("atomic" "sRGB:61/75/82" 50) ("atoll" "sRGB:43/121/122" 49) ("atlantis" "sRGB:156/208/59" 48) ("athsspecial" "sRGB:213/203/178" 47) ("athensgrey" "sRGB:220/221/221" 46) ("astronautblue" "sRGB:33/69/89" 45) ("astronaut" "sRGB:68/81/114" 44) ("astral" "sRGB:55/111/137" 43) ("astra" "sRGB:237/213/166" 42) ("asphalt" "sRGB:42/41/34" 41) ("ashbrown" "sRGB:73/63/47" 40) ("ash" "sRGB:190/186/167" 39) ("arrowtown" "sRGB:130/122/103" 38) ("armadillo" "sRGB:72/74/70" 37) ("arapawa" "sRGB:39/74/93" 36) ("aquamarine" "sRGB:32/89/72" 35) ("aquasqueeze" "sRGB:219/228/220" 34) ("aquaspring" "sRGB:232/243/232" 33) ("aquahaze" "sRGB:217/221/213" 32) ("aqua" "sRGB:146/211/202" 31) ("apricotwhite" "sRGB:247/240/219" 30) ("apricot" "sRGB:228/143/103" 29) ("applegreen" "sRGB:222/234/220" 28) ("appleblossom" "sRGB:169/82/73" 27) ("apple" "sRGB:102/179/72" 26) ("apache" "sRGB:211/169/92" 25) ("anzac" "sRGB:198/142/63" 24) ("antiquebrass" "sRGB:108/70/31" 23) ("anakiwa" "sRGB:140/206/234" 22) ("amulet" "sRGB:125/157/114" 21) ("amour" "sRGB:245/230/234" 20) ("amethystsmoke" "sRGB:149/135/156" 19) ("americano" "sRGB:138/125/114" 18) ("amazon" "sRGB:56/123/84" 17) ("aluminium" "sRGB:132/135/137" 16) ("alto" "sRGB:205/198/197" 15) ("alpine" "sRGB:173/138/59" 14) ("almondfrost" "sRGB:154/134/120" 13) ("allports" "sRGB:31/106/125" 12) ("alerttan" "sRGB:149/78/44" 11) ("albescentwhite" "sRGB:225/218/203" 10) ("alabaster" "sRGB:242/240/230" 9) ("akaroa" "sRGB:190/178/154" 8) ("afghantan" "sRGB:144/94/38" 7) ("affair" "sRGB:116/80/133" 6) ("aeroblue" "sRGB:192/232/213" 5) ("acorn" "sRGB:115/99/48" 4) ("acapulco" "sRGB:117/170/148" 3) ("acadia" "sRGB:53/49/44" 2) ("abbey" "sRGB:73/81/84" 1) ) (7 (3 #f order #f ordinal) (2 #f color #f string) (1 #t name #f string) ) (6 ("red" "CIEXYZ:0.639974/0.219285/0.140741" 19) ("purplishred" "CIEXYZ:0.292779/0.0595298/0.647691" 18) ("redpurple" "CIEXYZ:0.224491/0.0281085/0.7474" 17) ("reddishpurple" "CIEXYZ:0.195341/0.0146953/0.789964" 16) ("purple" "CIEXYZ:0.180159/0.00770975/0.812132" 15) ("bluishpurple" "CIEXYZ:0.174724/0.00520914/0.820067" 14) ("purplishblue" "CIEXYZ:0.150985/0.0227402/0.826274" 13) ("blue" "CIEXYZ:0.116102/0.0738583/0.81004" 12) ("greenishblue" "CIEXYZ:0.0833989/0.156445/0.760156" 11) ("bluegreen" "CIEXYZ:0.0234599/0.412703/0.563837" 10) ("bluishgreen" "CIEXYZ:0.00816803/0.538423/0.453409" 9) ("green" "CIEXYZ:0.0388518/0.812016/0.149132" 8) ("yellowishgreen" "CIEXYZ:0.337396/0.658848/0.00375544" 7) ("yellowgreen" "CIEXYZ:0.380466/0.617256/0.00227802" 6) ("greenishyellow" "CIEXYZ:0.465098/0.5338/0.00110199" 5) ("yellow" "CIEXYZ:0.505818/0.493217/0.000965024" 4) ("yellowishorange" "CIEXYZ:0.531897/0.467256/0.000847751" 3) ("orange" "CIEXYZ:0.602933/0.396497/0.000570581" 2) ("reddishorange" "CIEXYZ:0.658471/0.341258/0.000271188" 1) ) (5 (3 #f order #f ordinal) (2 #f color #f string) (1 #t name #f string) ) (4 (uint #f (lambda (x) (and (integer? x) (not (negative? x)))) number #f) (base-id #f number? ordinal #f) (number #f number? number #f) (domain *domains-data* #f atom #f) (atom #f (lambda (x) (or (not x) (symbol? x))) atom #f) (string #f string? string #f) (symbol #f symbol? symbol #f) (expression #f #f expression #f) (boolean #f boolean? boolean #f) (ordinal #f (lambda (x) (and (integer? x) (positive? x))) number #f) (type #f symbol? symbol #f) ) (3 (6 #f view-procedure #f expression) (5 #f user-integrity-rule #f expression) (4 #f bastab-id #f ordinal) (3 #f coltab-name #f symbol) (2 #f column-limit #f ordinal) (1 #t table-name #f symbol) ) (2 (5 #f type-param #f expression) (4 #f type-id #f type) (3 #f domain-integrity-rule #f expression) (2 #f foreign-table #f atom) (1 #t domain-name #f symbol) ) (1 (5 #f domain-name #f domain) (4 #f column-integrity-rule #f expression) (3 #f column-name #f symbol) (2 #f primary-key? #f boolean) (1 #t column-number #f ordinal) ) (0 (nbs-iscc 3 desc:nbs-iscc 10 #f #f) (desc:nbs-iscc 5 *columns* 9 #f #f) (resene 3 desc:resene 8 #f #f) (desc:resene 5 *columns* 7 #f #f) (saturate 3 desc:saturate 6 #f #f) (desc:saturate 5 *columns* 5 #f #f) (*columns* 5 *columns* 1 #f #f) (*domains-data* 5 *domains-desc* 4 #f #f) (*catalog-data* 6 *catalog-desc* 0 #f #f) (*domains-desc* 5 *columns* 2 #f #f) (*catalog-desc* 5 *columns* 3 #f #f) ) (*base-resources* (free-id 11) ) ) slib-3b1/cltime.scm0000644001705200017500000000454010173630172012154 0ustar tbtb;;;; "cltime.scm" Common-Lisp time conversion routines. ;;; Copyright (C) 1994, 1997 Aubrey Jaffer ; ;Permission to copy this software, to modify it, to redistribute it, ;to distribute modified versions, and to use it for any purpose is ;granted, subject to the following restrictions and understandings. ; ;1. Any copy made of this software must include this copyright notice ;in full. ; ;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; ;3. In conjunction with products arising from the use of this ;material, there shall be no use of my name in any advertising, ;promotional, or sales literature without prior written consent in ;each case. (require 'values) (require 'time-core) (require 'time-zone) (define time:1900 (time:invert (lambda (tm) (time:split tm 0 0 "GMT")) ;time:gmtime '#(0 0 0 1 0 0 #f #f 0 0 "GMT"))) ;@ (define (get-decoded-time) (decode-universal-time (get-universal-time))) ;@ (define (get-universal-time) (difftime (current-time) time:1900)) ;@ (define (decode-universal-time utime . tzarg) (let ((tv (apply time:split (offset-time time:1900 utime) (if (null? tzarg) (tz:params utime (time-zone (getenv "TZ"))) (list 0 (* 3600 (car tzarg)) "???"))))) (values (vector-ref tv 0) ;second [0..59] (vector-ref tv 1) ;minute [0..59] (vector-ref tv 2) ;hour [0..23] (vector-ref tv 3) ;date [1..31] (+ 1 (vector-ref tv 4)) ;month [1..12] (+ 1900 (vector-ref tv 5)) ;year [0....] (modulo (+ -1 (vector-ref tv 6)) 7) ;day-of-week [0..6] (0 is Monday) (eqv? 1 (vector-ref tv 8)) ;daylight-saving-time? (if (provided? 'inexact) (inexact->exact (/ (vector-ref tv 9) 3600)) (/ (vector-ref tv 9) 3600)) ;time-zone [-24..24] ))) ;@ (define (encode-universal-time second minute hour date month year . tzarg) (let* ((tz (time-zone (if (null? tzarg) (getenv "TZ") (string-append "???" (number->string (car tzarg)))))) (tv (vector second minute hour date (+ -1 month) (+ -1900 year) #f ;ignored #f ;ignored ))) (difftime (time:invert (lambda (tm) (apply time:split tm (tz:params tm tz))) ;localtime tv) time:1900))) slib-3b1/coerce.scm0000644001705200017500000000724210065361267012147 0ustar tbtb;;"coerce.scm" Scheme Implementation of COMMON-LISP COERCE and TYPE-OF. ; Copyright (C) 1995, 2001 Aubrey Jaffer ; ;Permission to copy this software, to modify it, to redistribute it, ;to distribute modified versions, and to use it for any purpose is ;granted, subject to the following restrictions and understandings. ; ;1. Any copy made of this software must include this copyright notice ;in full. ; ;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; ;3. In conjunction with products arising from the use of this ;material, there shall be no use of my name in any advertising, ;promotional, or sales literature without prior written consent in ;each case. (require-if 'compiling 'array) ;;@body ;;Returns a symbol name for the type of @1. (define (type-of obj) (cond ((boolean? obj) 'boolean) ((char? obj) 'char) ((number? obj) 'number) ((string? obj) 'string) ((symbol? obj) 'symbol) ((input-port? obj) 'port) ((output-port? obj) 'port) ((procedure? obj) 'procedure) ((eof-object? obj) 'eof-object) ((list? obj) 'list) ((pair? obj) 'pair) ((vector? obj) 'vector) ((and (provided? 'array) (array? obj)) 'array) (else '?))) ;;@body ;;Converts and returns @1 of type @code{char}, @code{number}, ;;@code{string}, @code{symbol}, @code{list}, or @code{vector} to ;;@2 (which must be one of these symbols). (define (coerce obj result-type) (define (err) (slib:error 'coerce 'not obj '-> result-type)) (define obj-type (type-of obj)) (cond ((eq? obj-type result-type) obj) (else (case obj-type ((char) (case result-type ((number integer) (char->integer obj)) ((string) (string obj)) ((symbol) (string->symbol (string obj))) ((list) (list obj)) ((vector) (vector obj)) (else (err)))) ((number) (case result-type ((char) (integer->char obj)) ((atom) obj) ((integer) obj) ((string) (number->string obj)) ((symbol) (string->symbol (number->string obj))) ((list) (string->list (number->string obj))) ((vector) (list->vector (string->list (number->string obj)))) (else (err)))) ((string) (case result-type ((char) (if (= 1 (string-length obj)) (string-ref obj 0) (err))) ((atom) (or (string->number obj) (string->symbol obj))) ((number integer) (or (string->number obj) (err))) ((symbol) (string->symbol obj)) ((list) (string->list obj)) ((vector) (list->vector (string->list obj))) (else (err)))) ((symbol) (case result-type ((char) (coerce (symbol->string obj) 'char)) ((number integer) (coerce (symbol->string obj) 'number)) ((string) (symbol->string obj)) ((atom) obj) ((list) (string->list (symbol->string obj))) ((vector) (list->vector (string->list (symbol->string obj)))) (else (err)))) ((list) (case result-type ((char) (if (and (= 1 (length obj)) (char? (car obj))) (car obj) (err))) ((number integer) (or (string->number (list->string obj)) (err))) ((string) (list->string obj)) ((symbol) (string->symbol (list->string obj))) ((vector) (list->vector obj)) (else (err)))) ((vector) (case result-type ((char) (if (and (= 1 (vector-length obj)) (char? (vector-ref obj 0))) (vector-ref obj 0) (err))) ((number integer) (or (string->number (coerce obj string)) (err))) ((string) (list->string (vector->list obj))) ((symbol) (string->symbol (coerce obj string))) ((list) (list->vector obj)) (else (err)))) (else (err)))))) slib-3b1/coerce.txi0000644001705200017500000000047010747237373012174 0ustar tbtb @defun type-of obj Returns a symbol name for the type of @var{obj}. @end defun @defun coerce obj result-type Converts and returns @var{obj} of type @code{char}, @code{number}, @code{string}, @code{symbol}, @code{list}, or @code{vector} to @var{result-type} (which must be one of these symbols). @end defun slib-3b1/collect.scm0000644001705200017500000001512710602606276012334 0ustar tbtb;"collect.scm" Sample collection operations ; COPYRIGHT (c) Kenneth Dickey 1992 ; ; This software may be used for any purpose whatever ; without warranty of any kind. ; AUTHOR Ken Dickey ; DATE 1992 September 1 ; LAST UPDATED 1992 September 2 ; NOTES Expository (optimizations & checks elided). ; Requires YASOS (Yet Another Scheme Object System). (require 'object) (require 'yasos) (define collect:size size) (define collect:print print) ;@ (define-operation (collection? obj) ;; default (cond ((or (list? obj) (vector? obj) (string? obj)) #t) (else #f) ) ) ;@ (define (empty? collection) (zero? (collect:size collection))) ;@ (define-operation (gen-elts ) ;; return element generator ;; default behavior (cond ;; see utilities, below, for generators ((vector? ) (collect:vector-gen-elts )) ((list? ) (collect:list-gen-elts )) ((string? ) (collect:string-gen-elts )) (else (slib:error 'gen-elts 'operation-not-supported (collect:print #f))) ) ) ;@ (define-operation (gen-keys collection) (if (or (vector? collection) (list? collection) (string? collection)) (let ( (max+1 (collect:size collection)) (index 0) ) (lambda () (cond ((< index max+1) (set! index (collect:add1 index)) (collect:sub1 index)) (else (slib:error 'no-more 'keys 'in 'generator)) ) ) ) (slib:error 'gen-keys 'operation-not-handled collection) ) ) ;@ (define (do-elts . ) (let ( (max+1 (collect:size (car ))) (generators (map collect:gen-elts )) ) (let loop ( (counter 0) ) (cond ((< counter max+1) (apply (map (lambda (g) (g)) generators)) (loop (collect:add1 counter)) ) (else 'unspecific) ; done ) ) ) ) ;@ (define (do-keys . ) (let ( (max+1 (collect:size (car ))) (generators (map collect:gen-keys )) ) (let loop ( (counter 0) ) (cond ((< counter max+1) (apply (map (lambda (g) (g)) generators)) (loop (collect:add1 counter)) ) (else 'unspecific) ; done ) ) ) ) ;@ (define (map-elts . ) (let ( (max+1 (collect:size (car ))) (generators (map collect:gen-elts )) (vec (make-vector (collect:size (car )))) ) (let loop ( (index 0) ) (cond ((< index max+1) (vector-set! vec index (apply (map (lambda (g) (g)) generators))) (loop (collect:add1 index)) ) (else vec) ; done ) ) ) ) ;@ (define (map-keys . ) (let ( (max+1 (collect:size (car ))) (generators (map collect:gen-keys )) (vec (make-vector (collect:size (car )))) ) (let loop ( (index 0) ) (cond ((< index max+1) (vector-set! vec index (apply (map (lambda (g) (g)) generators))) (loop (collect:add1 index)) ) (else vec) ; done ) ) ) ) ;@ (define-operation (for-each-key ) ;; default (collect:do-keys ) ;; talk about lazy! ) ;@ (define-operation (for-each-elt ) (collect:do-elts ) ) ;@ (define (reduce . ) (define (reduce-init pred? init lst) (if (null? lst) init (reduce-init pred? (pred? init (car lst)) (cdr lst)))) (if (null? ) (cond ((null? ) ) ((null? (cdr )) (car )) (else (reduce-init (car ) (cdr )))) (let ((max+1 (collect:size (car ))) (generators (map collect:gen-elts ))) (let loop ((count 0)) (cond ((< count max+1) (set! (apply (map (lambda (g) (g)) generators))) (loop (collect:add1 count))) (else )))))) ;;@ pred true for every elt? (define (every? . ) (let ( (max+1 (collect:size (car ))) (generators (map collect:gen-elts )) ) (let loop ( (count 0) ) (cond ((< count max+1) (if (apply (map (lambda (g) (g)) generators)) (loop (collect:add1 count)) #f) ) (else #t) ) ) ) ) ;;@ pred true for any elt? (define (any? . ) (let ( (max+1 (collect:size (car ))) (generators (map collect:gen-elts )) ) (let loop ( (count 0) ) (cond ((< count max+1) (if (apply (map (lambda (g) (g)) generators)) #t (loop (collect:add1 count)) )) (else #f) ) ) ) ) ;; MISC UTILITIES (define (collect:add1 obj) (+ obj 1)) (define (collect:sub1 obj) (- obj 1)) ;; Nota Bene: list-set! is bogus for element 0 (define (collect:list-set! ) (define (set-loop last this idx) (cond ((zero? idx) (set-cdr! last (cons (cdr this))) ) (else (set-loop (cdr last) (cdr this) (collect:sub1 idx))) ) ) ;; main (if (zero? ) (cons (cdr )) ;; return value (set-loop (cdr ) (collect:sub1 ))) ) (add-setter list-ref collect:list-set!) ; for (setter list-ref) ;; generator for list elements (define (collect:list-gen-elts ) (lambda () (if (null? ) (slib:error 'no-more 'list-elements 'in 'generator) (let ( (elt (car )) ) (set! (cdr )) elt)) ) ) ;; generator for vector elements (define (collect:make-vec-gen-elts ) (lambda (vec) (let ( (max+1 (collect:size vec)) (index 0) ) (lambda () (cond ((< index max+1) (set! index (collect:add1 index)) ( vec (collect:sub1 index)) ) (else #f) ) ) ) ) ) (define collect:vector-gen-elts (collect:make-vec-gen-elts vector-ref)) (define collect:string-gen-elts (collect:make-vec-gen-elts string-ref)) ;;; exports: (define collect:gen-keys gen-keys) (define collect:gen-elts gen-elts) (define collect:do-elts do-elts) (define collect:do-keys do-keys) ;; --- E O F "collect.oo" --- ;; slib-3b1/collectx.scm0000644001705200017500000002021210602606472012511 0ustar tbtb;"collect.scm" Sample collection operations ; COPYRIGHT (c) Kenneth Dickey 1992 ; ; This software may be used for any purpose whatever ; without warranty of any kind. ; AUTHOR Ken Dickey ; DATE 1992 September 1 ; LAST UPDATED 1992 September 2 ; NOTES Expository (optimizations & checks elided). ; Requires YASOS (Yet Another Scheme Object System). (require 'object) (require 'yasos) (define collect:size size) (define collect:print print) ;@ (define collection? (make-generic-method (lambda (obj!2) (cond ((or (list? obj!2) (vector? obj!2) (string? obj!2)) #t) (else #f))))) ;@ (define empty? (lambda (collection!1) (zero? (collect:size collection!1)))) ;@ (define gen-elts (make-generic-method (lambda (!2) (cond ((vector? !2) (collect:vector-gen-elts !2)) ((list? !2) (collect:list-gen-elts !2)) ((string? !2) (collect:string-gen-elts !2)) (else (slib:error 'gen-elts 'operation-not-supported (collect:print !2 #f))))))) ;@ (define gen-keys (make-generic-method (lambda (collection!2) (if (or (vector? collection!2) (list? collection!2) (string? collection!2)) (let ((max+1!3 (collect:size collection!2)) (index!3 0)) (lambda () (cond ((< index!3 max+1!3) (set! index!3 (collect:add1 index!3)) (collect:sub1 index!3)) (else (slib:error 'no-more 'keys 'in 'generator))))) (slib:error 'gen-keys 'operation-not-handled collection!2))))) ;@ (define do-elts (lambda (!1 . !1) (let ((max+1!2 (collect:size (car !1))) (generators!2 (map collect:gen-elts !1))) (let loop!4 ((counter!3 0)) (cond ((< counter!3 max+1!2) (apply !1 (map (lambda (g!5) (g!5)) generators!2)) (loop!4 (collect:add1 counter!3))) (else 'unspecific)))))) ;@ (define do-keys (lambda (!1 . !1) (let ((max+1!2 (collect:size (car !1))) (generators!2 (map collect:gen-keys !1))) (let loop!4 ((counter!3 0)) (cond ((< counter!3 max+1!2) (apply !1 (map (lambda (g!5) (g!5)) generators!2)) (loop!4 (collect:add1 counter!3))) (else 'unspecific)))))) ;@ (define map-elts (lambda (!1 . !1) (let ((max+1!2 (collect:size (car !1))) (generators!2 (map collect:gen-elts !1)) (vec!2 (make-vector (collect:size (car !1))))) (let loop!4 ((index!3 0)) (cond ((< index!3 max+1!2) (vector-set! vec!2 index!3 (apply !1 (map (lambda (g!5) (g!5)) generators!2))) (loop!4 (collect:add1 index!3))) (else vec!2)))))) ;@ (define map-keys (lambda (!1 . !1) (let ((max+1!2 (collect:size (car !1))) (generators!2 (map collect:gen-keys !1)) (vec!2 (make-vector (collect:size (car !1))))) (let loop!4 ((index!3 0)) (cond ((< index!3 max+1!2) (vector-set! vec!2 index!3 (apply !1 (map (lambda (g!5) (g!5)) generators!2))) (loop!4 (collect:add1 index!3))) (else vec!2)))))) ;@ (define for-each-key (make-generic-method (lambda (!2 !2) (collect:do-keys !2 !2)))) ;@ (define for-each-elt (make-generic-method (lambda (!2 !2) (collect:do-elts !2 !2)))) ;@ (define reduce (lambda (!1 !1 . !1) (letrec ((reduce-init!3 (lambda (pred?!8 init!8 lst!8) (if (null? lst!8) init!8 (reduce-init!3 pred?!8 (pred?!8 init!8 (car lst!8)) (cdr lst!8)))))) (if (null? !1) (cond ((null? !1) !1) ((null? (cdr !1)) (car !1)) (else (reduce-init!3 !1 (car !1) (cdr !1)))) (let ((max+1!4 (collect:size (car !1))) (generators!4 (map collect:gen-elts !1))) (let loop!6 ((count!5 0)) (cond ((< count!5 max+1!4) (set! !1 (apply !1 !1 (map (lambda (g!7) (g!7)) generators!4))) (loop!6 (collect:add1 count!5))) (else !1)))))))) ;;@ pred true for every elt? (define every? (lambda (!1 . !1) (let ((max+1!2 (collect:size (car !1))) (generators!2 (map collect:gen-elts !1))) (let loop!4 ((count!3 0)) (cond ((< count!3 max+1!2) (if (apply !1 (map (lambda (g!5) (g!5)) generators!2)) (loop!4 (collect:add1 count!3)) #f)) (else #t)))))) ;;@ pred true for any elt? (define any? (lambda (!1 . !1) (let ((max+1!2 (collect:size (car !1))) (generators!2 (map collect:gen-elts !1))) (let loop!4 ((count!3 0)) (cond ((< count!3 max+1!2) (if (apply !1 (map (lambda (g!5) (g!5)) generators!2)) #t (loop!4 (collect:add1 count!3)))) (else #f)))))) ;; MISC UTILITIES (define collect:add1 (lambda (obj!1) (+ obj!1 1))) (define collect:sub1 (lambda (obj!1) (- obj!1 1))) ;; Nota Bene: list-set! is bogus for element 0 (define collect:list-set! (lambda (!1 !1 !1) (letrec ((set-loop!3 (lambda (last!4 this!4 idx!4) (cond ((zero? idx!4) (set-cdr! last!4 (cons !1 (cdr this!4))) !1) (else (set-loop!3 (cdr last!4) (cdr this!4) (collect:sub1 idx!4))))))) (if (zero? !1) (cons !1 (cdr !1)) (set-loop!3 !1 (cdr !1) (collect:sub1 !1)))))) (add-setter list-ref collect:list-set!) ; for (setter list-ref) ;; generator for list elements (define collect:list-gen-elts (lambda (!1) (lambda () (if (null? !1) (slib:error 'no-more 'list-elements 'in 'generator) (let ((elt!3 (car !1))) (begin (set! !1 (cdr !1)) elt!3)))))) ;; generator for vector elements (define collect:make-vec-gen-elts (lambda (!1) (lambda (vec!2) (let ((max+1!3 (collect:size vec!2)) (index!3 0)) (lambda () (cond ((< index!3 max+1!3) (set! index!3 (collect:add1 index!3)) (!1 vec!2 (collect:sub1 index!3))) (else #f))))))) (define collect:vector-gen-elts (collect:make-vec-gen-elts vector-ref)) (define collect:string-gen-elts (collect:make-vec-gen-elts string-ref)) ;;; exports: (define collect:gen-keys gen-keys) (define collect:gen-elts gen-elts) (define collect:do-elts do-elts) (define collect:do-keys do-keys) ;; --- E O F "collect.oo" --- ;; slib-3b1/colornam.scm0000644001705200017500000001023407747576601012531 0ustar tbtb;;; "colornam.scm" color name databases ;Copyright 2001, 2002 Aubrey Jaffer ; ;Permission to copy this software, to modify it, to redistribute it, ;to distribute modified versions, and to use it for any purpose is ;granted, subject to the following restrictions and understandings. ; ;1. Any copy made of this software must include this copyright notice ;in full. ; ;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; ;3. In conjunction with products arising from the use of this ;material, there shall be no use of my name in any advertising, ;promotional, or sales literature without prior written consent in ;each case. (require 'databases) (require 'color) ;;@code{(require 'color-names)} ;;@ftindex color-names ;;@noindent ;;Rather than ballast the color dictionaries with numbered grays, ;;@code{file->color-dictionary} discards them. They are provided ;;through the @code{grey} procedure: ;;@body ;;Returns @code{(inexact->exact (round (* k 2.55)))}, the X11 color ;;grey@i{}. (define (grey k) (define int (inexact->exact (round (* k 2.55)))) (color:sRGB int int int)) ;;@noindent ;;A color dictionary is a database table relating @dfn{canonical} ;;color-names to color-strings ;;(@pxref{Color Data-Type, External Representation}). ;; ;;@noindent ;;The column names in a color dictionary are unimportant; the first ;;field is the key, and the second is the color-string. ;;@body Returns a downcased copy of the string or symbol @1 with ;;@samp{_}, @samp{-}, and whitespace removed. (define (color-name:canonicalize name) (list->string (apply append (map (lambda (c) (if (or (char-alphabetic? c) (char-numeric? c)) (list (char-downcase c)) '())) (string->list (if (symbol? name) (symbol->string name) name)))))) ;;@args name table1 table2 @dots{} ;; ;;@2, @3, @dots{} must be color-dictionary tables. @0 searches for the ;;canonical form of @1 in @2, @3, @dots{} in order; returning the ;;color-string of the first matching record; #f otherwise. (define (color-name->color name . tables) (define cancol (color-name:canonicalize name)) (define found #f) (do ((tabs tables (cdr tabs))) ((or found (null? tabs)) (and found (string->color found))) (set! found (((car tabs) 'get 2) cancol)))) ;;@args table1 table2 @dots{} ;; ;;@1, @2, @dots{} must be color-dictionary tables. @0 returns a ;;procedure which searches for the canonical form of its string argument ;;in @1, @2, @dots{}; returning the color-string of the first matching ;;record; and #f otherwise. (define (color-dictionaries->lookup . tables) (define procs (map (lambda (tab) (tab 'get 2)) tables)) (lambda (name) (define cancol (color-name:canonicalize name)) (define found #f) (do ((procs procs (cdr procs))) ((or found (null? procs)) (and found (string->color found))) (set! found ((car procs) cancol))))) ;;@args name rdb base-table-type ;; ;;@2 must be a string naming a relational database file; and the symbol ;;@1 a table therein. The database will be opened as ;;@var{base-table-type}. @0 returns the read-only table @1 in database ;;@1 if it exists; #f otherwise. ;; ;;@args name rdb ;; ;;@2 must be an open relational database or a string naming a relational ;;database file; and the symbol @1 a table therein. @0 returns the ;;read-only table @1 in database @1 if it exists; #f otherwise. (define (color-dictionary table-name . *db*) (define rdb (apply open-database *db*)) (and rdb ((rdb 'open-table) table-name #f))) ;;@args name rdb base-table-type ;;@args name rdb ;; ;;@2 must be a string naming a relational database file; and the symbol ;;@1 a table therein. If the symbol @3 is provided, the database will ;;be opened as @3. @0 creates a top-level definition of the symbol @1 ;;to a lookup procedure for the color dictionary @1 in @2. ;; ;;The value returned by @0 is unspecified. (define (load-color-dictionary table-name . db) (slib:eval `(define ,table-name (color-dictionaries->lookup (color-dictionary ',table-name ,@(map (lambda (arg) (list 'quote arg)) db)))))) slib-3b1/colornam.txi0000644001705200017500000000515210747237372012547 0ustar tbtb@code{(require 'color-names)} @ftindex color-names @noindent Rather than ballast the color dictionaries with numbered grays, @code{file->color-dictionary} discards them. They are provided through the @code{grey} procedure: @defun grey k Returns @code{(inexact->exact (round (* k 2.55)))}, the X11 color grey@i{}. @end defun @noindent A color dictionary is a database table relating @dfn{canonical} @cindex canonical color-names to color-strings (@pxref{Color Data-Type, External Representation}). @noindent The column names in a color dictionary are unimportant; the first field is the key, and the second is the color-string. @defun color-name:canonicalize name Returns a downcased copy of the string or symbol @var{name} with @samp{_}, @samp{-}, and whitespace removed. @end defun @defun color-name->color name table1 table2 @dots{} @var{table1}, @var{table2}, @dots{} must be color-dictionary tables. @code{color-name->color} searches for the canonical form of @var{name} in @var{table1}, @var{table2}, @dots{} in order; returning the color-string of the first matching record; #f otherwise. @end defun @defun color-dictionaries->lookup table1 table2 @dots{} @var{table1}, @var{table2}, @dots{} must be color-dictionary tables. @code{color-dictionaries->lookup} returns a procedure which searches for the canonical form of its string argument in @var{table1}, @var{table2}, @dots{}; returning the color-string of the first matching record; and #f otherwise. @end defun @defun color-dictionary name rdb base-table-type @var{rdb} must be a string naming a relational database file; and the symbol @var{name} a table therein. The database will be opened as @var{base-table-type}. @code{color-dictionary} returns the read-only table @var{name} in database @var{name} if it exists; #f otherwise. @defunx color-dictionary name rdb @var{rdb} must be an open relational database or a string naming a relational database file; and the symbol @var{name} a table therein. @code{color-dictionary} returns the read-only table @var{name} in database @var{name} if it exists; #f otherwise. @end defun @defun load-color-dictionary name rdb base-table-type @defunx load-color-dictionary name rdb @var{rdb} must be a string naming a relational database file; and the symbol @var{name} a table therein. If the symbol @var{base-table-type} is provided, the database will be opened as @var{base-table-type}. @code{load-color-dictionary} creates a top-level definition of the symbol @var{name} to a lookup procedure for the color dictionary @var{name} in @var{rdb}. The value returned by @code{load-color-dictionary} is unspecified. @end defun slib-3b1/color.scm0000644001705200017500000005631610227335544012032 0ustar tbtb;;; "color.scm" color data-type ;Copyright 2001, 2002 Aubrey Jaffer ; ;Permission to copy this software, to modify it, to redistribute it, ;to distribute modified versions, and to use it for any purpose is ;granted, subject to the following restrictions and understandings. ; ;1. Any copy made of this software must include this copyright notice ;in full. ; ;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; ;3. In conjunction with products arising from the use of this ;material, there shall be no use of my name in any advertising, ;promotional, or sales literature without prior written consent in ;each case. (require 'record) (require 'color-space) (require 'scanf) (require 'printf) (require 'string-case) (define color:rtd (make-record-type "color" '(encoding ;symbol coordinates ;list of coordinates parameter ;white-point or precision ))) (define color:construct (record-constructor color:rtd '(encoding coordinates parameter))) (define color:encoding (record-accessor color:rtd 'encoding)) (define color:coordinates (record-accessor color:rtd 'coordinates)) (define color:parameter (record-accessor color:rtd 'parameter)) (define color:precision color:parameter) (define color:color? (record-predicate color:rtd)) (define (color:white-point color) (case (color:encoding color) ((CIEXYZ RGB709 sRGB xRGB e-sRGB) CIEXYZ:D65) ((L*a*b* L*u*v* L*C*h) (or (color:parameter color) CIEXYZ:D65)))) ;;@subsubheading Measurement-based Color Spaces (define (color:helper num-of-nums name list->color) (lambda args (define cnt 0) (for-each (lambda (x) (if (and (< cnt num-of-nums) (not (real? x))) (slib:error name ': 'wrong-type x)) (set! cnt (+ 1 cnt))) args) (or (list->color args) (slib:error name ': 'out-of-range args)))) ;;@noindent ;;@cindex tristimulus ;;The @dfn{tristimulus} color spaces are those whose component values ;;are proportional measurements of light intensity. The CIEXYZ(1931) ;;system provides 3 sets of spectra to dot-product with a spectrum of ;;interest. The result of those dot-products is coordinates in CIEXYZ ;;space. All tristimuls color spaces are related to CIEXYZ by linear ;;transforms, namely matrix multiplication. Of the color spaces listed ;;here, CIEXYZ and RGB709 are tristimulus spaces. ;;@deftp {Color Space} CIEXYZ ;;The CIEXYZ color space covers the full @dfn{gamut}. ;;It is the basis for color-space conversions. ;; ;;CIEXYZ is a list of three inexact numbers between 0.0 and 1.1. ;;'(0. 0. 0.) is black; '(1. 1. 1.) is white. ;;@end deftp ;;@body ;;@1 must be a list of 3 numbers. If @1 is valid CIEXYZ coordinates, ;;then @0 returns the color specified by @1; otherwise returns #f. (define (CIEXYZ->color XYZ) (and (eqv? 3 (length XYZ)) (apply (lambda (x y z) (and (real? x) (<= -0.001 x) (real? y) (<= -0.001 y 1.001) (real? z) (<= -0.001 z) (color:construct 'CIEXYZ XYZ #f))) XYZ))) ;;@args x y z ;;Returns the CIEXYZ color composed of @1, @2, @3. If the ;;coordinates do not encode a valid CIEXYZ color, then an error is ;;signaled. (define color:CIEXYZ (color:helper 3 'color:CIEXYZ CIEXYZ->color)) ;;@body Returns the list of 3 numbers encoding @1 in CIEXYZ. (define (color->CIEXYZ color) (if (not (color:color? color)) (slib:error 'color->CIEXYZ ': 'not 'color? color)) (case (color:encoding color) ((CIEXYZ) (append (color:coordinates color) '())) ((RGB709) (RGB709->CIEXYZ (color:coordinates color))) ((L*a*b*) (L*a*b*->CIEXYZ (color:coordinates color) (color:white-point color))) ((L*u*v*) (L*u*v*->CIEXYZ (color:coordinates color) (color:white-point color))) ((sRGB) (sRGB->CIEXYZ (color:coordinates color))) ((e-sRGB) (e-sRGB->CIEXYZ (color:precision color) (color:coordinates color))) ((L*C*h) (L*a*b*->CIEXYZ (L*C*h->L*a*b* (color:coordinates color)) (color:white-point color))) (else (slib:error 'color->CIEXYZ ': (color:encoding color) color)))) ;;@deftp {Color Space} RGB709 ;;BT.709-4 (03/00) @cite{Parameter values for the HDTV standards for ;;production and international programme exchange} specifies parameter ;;values for chromaticity, sampling, signal format, frame rates, etc., of ;;high definition television signals. ;; ;;An RGB709 color is represented by a list of three inexact numbers ;;between 0.0 and 1.0. '(0. 0. 0.) is black '(1. 1. 1.) is white. ;;@end deftp ;;@body ;;@1 must be a list of 3 numbers. If @1 is valid RGB709 coordinates, ;;then @0 returns the color specified by @1; otherwise returns #f. (define (RGB709->color RGB) (and (eqv? 3 (length RGB)) (apply (lambda (r g b) (and (real? r) (<= -0.001 r 1.001) (real? g) (<= -0.001 g 1.001) (real? b) (<= -0.001 b 1.001) (color:construct 'RGB709 RGB #f))) RGB))) ;;@args r g b ;;Returns the RGB709 color composed of @1, @2, @3. If the ;;coordinates do not encode a valid RGB709 color, then an error is ;;signaled. (define color:RGB709 (color:helper 3 'color:RGB709 RGB709->color)) ;;@body Returns the list of 3 numbers encoding @1 in RGB709. (define (color->RGB709 color) (if (not (color:color? color)) (slib:error 'color->RGB709 ': 'not 'color? color)) (case (color:encoding color) ((RGB709) (append (color:coordinates color) '())) ((CIEXYZ) (CIEXYZ->RGB709 (color:coordinates color))) (else (CIEXYZ->RGB709 (color->CIEXYZ color))))) ;;@subsubheading Perceptual Uniformity ;;@noindent ;;Although properly encoding the chromaticity, tristimulus spaces do not ;;match the logarithmic response of human visual systems to intensity. ;;Minimum detectable differences between colors correspond to a smaller ;;range of distances (6:1) in the L*a*b* and L*u*v* spaces than in ;;tristimulus spaces (80:1). For this reason, color distances are ;;computed in L*a*b* (or L*C*h). ;;@deftp {Color Space} L*a*b* ;;Is a CIE color space which better matches the human visual system's ;;perception of color. It is a list of three numbers: ;;@itemize @bullet ;;@item ;;0 <= L* <= 100 (CIE @dfn{Lightness}) ;;@item ;;-500 <= a* <= 500 ;;@item ;;-200 <= b* <= 200 ;;@end itemize ;;@end deftp ;;@args L*a*b* white-point ;;@1 must be a list of 3 numbers. If @1 is valid L*a*b* coordinates, ;;then @0 returns the color specified by @1; otherwise returns #f. (define (L*a*b*->color L*a*b* . white-point) (and (list? L*a*b*) (eqv? 3 (length L*a*b*)) (<= 0 (length white-point) 1) (apply (lambda (L* a* b*) (and (real? L*) (<= 0 L* 100) (real? a*) (<= -500 a* 500) (real? b*) (<= -200 b* 200) (color:construct 'L*a*b* L*a*b* (if (null? white-point) #f (color->CIEXYZ (car white-point)))))) L*a*b*))) ;;@args L* a* b* white-point ;;Returns the L*a*b* color composed of @1, @2, @3 with @4. ;;@args L* a* b* ;;Returns the L*a*b* color composed of @1, @2, @3. If the coordinates ;;do not encode a valid L*a*b* color, then an error is signaled. (define color:L*a*b* (color:helper 3 'color:L*a*b* L*a*b*->color)) ;;@args color white-point ;;Returns the list of 3 numbers encoding @1 in L*a*b* with @2. ;;@args color ;;Returns the list of 3 numbers encoding @1 in L*a*b*. (define (color->L*a*b* color . white-point) (define (wp) (if (null? white-point) CIEXYZ:D65 (color:coordinates (car white-point)))) (if (not (color:color? color)) (slib:error 'color->L*a*b* ': 'not 'color? color)) (case (color:encoding color) ((L*a*b*) (if (equal? (wp) (color:white-point color)) (append (color:coordinates color) '()) (CIEXYZ->L*a*b* (L*a*b*->CIEXYZ color (color:white-point color)) (wp)))) ((L*u*v*) (CIEXYZ->L*a*b* (L*u*v*->CIEXYZ (color:coordinates color) (color:white-point color)) (wp))) ((L*C*h) (if (equal? (wp) (color:white-point color)) (L*C*h->L*a*b* (color:coordinates color)) (CIEXYZ->L*a*b* (L*a*b*->CIEXYZ (L*C*h->L*a*b* (color:coordinates color)) (color:white-point color)) (wp)))) ((CIEXYZ) (CIEXYZ->L*a*b* (color:coordinates color) (wp))) (else (CIEXYZ->L*a*b* (color->CIEXYZ color) (wp))))) ;;@deftp {Color Space} L*u*v* ;;Is another CIE encoding designed to better match the human visual ;;system's perception of color. ;;@end deftp ;;@args L*u*v* white-point ;;@1 must be a list of 3 numbers. If @1 is valid L*u*v* coordinates, ;;then @0 returns the color specified by @1; otherwise returns #f. (define (L*u*v*->color L*u*v* . white-point) (and (list? L*u*v*) (eqv? 3 (length L*u*v*)) (<= 0 (length white-point) 1) (apply (lambda (L* u* v*) (and (real? L*) (<= 0 L* 100) (real? u*) (<= -500 u* 500) (real? v*) (<= -200 v* 200) (color:construct 'L*u*v* L*u*v* (if (null? white-point) #f (color->CIEXYZ (car white-point)))))) L*u*v*))) ;;@args L* u* v* white-point ;;Returns the L*u*v* color composed of @1, @2, @3 with @4. ;;@args L* u* v* ;;Returns the L*u*v* color composed of @1, @2, @3. If the coordinates ;;do not encode a valid L*u*v* color, then an error is signaled. (define color:L*u*v* (color:helper 3 'color:L*u*v* L*u*v*->color)) ;;@args color white-point ;;Returns the list of 3 numbers encoding @1 in L*u*v* with @2. ;;@args color ;;Returns the list of 3 numbers encoding @1 in L*u*v*. (define (color->L*u*v* color . white-point) (define (wp) (if (null? white-point) (color:white-point color) (car white-point))) (if (not (color:color? color)) (slib:error 'color->L*u*v* ': 'not 'color? color)) (case (color:encoding color) ((L*u*v*) (append (color:coordinates color) '())) ((L*a*b*) (CIEXYZ->L*u*v* (L*a*b*->CIEXYZ (color:coordinates color) (color:white-point color)) (wp))) ((L*C*h) (CIEXYZ->L*u*v* (L*a*b*->CIEXYZ (L*C*h->L*a*b* (color:coordinates color)) (color:white-point color)) (wp))) ((CIEXYZ) (CIEXYZ->L*u*v* (color:coordinates color) (wp))) (else (CIEXYZ->L*u*v* (color->CIEXYZ color) (wp))))) ;;@subsubheading Cylindrical Coordinates ;;@noindent ;;HSL (Hue Saturation Lightness), HSV (Hue Saturation Value), HSI (Hue ;;Saturation Intensity) and HCI (Hue Chroma Intensity) are cylindrical ;;color spaces (with angle hue). But these spaces are all defined in ;;terms device-dependent RGB spaces. ;;@noindent ;;One might wonder if there is some fundamental reason why intuitive ;;specification of color must be device-dependent. But take heart! A ;;cylindrical system can be based on L*a*b* and is used for predicting how ;;close colors seem to observers. ;;@deftp {Color Space} L*C*h ;;Expresses the *a and b* of L*a*b* in polar coordinates. It is a list of ;;three numbers: ;;@itemize @bullet ;;@item ;;0 <= L* <= 100 (CIE @dfn{Lightness}) ;;@item ;;C* (CIE @dfn{Chroma}) is the distance from the neutral (gray) axis. ;;@item ;;0 <= h <= 360 (CIE @dfn{Hue}) is the angle. ;;@end itemize ;; ;;The colors by quadrant of h are: ;;@multitable @columnfractions .20 .60 .20 ;;@item 0 @tab red, orange, yellow @tab 90 ;;@item 90 @tab yellow, yellow-green, green @tab 180 ;;@item 180 @tab green, cyan (blue-green), blue @tab 270 ;;@item 270 @tab blue, purple, magenta @tab 360 ;;@end multitable ;;@end deftp ;;@args L*C*h white-point ;;@1 must be a list of 3 numbers. If @1 is valid L*C*h coordinates, ;;then @0 returns the color specified by @1; otherwise returns #f. (define (L*C*h->color L*C*h . white-point) (and (list? L*C*h) (eqv? 3 (length L*C*h)) (<= 0 (length white-point) 1) (apply (lambda (L* C* h) (and (real? L*) (<= 0 L* 100) (real? C*) (<= 0 C*) (real? h) (<= 0 h 360) (color:construct 'L*C*h L*C*h (if (null? white-point) #f (color->CIEXYZ (car white-point)))))) L*C*h))) ;;@args L* C* h white-point ;;Returns the L*C*h color composed of @1, @2, @3 with @4. ;;@args L* C* h ;;Returns the L*C*h color composed of @1, @2, @3. If the coordinates ;;do not encode a valid L*C*h color, then an error is signaled. (define color:L*C*h (color:helper 3 'color:L*C*h L*C*h->color)) ;;@args color white-point ;;Returns the list of 3 numbers encoding @1 in L*C*h with @2. ;;@args color ;;Returns the list of 3 numbers encoding @1 in L*C*h. (define (color->L*C*h color . white-point) (if (not (color:color? color)) (slib:error 'color->L*C*h ': 'not 'color? color)) (if (and (eqv? 'L*C*h (color:encoding color)) (equal? (color:white-point color) (if (null? white-point) CIEXYZ:D65 (color:coordinates (car white-point))))) (append (color:coordinates color) '()) (L*a*b*->L*C*h (apply color->L*a*b* color white-point)))) ;;@subsubheading Digital Color Spaces ;;@noindent ;;The color spaces discussed so far are impractical for image data because ;;of numerical precision and computational requirements. In 1998 the IEC ;;adopted @cite{A Standard Default Color Space for the Internet - sRGB} ;;(@url{http://www.w3.org/Graphics/Color/sRGB}). sRGB was cleverly ;;designed to employ the 24-bit (256x256x256) color encoding already in ;;widespread use; and the 2.2 gamma intrinsic to CRT monitors. ;;@noindent ;;Conversion from CIEXYZ to digital (sRGB) color spaces is accomplished by ;;conversion first to a RGB709 tristimulus space with D65 white-point; ;;then each coordinate is individually subjected to the same non-linear ;;mapping. Inverse operations in the reverse order create the inverse ;;transform. ;;@deftp {Color Space} sRGB ;;Is "A Standard Default Color Space for the Internet". Most display ;;monitors will work fairly well with sRGB directly. Systems using ICC ;;profiles ;;@ftindex ICC Profile ;;@footnote{ ;;@noindent ;;A comprehensive encoding of transforms between CIEXYZ and device color ;;spaces is the International Color Consortium profile format, ;;ICC.1:1998-09: ;;@quotation ;;The intent of this format is to provide a cross-platform device profile ;;format. Such device profiles can be used to translate color data ;;created on one device into another device's native color space. ;;@end quotation ;;} ;;should work very well with sRGB. ;;An sRGB color is a triplet of integers ranging 0 to 255. D65 is the ;;white-point for sRGB. ;;@end deftp ;;@body ;;@1 must be a list of 3 numbers. If @1 is valid sRGB coordinates, ;;then @0 returns the color specified by @1; otherwise returns #f. (define (sRGB->color RGB) (and (eqv? 3 (length RGB)) (apply (lambda (r g b) (and (integer? r) (<= 0 r 255) (integer? g) (<= 0 g 255) (integer? b) (<= 0 b 255) (color:construct 'sRGB RGB #f))) RGB))) ;;@args r g b ;;Returns the sRGB color composed of @1, @2, @3. If the ;;coordinates do not encode a valid sRGB color, then an error is ;;signaled. (define color:sRGB (color:helper 3 'color:sRGB sRGB->color)) ;;@deftp {Color Space} xRGB ;;Represents the equivalent sRGB color with a single 24-bit integer. The ;;most significant 8 bits encode red, the middle 8 bits blue, and the ;;least significant 8 bits green. ;;@end deftp ;;@body ;;Returns the list of 3 integers encoding @1 in sRGB. (define (color->sRGB color) (if (not (color:color? color)) (slib:error 'color->sRGB ': 'not 'color? color)) (case (color:encoding color) ((CIEXYZ) (CIEXYZ->sRGB (color:coordinates color))) ((sRGB) (append (color:coordinates color) '())) (else (CIEXYZ->sRGB (color->CIEXYZ color))))) ;;@body Returns the 24-bit integer encoding @1 in sRGB. (define (color->xRGB color) (sRGB->xRGB (color->sRGB color))) ;;@args k ;;Returns the sRGB color composed of the 24-bit integer @1. (define (xRGB->color xRGB) (and (integer? xRGB) (<= 0 xRGB #xffffff) (sRGB->color (xRGB->sRGB xRGB)))) ;;@deftp {Color Space} e-sRGB ;;Is "Photography - Electronic still picture imaging - Extended sRGB color ;;encoding" (PIMA 7667:2001). It extends the gamut of sRGB; and its ;;higher precision numbers provide a larger dynamic range. ;; ;;A triplet of integers represent e-sRGB colors. Three precisions are ;;supported: ;;@table @r ;;@item e-sRGB10 ;;0 to 1023 ;;@item e-sRGB12 ;;0 to 4095 ;;@item e-sRGB16 ;;0 to 65535 ;;@end table ;;@end deftp (define (esRGB->color prec-RGB) (and (eqv? 4 (length prec-RGB)) (let ((range (and (pair? prec-RGB) (case (car prec-RGB) ((10) 1023) ((12) 4095) ((16) 65535) (else #f))))) (apply (lambda (precision r g b) (and (integer? r) (<= 0 r range) (integer? g) (<= 0 g range) (integer? b) (<= 0 b range) (color:construct 'e-sRGB (cdr prec-RGB) precision))) prec-RGB)))) ;;@body @1 must be the integer 10, 12, or 16. @2 must be a list of 3 ;;numbers. If @2 is valid e-sRGB coordinates, then @0 returns the color ;;specified by @2; otherwise returns #f. (define (e-sRGB->color precision RGB) (esRGB->color (cons precision RGB))) ;;@args 10 r g b ;;Returns the e-sRGB10 color composed of integers @2, @3, @4. ;;@args 12 r g b ;;Returns the e-sRGB12 color composed of integers @2, @3, @4. ;;@args 16 r g b ;;Returns the e-sRGB16 color composed of integers @2, @3, @4. ;;If the coordinates do not encode a valid e-sRGB color, then an error ;;is signaled. (define color:e-sRGB (color:helper 4 'color:e-sRGB esRGB->color)) ;;@body @1 must be the integer 10, 12, or 16. @0 returns the list of 3 ;;integers encoding @2 in sRGB10, sRGB12, or sRGB16. (define (color->e-sRGB precision color) (case precision ((10 12 16) (if (not (color:color? color)) (slib:error 'color->e-sRGB ': 'not 'color? color))) (else (slib:error 'color->e-sRGB ': 'invalid 'precision precision))) (case (color:encoding color) ((e-sRGB) (e-sRGB->e-sRGB (color:precision color) (color:coordinates color) precision)) ((sRGB) (sRGB->e-sRGB precision (color:coordinates color))) (else (CIEXYZ->e-sRGB precision (color->CIEXYZ color))))) ;;;; Polytypic Colors ;;; The rest of documentation is in "slib.texi" ;@ (define D65 (CIEXYZ->color CIEXYZ:D65)) (define D50 (CIEXYZ->color CIEXYZ:D50)) ;@ (define (color? obj . typ) (cond ((not (color:color? obj)) #f) ((null? typ) #t) (else (eqv? (car typ) (color:encoding obj))))) ;@ (define (make-color space . args) (apply (case space ((CIEXYZ) CIEXYZ->color) ((RGB709) RGB709->color) ((L*a*b*) L*a*b*->color) ((L*u*v*) L*u*v*->color) ((L*C*h) L*C*h->color) ((sRGB) sRGB->color) ((xRGB) xRGB->color) ((e-sRGB) e-sRGB->color) (else (slib:error 'make-color ': 'not 'space? space))) args)) ;@ (define color-space color:encoding) ;@ (define (color-precision color) (if (not (color:color? color)) (slib:error 'color-precision ': 'not 'color? color)) (case (color:encoding color) ((e-sRGB) (color:precision color)) ((sRGB) 8) (else #f))) ;@ (define (color-white-point color) (if (not (color:color? color)) (slib:error 'color-white-point ': 'not 'color? color)) (case (color:encoding color) ((L*a*b*) (color:CIEXYZ (color:white-point color))) ((L*u*v*) (color:CIEXYZ (color:white-point color))) ((L*C*h) (color:CIEXYZ (color:white-point color))) ((RGB709) D65) ((sRGB) D65) ((e-sRGB) D65) (else #f))) ;@ (define (convert-color color encoding . opt-arg) (define (noarg) (if (not (null? opt-arg)) (slib:error 'convert-color ': 'too-many 'arguments opt-arg))) (if (not (color:color? color)) (slib:error 'convert-color ': 'not 'color? color)) (case encoding ((CIEXYZ) (noarg) (CIEXYZ->color (color->CIEXYZ color))) ((RGB709) (noarg) (RGB709->color (color->RGB709 color))) ((sRGB) (noarg) (sRGB->color (color->sRGB color))) ((e-sRGB) (e-sRGB->color (car opt-arg) (color->e-sRGB (car opt-arg) color))) ((L*a*b*) (apply L*a*b*->color (color->L*a*b* color) opt-arg)) ((L*u*v*) (apply L*u*v*->color (color->L*u*v* color) opt-arg)) ((L*C*h) (apply L*C*h->color (color->L*C*h color) opt-arg)) (else (slib:error 'convert-color ': encoding '?)))) ;;; External color representations ;@ (define (color->string color) (if (not (color:color? color)) (slib:error 'color->string ': 'not 'color? color)) (case (color:encoding color) ((CIEXYZ) (apply sprintf #f "CIEXYZ:%g/%g/%g" (color:coordinates color))) ((L*a*b*) (apply sprintf #f "CIELab:%.4f/%.4f/%.4f" (if (equal? CIEXYZ:D65 (color:white-point color)) (color:coordinates color) (CIEXYZ->L*a*b* (L*a*b*->CIEXYZ (color:coordinates color) (color:white-point color)))))) ((L*u*v*) (apply sprintf #f "CIELuv:%.4f/%.4f/%.4f" (if (equal? CIEXYZ:D65 (color:white-point color)) (color:coordinates color) (CIEXYZ->L*u*v* (L*u*v*->CIEXYZ (color:coordinates color) (color:white-point color)))))) ((L*C*h) (apply sprintf #f "CIELCh:%.4f/%.4f/%.4f" (if (equal? CIEXYZ:D65 (color:white-point color)) (color:coordinates color) (L*a*b*->L*C*h (CIEXYZ->L*a*b* (L*a*b*->CIEXYZ (L*C*h->L*a*b* (color:coordinates color)) (color:white-point color))))))) ((RGB709) (apply sprintf #f "RGBi:%g/%g/%g" (color:coordinates color))) ((sRGB) (apply sprintf #f "sRGB:%d/%d/%d" (color:coordinates color))) ((e-sRGB) (apply sprintf #f "e-sRGB%d:%d/%d/%d" (color:precision color) (color:coordinates color))) (else (slib:error 'color->string ': (color:encoding color) color)))) ;@ (define (string->color str) (define prec #f) (define coding #f) (define x #f) (define y #f) (define z #f) (cond ((eqv? 4 (sscanf str " %[CIEXYZciexyzLABUVlabuvHhRrGg709]:%f/%f/%f" coding x y z)) (case (string-ci->symbol coding) ((CIEXYZ) (color:CIEXYZ x y z)) ((CIELab) (color:L*a*b* x y z)) ((CIELuv) (color:L*u*v* x y z)) ((CIELCh) (color:L*C*h x y z)) ((RGBi ; Xlib - C Language X Interface RGB709) (color:RGB709 x y z)) (else #f))) ((eqv? 4 (sscanf str " %[sRGBSrgb]:%d/%d/%d" coding x y z)) (case (string-ci->symbol coding) ((sRGB) (color:sRGB x y z)) (else #f))) ((eqv? 5 (sscanf str " %[-esRGBESrgb]%d:%d/%d/%d" coding prec x y z)) (case (string-ci->symbol coding) ((e-sRGB) (color:e-sRGB prec x y z)) (else #f))) ((eqv? 2 (sscanf str " %[sRGBxXXRGB]:%6x%[/0-9a-fA-F]" coding x y)) (case (string-ci->symbol coding) ((sRGB xRGB sRGBx) (xRGB->color x)) (else #f))) ((and (eqv? 1 (sscanf str " #%6[0-9a-fA-F]%[0-9a-fA-F]" x y)) (eqv? 6 (string-length x))) (xRGB->color (string->number x 16))) ((and (eqv? 2 (sscanf str " %[#0xX]%6[0-9a-fA-F]%[0-9a-fA-F]" coding x y)) (eqv? 6 (string-length x)) (member coding '("#" "#x" "0x" "#X" "0X"))) (xRGB->color (string->number x 16))) (else #f))) ;;;; visual color metrics ;@ (define (CIE:DE* color1 color2 . white-point) (L*a*b*:DE* (apply color->L*a*b* color1 white-point) (apply color->L*a*b* color2 white-point))) ;@ (define (CIE:DE*94 color1 color2 . parametric-factors) (apply L*C*h:DE*94 (color->L*C*h color1) (color->L*C*h color2) parametric-factors)) ;@ (define (CMC:DE* color1 color2 . parametric-factors) (apply CMC-DE (color->L*C*h color1) (color->L*C*h color2) parametric-factors)) ;;; Short names ;; (define CIEXYZ color:CIEXYZ) ;; (define RGB709 color:RGB709) ;; (define L*a*b* color:L*a*b*) ;; (define L*u*v* color:L*u*v*) ;; (define L*C*h color:L*C*h) ;; (define sRGB color:sRGB) ;; (define xRGB xRGB->color) ;; (define e-sRGB color:e-sRGB) slib-3b1/colorspc.scm0000644001705200017500000004224610625110304012520 0ustar tbtb;;; "colorspc.scm" color-space conversions ;Copyright 2001, 2002 Aubrey Jaffer ; ;Permission to copy this software, to modify it, to redistribute it, ;to distribute modified versions, and to use it for any purpose is ;granted, subject to the following restrictions and understandings. ; ;1. Any copy made of this software must include this copyright notice ;in full. ; ;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; ;3. In conjunction with products arising from the use of this ;material, there shall be no use of my name in any advertising, ;promotional, or sales literature without prior written consent in ;each case. (require 'logical) (require 'multiarg/and-) (require-if 'compiling 'sort) (require-if 'compiling 'ciexyz) ;@ (define (color:linear-transform matrix row) (map (lambda (mrow) (apply + (map * mrow row))) matrix)) (define RGB709:into-matrix '(( 3.240479 -1.537150 -0.498535 ) ( -0.969256 1.875992 0.041556 ) ( 0.055648 -0.204043 1.057311 ))) ;;; http://www.pima.net/standards/it10/PIMA7667/PIMA7667-2001.PDF gives ;;; matrix identical to sRGB:from-matrix, but colors drift under ;;; repeated conversions to and from CIEXYZ. Instead use RGB709. (define RGB709:from-matrix '(( 0.412453 0.357580 0.180423 ) ( 0.212671 0.715160 0.072169 ) ( 0.019334 0.119193 0.950227 ))) ;; From http://www.cs.rit.edu/~ncs/color/t_convert.html ;@ (define (CIEXYZ->RGB709 XYZ) (color:linear-transform RGB709:into-matrix XYZ)) (define (RGB709->CIEXYZ rgb) (color:linear-transform RGB709:from-matrix rgb)) ;;; From http://www.w3.org/Graphics/Color/sRGB.html (define sRGB-log (lambda (sv) (if (<= sv 0.00304) (* 12.92 sv) (+ -0.055 (* 1.055 (expt sv 10/24)))))) (define sRGB-exp (lambda (x) (if (<= x 0.03928) (/ x 12.92) (expt (/ (+ 0.055 x) 1.055) 2.4)))) ;; Clipping as recommended by sRGB spec. ;@ (define (CIEXYZ->sRGB XYZ) (map (lambda (sv) (inexact->exact (round (* 255 (sRGB-log (max 0 (min 1 sv))))))) (color:linear-transform RGB709:into-matrix XYZ))) (define (sRGB->CIEXYZ sRGB) (color:linear-transform RGB709:from-matrix (map sRGB-exp (map (lambda (b8v) (/ b8v 255.0)) sRGB)))) ;;; sRGB values are sometimes written as 24-bit integers 0xRRGGBB ;@ (define (xRGB->sRGB xRGB) (list (ash xRGB -16) (logand (ash xRGB -8) 255) (logand xRGB 255))) (define (sRGB->xRGB sRGB) (apply + (map * sRGB '(#x10000 #x100 #x1)))) ;@ (define (xRGB->CIEXYZ xRGB) (sRGB->CIEXYZ (xRGB->sRGB xRGB))) (define (CIEXYZ->xRGB xyz) (sRGB->xRGB (CIEXYZ->sRGB xyz))) ;;; http://www.pima.net/standards/it10/PIMA7667/PIMA7667-2001.PDF ;;; Photography - Electronic still picture imaging - ;;; Extended sRGB color encoding - e-sRGB (define e-sRGB-log (lambda (sv) (cond ((< sv -0.0031308) (- 0.055 (* 1.055 (expt (- sv) 10/24)))) ((<= sv 0.0031308) (* 12.92 sv)) (else (+ -0.055 (* 1.055 (expt sv 10/24))))))) (define e-sRGB-exp (lambda (x) (cond ((< x -0.04045) (- (expt (/ (- 0.055 x) 1.055) 2.4))) ((<= x 0.04045) (/ x 12.92)) (else (expt (/ (+ 0.055 x) 1.055) 2.4))))) ;@ (define (CIEXYZ->e-sRGB n XYZ) (define two^n-9 (ash 1 (- n 9))) (define offset (* 3 (ash 1 (- n 3)))) (map (lambda (x) (+ (inexact->exact (round (* x 255 two^n-9))) offset)) (map e-sRGB-log (color:linear-transform RGB709:into-matrix XYZ)))) ;@ (define (e-sRGB->CIEXYZ n rgb) (define two^n-9 (ash 1 (- n 9))) (define offset (* 3 (ash 1 (- n 3)))) (color:linear-transform RGB709:from-matrix (map e-sRGB-exp (map (lambda (b8v) (/ (- b8v offset) 255.0 two^n-9)) rgb)))) ;@ (define (sRGB->e-sRGB n sRGB) (define two^n-9 (ash 1 (- n 9))) (define offset (* 3 (ash 1 (- n 3)))) (map (lambda (x) (+ offset (* two^n-9 x))) sRGB)) ;@ (define (e-sRGB->sRGB n rgb) (define two^n-9 (ash 1 (- n 9))) (define offset (* 3 (ash 1 (- n 3)))) (map (lambda (x) (/ (- x offset) two^n-9)) rgb)) ;@ (define (e-sRGB->e-sRGB n rgb m) (define shft (- m n)) (cond ((zero? shft) rgb) (else (map (lambda (x) (ash x shft)) rgb)))) ;;; From http://www.cs.rit.edu/~ncs/color/t_convert.html ;;; CIE 1976 L*a*b* is based directly on CIE XYZ and is an attampt to ;;; linearize the perceptibility of color differences. The non-linear ;;; relations for L*, a*, and b* are intended to mimic the logarithmic ;;; response of the eye. Coloring information is referred to the color ;;; of the white point of the system, subscript n. ;;;; L* is CIE lightness ;;; L* = 116 * (Y/Yn)^1/3 - 16 for Y/Yn > 0.008856 ;;; L* = 903.3 * Y/Yn otherwise (define (CIE:Y/Yn->L* Y/Yn) (if (> Y/Yn 0.008856) (+ -16 (* 116 (expt Y/Yn 1/3))) (* 903.3 Y/Yn))) (define (CIE:L*->Y/Yn L*) (cond ((<= L* (* 903.3 0.008856)) (/ L* 903.3)) ((<= L* 100.) (expt (/ (+ L* 16) 116) 3)) (else 1))) ;;; a* = 500 * ( f(X/Xn) - f(Y/Yn) ) ;;; b* = 200 * ( f(Y/Yn) - f(Z/Zn) ) ;;; where f(t) = t^1/3 for t > 0.008856 ;;; f(t) = 7.787 * t + 16/116 otherwise (define (ab-log t) (if (> t 0.008856) (expt t 1/3) (+ 16/116 (* t 7.787)))) (define (ab-exp f) (define f3 (expt f 3)) (if (> f3 0.008856) f3 (/ (- f 16/116) 7.787))) ;@ (define (CIEXYZ->L*a*b* XYZ . white-point) (apply (lambda (X/Xn Y/Yn Z/Zn) (list (CIE:Y/Yn->L* Y/Yn) (* 500 (- (ab-log X/Xn) (ab-log Y/Yn))) (* 200 (- (ab-log Y/Yn) (ab-log Z/Zn))))) (map / XYZ (if (null? white-point) CIEXYZ:D65 (car white-point))))) ;;; Here Xn, Yn and Zn are the tristimulus values of the reference white. ;@ (define (L*a*b*->CIEXYZ L*a*b* . white-point) (apply (lambda (Xn Yn Zn) (apply (lambda (L* a* b*) (let* ((Y/Yn (CIE:L*->Y/Yn L*)) (fY/Yn (ab-log Y/Yn))) (list (* Xn (ab-exp (+ fY/Yn (/ a* 500)))) (* Yn Y/Yn) (* Zn (ab-exp (+ fY/Yn (/ b* -200))))))) L*a*b*)) (if (null? white-point) CIEXYZ:D65 (car white-point)))) ;;; XYZ to CIELUV ;;; CIE 1976 L*u*u* (CIELUV) is based directly on CIE XYZ and is another ;;; attampt to linearize the perceptibility of color differences. L* is ;;; CIE lightness as for L*a*b* above. The non-linear relations for u* ;;; and v* are: ;;; u* = 13 L* ( u' - un' ) ;;; v* = 13 L* ( v' - vn' ) ;;; The quantities un' and vn' refer to the reference white or the light ;;; source; for the 2.o observer and illuminant C, un' = 0.2009, vn' = ;;; 0.4610. Equations for u' and v' are given below: ;;; u' = 4 X / (X + 15 Y + 3 Z) ;;; v' = 9 Y / (X + 15 Y + 3 Z) (define (XYZ->uv XYZ) (apply (lambda (X Y Z) (define denom (+ X (* 15 Y) (* 3 Z))) (if (zero? denom) '(4. 9.) (list (/ (* 4 X) denom) (/ (* 9 Y) denom)))) XYZ)) ;@ (define (CIEXYZ->L*u*v* XYZ . white-point) (set! white-point (if (null? white-point) CIEXYZ:D65 (car white-point))) (let* ((Y/Yn (/ (cadr XYZ) (cadr white-point))) (L* (CIE:Y/Yn->L* Y/Yn))) (cons L* (map (lambda (q) (* 13 L* q)) (map - (XYZ->uv XYZ) (XYZ->uv white-point)))))) ;;; CIELUV to XYZ ;;; The transformation from CIELUV to XYZ is performed as following: ;;; u' = u / ( 13 L* ) + un ;;; v' = v / ( 13 L* ) + vn ;;; X = 9 Y u' / 4 v' ;;; Z = ( 12 Y - 3 Y u' - 20 Y v' ) / 4 v' ;@ (define (L*u*v*->CIEXYZ L*u*v* . white-point) (set! white-point (if (null? white-point) CIEXYZ:D65 (car white-point))) (apply (lambda (un vn) (apply (lambda (L* u* v*) (if (not (positive? L*)) '(0. 0. 0.) (let* ((up (+ (/ u* 13 L*) un)) (vp (+ (/ v* 13 L*) vn)) (Y (* (CIE:L*->Y/Yn L*) (cadr white-point)))) (list (/ (* 9 Y up) 4 vp) Y (/ (* Y (+ 12 (* -3 up) (* -20 vp))) 4 vp))))) L*u*v*)) (XYZ->uv white-point))) ;;; http://www.inforamp.net/~poynton/PDFs/coloureq.pdf (define pi (* 4 (atan 1))) (define pi/180 (/ pi 180)) ;@ (define (L*a*b*->L*C*h lab) (define h (/ (atan (caddr lab) (cadr lab)) pi/180)) (list (car lab) (sqrt (apply + (map * (cdr lab) (cdr lab)))) (if (negative? h) (+ 360 h) h))) ;@ (define (L*C*h->L*a*b* lch) (apply (lambda (L* C* h) (set! h (* h pi/180)) (list L* (* C* (cos h)) (* C* (sin h)))) lch)) ;@ (define (L*a*b*:DE* lab1 lab2) (sqrt (apply + (map (lambda (x) (* x x)) (map - lab1 lab2))))) ;;; http://www.colorpro.com/info/data/cie94.html (define (color:process-params parametric-factors) (define ans (case (length parametric-factors) ((0) #f) ((1) (if (list? parametric-factors) (apply color:process-params parametric-factors) (append parametric-factors '(1 1)))) ((2) (append parametric-factors '(1))) ((3) parametric-factors) (else (slib:error 'parametric-factors 'too-many parametric-factors)))) (and ans (for-each (lambda (obj) (if (not (number? obj)) (slib:error 'parametric-factors 'not 'number? obj))) ans)) ans) ;@ (define (L*C*h:DE*94 lch1 lch2 . parametric-factors) (define C* (sqrt (* (cadr lch1) (cadr lch2)))) ;Geometric mean (sqrt (apply + (map / (map (lambda (x) (* x x)) (map - lch1 lch2)) (list 1 ; S_l (+ 1 (* .045 C*)) ; S_c (+ 1 (* .015 C*))) ; S_h (or (color:process-params parametric-factors) '(1 1 1)))))) ;;; CMC-DE is designed only for small color-differences. But try to do ;;; something reasonable for large differences. Use bisector (h*) of ;;; the hue angles if separated by less than 90.o; otherwise, pick h of ;;; the color with larger C*. ;@ (define (CMC-DE lch1 lch2 . parametric-factors) (apply (lambda (L* C* h_) ;Geometric means (let ((ang1 (* pi/180 (caddr lch1))) (ang2 (* pi/180 (caddr lch2)))) (cond ((>= 90 (abs (/ (atan (sin (- ang1 ang2)) (cos (- ang1 ang2))) pi/180))) (set! h_ (/ (atan (+ (sin ang1) (sin ang2)) (+ (cos ang1) (cos ang2))) pi/180))) ((>= (cadr lch1) (cadr lch2)) (caddr lch1)) (else (caddr lch2)))) (let* ((C*^4 (expt C* 4)) (f (sqrt (/ C*^4 (+ C*^4 1900)))) (T (if (and (> h_ 164) (< h_ 345)) (+ 0.56 (abs (* 0.2 (cos (* (+ h_ 168) pi/180))))) (+ 0.36 (abs (* 0.4 (cos (* (+ h_ 35) pi/180))))))) (S_l (if (< L* 16) 0.511 (/ (* 0.040975 L*) (+ 1 (* 0.01765 L*))))) (S_c (+ (/ (* 0.0638 C*) (+ 1 (* 0.0131 C*))) 0.638)) (S_h (* S_c (+ (* (+ -1 T) f) 1)))) (sqrt (apply + (map / (map (lambda (x) (* x x)) (map - lch1 lch2)) (list S_l S_c S_h) (or (color:process-params parametric-factors) '(2 1 1))))))) (map sqrt (map * lch1 lch2)))) ;;; Chromaticity ;@ (define (XYZ->chromaticity XYZ) (define sum (apply + XYZ)) (list (/ (car XYZ) sum) (/ (cadr XYZ) sum))) ;@ (define (chromaticity->CIEXYZ x y) (list x y (- 1 x y))) (define (chromaticity->whitepoint x y) (list (/ x y) 1 (/ (- 1 x y) y))) ;@ (define (XYZ->xyY XYZ) (define sum (apply + XYZ)) (if (zero? sum) '(0 0 0) (list (/ (car XYZ) sum) (/ (cadr XYZ) sum) (cadr XYZ)))) ;@ (define (xyY->XYZ xyY) (define x (car xyY)) (define y (cadr xyY)) (if (zero? y) '(0 0 0) (let ((Y/y (/ (caddr xyY) y))) (list (* Y/y x) (caddr xyY) (* Y/y (- 1 x y)))))) ;@ (define (xyY:normalize-colors lst . n) (define (nthcdr n lst) (if (zero? n) lst (nthcdr (+ -1 n) (cdr lst)))) (define Ys (map caddr lst)) (set! n (if (null? n) 1 (car n))) (let ((max-Y (if (positive? n) (* n (apply max Ys)) (let () (require 'sort) (apply max (nthcdr (- n) (sort Ys >=))))))) (map (lambda (xyY) (let ((x (max 0 (car xyY))) (y (max 0 (cadr xyY)))) (define sum (max 1 (+ x y))) (list (/ x sum) (/ y sum) (max 0 (min 1 (/ (caddr xyY) max-Y)))))) lst))) ;;; http://www.aim-dtp.net/aim/technology/cie_xyz/cie_xyz.htm: ;;; Illuminant D65 0.312713 0.329016 ;; (define CIEXYZ:D65 (chromaticity->whitepoint 0.312713 0.329016)) ;; (define CIEXYZ:D65 (chromaticity->whitepoint 0.3127 0.3290)) ;@ (define CIEXYZ:D50 (chromaticity->whitepoint 0.3457 0.3585)) ;;; With its 16-bit resolution, e-sRGB-16 is extremely sensitive to ;;; whitepoint. Even the 6 digits of precision specified above is ;;; insufficient to make (color->e-srgb 16 d65) ==> (57216 57216 57216) ;@ (define CIEXYZ:D65 (e-sRGB->CIEXYZ 16 '(57216 57216 57216))) ;;; http://www.efg2.com/Lab/Graphics/Colors/Chromaticity.htm CIE 1931: ;@ (define CIEXYZ:A (chromaticity->whitepoint 0.44757 0.40745)) ; 2856.K (define CIEXYZ:B (chromaticity->whitepoint 0.34842 0.35161)) ; 4874.K (define CIEXYZ:C (chromaticity->whitepoint 0.31006 0.31616)) ; 6774.K (define CIEXYZ:E (chromaticity->whitepoint 1/3 1/3)) ; 5400.K ;;; Converting spectra (define cie:x-bar #f) (define cie:y-bar #f) (define cie:z-bar #f) ;@ (define (load-ciexyz . path) (let ((path (if (null? path) (in-vicinity (library-vicinity) "cie1931.xyz") (car path)))) (set! cie:x-bar (make-vector 80)) (set! cie:y-bar (make-vector 80)) (set! cie:z-bar (make-vector 80)) (call-with-input-file path (lambda (iprt) (do ((wlen 380 (+ 5 wlen)) (idx 0 (+ 1 idx))) ((>= wlen 780)) (let ((rlen (read iprt))) (if (not (eqv? wlen rlen)) (slib:error path 'expected wlen 'not rlen)) (vector-set! cie:x-bar idx (read iprt)) (vector-set! cie:y-bar idx (read iprt)) (vector-set! cie:z-bar idx (read iprt)))))))) ;@ (define (read-cie-illuminant path) (define siv (make-vector 107)) (call-with-input-file path (lambda (iprt) (do ((idx 0 (+ 1 idx))) ((>= idx 107) siv) (vector-set! siv idx (read iprt)))))) ;@ (define (read-normalized-illuminant path) (define siv (read-cie-illuminant path)) (let ((yw (/ (cadr (spectrum->XYZ siv 300e-9 830e-9))))) (illuminant-map (lambda (w x) (* x yw)) siv))) ;@ (define (illuminant-map proc siv) (define prod (make-vector 107)) (do ((idx 106 (+ -1 idx)) (w 830e-9 (+ -5e-9 w))) ((negative? idx) prod) (vector-set! prod idx (proc w (vector-ref siv idx))))) ;@ (define (illuminant-map->XYZ proc siv) (spectrum->XYZ (illuminant-map proc siv) 300e-9 830e-9)) ;@ (define (wavelength->XYZ wl) (if (not cie:y-bar) (require 'ciexyz)) (set! wl (- (/ wl 5.e-9) 380/5)) (if (<= 0 wl (+ -1 400/5)) (let* ((wlf (inexact->exact (floor wl))) (res (- wl wlf))) (define (interpolate vect idx res) (+ (* res (vector-ref vect idx)) (* (- 1 res) (vector-ref vect (+ 1 idx))))) (list (interpolate cie:x-bar wlf res) (interpolate cie:y-bar wlf res) (interpolate cie:z-bar wlf res))) (slib:error 'wavelength->XYZ 'out-of-range wl))) (define (wavelength->chromaticity wl) (XYZ->chromaticity (wavelength->XYZ wl))) ;@ (define (spectrum->XYZ . args) (define x 0) (define y 0) (define z 0) (if (not cie:y-bar) (require 'ciexyz)) (case (length args) ((1) (set! args (car args)) (do ((wvln 380.e-9 (+ 5.e-9 wvln)) (idx 0 (+ 1 idx))) ((>= idx 80) (map (lambda (x) (/ x 80)) (list x y z))) (let ((inten (args wvln))) (set! x (+ x (* (vector-ref cie:x-bar idx) inten))) (set! y (+ y (* (vector-ref cie:y-bar idx) inten))) (set! z (+ z (* (vector-ref cie:z-bar idx) inten)))))) ((3) (let* ((vect (if (list? (car args)) (list->vector (car args)) (car args))) (vlen (vector-length vect)) (x1 (cadr args)) (x2 (caddr args)) (xinc (/ (- x2 x1) (+ -1 vlen))) (x->j (lambda (x) (inexact->exact (round (/ (- x x1) xinc))))) (x->k (lambda (x) (inexact->exact (round (/ (- x 380.e-9) 5.e-9))))) (j->x (lambda (j) (+ x1 (* j xinc)))) (k->x (lambda (k) (+ 380.e-9 (* k 5.e-9)))) (xlo (max (min x1 x2) 380.e-9)) (xhi (min (max x1 x2) 780.e-9)) (jhi (x->j xhi)) (khi (x->k xhi)) (jinc (if (negative? xinc) -1 1))) (if (<= (abs xinc) 5.e-9) (do ((wvln (j->x (x->j xlo)) (+ wvln (abs xinc))) (jdx (x->j xlo) (+ jdx jinc))) ((>= jdx jhi) (let ((nsmps (abs (- jhi (x->j xlo))))) (map (lambda (x) (/ x nsmps)) (list x y z)))) (let ((ciedex (min 79 (x->k wvln))) (inten (vector-ref vect jdx))) (set! x (+ x (* (vector-ref cie:x-bar ciedex) inten))) (set! y (+ y (* (vector-ref cie:y-bar ciedex) inten))) (set! z (+ z (* (vector-ref cie:z-bar ciedex) inten))))) (do ((wvln (k->x (x->k xlo)) (+ wvln 5.e-9)) (kdx (x->k xlo) (+ kdx 1))) ((>= kdx khi) (let ((nsmps (abs (- khi (x->k xlo))))) (map (lambda (x) (/ x nsmps)) (list x y z)))) (let ((inten (vector-ref vect (x->j wvln)))) (set! x (+ x (* (vector-ref cie:x-bar kdx) inten))) (set! y (+ y (* (vector-ref cie:y-bar kdx) inten))) (set! z (+ z (* (vector-ref cie:z-bar kdx) inten)))))))) (else (slib:error 'spectrum->XYZ 'wna args)))) (define (spectrum->chromaticity . args) (XYZ->chromaticity (apply spectrum->XYZ args))) ;@ (define blackbody-spectrum (let* ((c 2.998e8) (h 6.626e-34) (h*c (* h c)) (k 1.381e-23) (pi*2*h*c*c (* 2 pi h*c c))) (lambda (temp . span) (define h*c/kT (/ h*c k temp)) (define pi*2*h*c*c*span (* pi*2*h*c*c (if (null? span) 1.e-9 (car span)))) (lambda (x) (/ pi*2*h*c*c*span (expt x 5) (- (exp (/ h*c/kT x)) 1)))))) ;@ (define (temperature->XYZ temp . span) (spectrum->XYZ (apply blackbody-spectrum temp span))) ;was .5e-9 (define (temperature->chromaticity temp) (XYZ->chromaticity (temperature->XYZ temp))) slib-3b1/color.txi0000644001705200017500000002402510747237372012053 0ustar tbtb@subsubheading Measurement-based Color Spaces @noindent @cindex tristimulus The @dfn{tristimulus} color spaces are those whose component values @cindex tristimulus are proportional measurements of light intensity. The CIEXYZ(1931) system provides 3 sets of spectra to dot-product with a spectrum of interest. The result of those dot-products is coordinates in CIEXYZ space. All tristimuls color spaces are related to CIEXYZ by linear transforms, namely matrix multiplication. Of the color spaces listed here, CIEXYZ and RGB709 are tristimulus spaces. @deftp {Color Space} CIEXYZ The CIEXYZ color space covers the full @dfn{gamut}. @cindex gamut It is the basis for color-space conversions. CIEXYZ is a list of three inexact numbers between 0.0 and 1.1. '(0. 0. 0.) is black; '(1. 1. 1.) is white. @end deftp @defun ciexyz->color xyz @var{xyz} must be a list of 3 numbers. If @var{xyz} is valid CIEXYZ coordinates, then @code{ciexyz->color} returns the color specified by @var{xyz}; otherwise returns #f. @end defun @defun color:ciexyz x y z Returns the CIEXYZ color composed of @var{x}, @var{y}, @var{z}. If the coordinates do not encode a valid CIEXYZ color, then an error is signaled. @end defun @defun color->ciexyz color Returns the list of 3 numbers encoding @var{color} in CIEXYZ. @end defun @deftp {Color Space} RGB709 BT.709-4 (03/00) @cite{Parameter values for the HDTV standards for production and international programme exchange} specifies parameter values for chromaticity, sampling, signal format, frame rates, etc., of high definition television signals. An RGB709 color is represented by a list of three inexact numbers between 0.0 and 1.0. '(0. 0. 0.) is black '(1. 1. 1.) is white. @end deftp @defun rgb709->color rgb @var{rgb} must be a list of 3 numbers. If @var{rgb} is valid RGB709 coordinates, then @code{rgb709->color} returns the color specified by @var{rgb}; otherwise returns #f. @end defun @defun color:rgb709 r g b Returns the RGB709 color composed of @var{r}, @var{g}, @var{b}. If the coordinates do not encode a valid RGB709 color, then an error is signaled. @end defun @defun color->rgb709 color Returns the list of 3 numbers encoding @var{color} in RGB709. @end defun @subsubheading Perceptual Uniformity @noindent Although properly encoding the chromaticity, tristimulus spaces do not match the logarithmic response of human visual systems to intensity. Minimum detectable differences between colors correspond to a smaller range of distances (6:1) in the L*a*b* and L*u*v* spaces than in tristimulus spaces (80:1). For this reason, color distances are computed in L*a*b* (or L*C*h). @deftp {Color Space} L*a*b* Is a CIE color space which better matches the human visual system's perception of color. It is a list of three numbers: @itemize @bullet @item 0 <= L* <= 100 (CIE @dfn{Lightness}) @cindex Lightness @item -500 <= a* <= 500 @item -200 <= b* <= 200 @end itemize @end deftp @defun l*a*b*->color L*a*b* white-point @var{L*a*b*} must be a list of 3 numbers. If @var{L*a*b*} is valid L*a*b* coordinates, then @code{l*a*b*->color} returns the color specified by @var{L*a*b*}; otherwise returns #f. @end defun @defun color:l*a*b* L* a* b* white-point Returns the L*a*b* color composed of @var{L*}, @var{a*}, @var{b*} with @var{white-point}. @defunx color:l*a*b* L* a* b* Returns the L*a*b* color composed of @var{L*}, @var{a*}, @var{b*}. If the coordinates do not encode a valid L*a*b* color, then an error is signaled. @end defun @defun color->l*a*b* color white-point Returns the list of 3 numbers encoding @var{color} in L*a*b* with @var{white-point}. @defunx color->l*a*b* color Returns the list of 3 numbers encoding @var{color} in L*a*b*. @end defun @deftp {Color Space} L*u*v* Is another CIE encoding designed to better match the human visual system's perception of color. @end deftp @defun l*u*v*->color L*u*v* white-point @var{L*u*v*} must be a list of 3 numbers. If @var{L*u*v*} is valid L*u*v* coordinates, then @code{l*u*v*->color} returns the color specified by @var{L*u*v*}; otherwise returns #f. @end defun @defun color:l*u*v* L* u* v* white-point Returns the L*u*v* color composed of @var{L*}, @var{u*}, @var{v*} with @var{white-point}. @defunx color:l*u*v* L* u* v* Returns the L*u*v* color composed of @var{L*}, @var{u*}, @var{v*}. If the coordinates do not encode a valid L*u*v* color, then an error is signaled. @end defun @defun color->l*u*v* color white-point Returns the list of 3 numbers encoding @var{color} in L*u*v* with @var{white-point}. @defunx color->l*u*v* color Returns the list of 3 numbers encoding @var{color} in L*u*v*. @end defun @subsubheading Cylindrical Coordinates @noindent HSL (Hue Saturation Lightness), HSV (Hue Saturation Value), HSI (Hue Saturation Intensity) and HCI (Hue Chroma Intensity) are cylindrical color spaces (with angle hue). But these spaces are all defined in terms device-dependent RGB spaces. @noindent One might wonder if there is some fundamental reason why intuitive specification of color must be device-dependent. But take heart! A cylindrical system can be based on L*a*b* and is used for predicting how close colors seem to observers. @deftp {Color Space} L*C*h Expresses the *a and b* of L*a*b* in polar coordinates. It is a list of three numbers: @itemize @bullet @item 0 <= L* <= 100 (CIE @dfn{Lightness}) @cindex Lightness @item C* (CIE @dfn{Chroma}) is the distance from the neutral (gray) axis. @cindex Chroma @item 0 <= h <= 360 (CIE @dfn{Hue}) is the angle. @cindex Hue @end itemize The colors by quadrant of h are: @multitable @columnfractions .20 .60 .20 @item 0 @tab red, orange, yellow @tab 90 @item 90 @tab yellow, yellow-green, green @tab 180 @item 180 @tab green, cyan (blue-green), blue @tab 270 @item 270 @tab blue, purple, magenta @tab 360 @end multitable @end deftp @defun l*c*h->color L*C*h white-point @var{L*C*h} must be a list of 3 numbers. If @var{L*C*h} is valid L*C*h coordinates, then @code{l*c*h->color} returns the color specified by @var{L*C*h}; otherwise returns #f. @end defun @defun color:l*c*h L* C* h white-point Returns the L*C*h color composed of @var{L*}, @var{C*}, @var{h} with @var{white-point}. @defunx color:l*c*h L* C* h Returns the L*C*h color composed of @var{L*}, @var{C*}, @var{h}. If the coordinates do not encode a valid L*C*h color, then an error is signaled. @end defun @defun color->l*c*h color white-point Returns the list of 3 numbers encoding @var{color} in L*C*h with @var{white-point}. @defunx color->l*c*h color Returns the list of 3 numbers encoding @var{color} in L*C*h. @end defun @subsubheading Digital Color Spaces @noindent The color spaces discussed so far are impractical for image data because of numerical precision and computational requirements. In 1998 the IEC adopted @cite{A Standard Default Color Space for the Internet - sRGB} (@url{http://www.w3.org/Graphics/Color/sRGB}). sRGB was cleverly designed to employ the 24-bit (256x256x256) color encoding already in widespread use; and the 2.2 gamma intrinsic to CRT monitors. @noindent Conversion from CIEXYZ to digital (sRGB) color spaces is accomplished by conversion first to a RGB709 tristimulus space with D65 white-point; then each coordinate is individually subjected to the same non-linear mapping. Inverse operations in the reverse order create the inverse transform. @deftp {Color Space} sRGB Is "A Standard Default Color Space for the Internet". Most display monitors will work fairly well with sRGB directly. Systems using ICC profiles @ftindex ICC Profile @footnote{ @noindent A comprehensive encoding of transforms between CIEXYZ and device color spaces is the International Color Consortium profile format, ICC.1:1998-09: @quotation The intent of this format is to provide a cross-platform device profile format. Such device profiles can be used to translate color data created on one device into another device's native color space. @end quotation } should work very well with sRGB. @end deftp @defun srgb->color rgb @var{rgb} must be a list of 3 numbers. If @var{rgb} is valid sRGB coordinates, then @code{srgb->color} returns the color specified by @var{rgb}; otherwise returns #f. @end defun @defun color:srgb r g b Returns the sRGB color composed of @var{r}, @var{g}, @var{b}. If the coordinates do not encode a valid sRGB color, then an error is signaled. @end defun @deftp {Color Space} xRGB Represents the equivalent sRGB color with a single 24-bit integer. The most significant 8 bits encode red, the middle 8 bits blue, and the least significant 8 bits green. @end deftp @defun color->srgb color Returns the list of 3 integers encoding @var{color} in sRGB. @end defun @defun color->xrgb color Returns the 24-bit integer encoding @var{color} in sRGB. @end defun @defun xrgb->color k Returns the sRGB color composed of the 24-bit integer @var{k}. @end defun @deftp {Color Space} e-sRGB Is "Photography - Electronic still picture imaging - Extended sRGB color encoding" (PIMA 7667:2001). It extends the gamut of sRGB; and its higher precision numbers provide a larger dynamic range. A triplet of integers represent e-sRGB colors. Three precisions are supported: @table @r @item e-sRGB10 0 to 1023 @item e-sRGB12 0 to 4095 @item e-sRGB16 0 to 65535 @end table @end deftp @defun e-srgb->color precision rgb @var{precision} must be the integer 10, 12, or 16. @var{rgb} must be a list of 3 numbers. If @var{rgb} is valid e-sRGB coordinates, then @code{e-srgb->color} returns the color specified by @var{rgb}; otherwise returns #f. @end defun @defun color:e-srgb 10 r g b Returns the e-sRGB10 color composed of integers @var{r}, @var{g}, @var{b}. @defunx color:e-srgb 12 r g b Returns the e-sRGB12 color composed of integers @var{r}, @var{g}, @var{b}. @defunx color:e-srgb 16 r g b Returns the e-sRGB16 color composed of integers @var{r}, @var{g}, @var{b}. If the coordinates do not encode a valid e-sRGB color, then an error is signaled. @end defun @defun color->e-srgb precision color @var{precision} must be the integer 10, 12, or 16. @code{color->e-srgb} returns the list of 3 integers encoding @var{color} in sRGB10, sRGB12, or sRGB16. @end defun slib-3b1/comlist.scm0000644001705200017500000002402110174620634012350 0ustar tbtb;;"comlist.scm" Implementation of COMMON LISP list functions for Scheme ; Copyright (C) 1991, 1993, 1995, 2001, 2003 Aubrey Jaffer. ; Copyright (C) 2000 Colin Walters ; ;Permission to copy this software, to modify it, to redistribute it, ;to distribute modified versions, and to use it for any purpose is ;granted, subject to the following restrictions and understandings. ; ;1. Any copy made of this software must include this copyright notice ;in full. ; ;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; ;3. In conjunction with products arising from the use of this ;material, there shall be no use of my name in any advertising, ;promotional, or sales literature without prior written consent in ;each case. ;;; Some of these functions may be already defined in your Scheme. ;;; Comment out those definitions for functions which are already defined. ;;;; LIST FUNCTIONS FROM COMMON LISP ;;; Some tail-recursive optimizations made by ;;; Colin Walters ;;; AGJ restored order July 2001. ;;;@ From: hugh@ear.mit.edu (Hugh Secker-Walker) (define (make-list k . init) (set! init (if (pair? init) (car init))) (do ((k (+ -1 k) (+ -1 k)) (result '() (cons init result))) ((negative? k) result))) ;@ (define (copy-list lst) (append lst '())) ;@ (define (adjoin obj lst) (if (memv obj lst) lst (cons obj lst))) ;@ (define union (letrec ((onion (lambda (lst1 lst2) (if (null? lst1) lst2 (onion (cdr lst1) (comlist:adjoin (car lst1) lst2)))))) (lambda (lst1 lst2) (cond ((null? lst1) lst2) ((null? lst2) lst1) ((null? (cdr lst1)) (comlist:adjoin (car lst1) lst2)) ((null? (cdr lst2)) (comlist:adjoin (car lst2) lst1)) ((< (length lst2) (length lst1)) (onion (reverse lst2) lst1)) (else (onion (reverse lst1) lst2)))))) ;@ (define (intersection lst1 lst2) (if (null? lst2) lst2 (let build-intersection ((lst1 lst1) (result '())) (cond ((null? lst1) (reverse result)) ((memv (car lst1) lst2) (build-intersection (cdr lst1) (cons (car lst1) result))) (else (build-intersection (cdr lst1) result)))))) ;@ (define (set-difference lst1 lst2) (if (null? lst2) lst1 (let build-difference ((lst1 lst1) (result '())) (cond ((null? lst1) (reverse result)) ((memv (car lst1) lst2) (build-difference (cdr lst1) result)) (else (build-difference (cdr lst1) (cons (car lst1) result))))))) ;@ (define (subset? lst1 lst2) (or (eq? lst1 lst2) (let loop ((lst1 lst1)) (or (null? lst1) (and (memv (car lst1) lst2) (loop (cdr lst1))))))) ;@ (define (position obj lst) (define pos (lambda (n lst) (cond ((null? lst) #f) ((eqv? obj (car lst)) n) (else (pos (+ 1 n) (cdr lst)))))) (pos 0 lst)) ;@ (define (reduce-init pred? init lst) (if (null? lst) init (comlist:reduce-init pred? (pred? init (car lst)) (cdr lst)))) ;@ (define (reduce pred? lst) (cond ((null? lst) lst) ((null? (cdr lst)) (car lst)) (else (comlist:reduce-init pred? (car lst) (cdr lst))))) ;@ (define (some pred lst . rest) (cond ((null? rest) (let mapf ((lst lst)) (and (not (null? lst)) (or (pred (car lst)) (mapf (cdr lst)))))) (else (let mapf ((lst lst) (rest rest)) (and (not (null? lst)) (or (apply pred (car lst) (map car rest)) (mapf (cdr lst) (map cdr rest)))))))) ;@ (define (every pred lst . rest) (cond ((null? rest) (let mapf ((lst lst)) (or (null? lst) (and (pred (car lst)) (mapf (cdr lst)))))) (else (let mapf ((lst lst) (rest rest)) (or (null? lst) (and (apply pred (car lst) (map car rest)) (mapf (cdr lst) (map cdr rest)))))))) ;@ (define (notany pred . ls) (not (apply comlist:some pred ls))) ;@ (define (notevery pred . ls) (not (apply comlist:every pred ls))) ;@ (define (list-of?? predicate . bound) (define (errout) (apply slib:error 'list-of?? predicate bound)) (case (length bound) ((0) (lambda (obj) (and (list? obj) (comlist:every predicate obj)))) ((1) (set! bound (car bound)) (cond ((negative? bound) (set! bound (- bound)) (lambda (obj) (and (list? obj) (<= bound (length obj)) (comlist:every predicate obj)))) (else (lambda (obj) (and (list? obj) (<= (length obj) bound) (comlist:every predicate obj)))))) ((2) (let ((low (car bound)) (high (cadr bound))) (cond ((or (negative? low) (negative? high)) (errout)) ((< high low) (set! high (car bound)) (set! low (cadr bound)))) (lambda (obj) (and (list? obj) (<= low (length obj) high) (comlist:every predicate obj))))) (else (errout)))) ;@ (define (find-if pred? lst) (cond ((null? lst) #f) ((pred? (car lst)) (car lst)) (else (comlist:find-if pred? (cdr lst))))) ;@ (define (member-if pred? lst) (cond ((null? lst) #f) ((pred? (car lst)) lst) (else (comlist:member-if pred? (cdr lst))))) ;@ (define (remove obj lst) (define head (list '*head*)) (let remove ((lst lst) (tail head)) (cond ((null? lst)) ((eqv? obj (car lst)) (remove (cdr lst) tail)) (else (set-cdr! tail (list (car lst))) (remove (cdr lst) (cdr tail))))) (cdr head)) ;@ (define (remove-if pred? lst) (let remove-if ((lst lst) (result '())) (cond ((null? lst) (reverse result)) ((pred? (car lst)) (remove-if (cdr lst) result)) (else (remove-if (cdr lst) (cons (car lst) result)))))) ;@ (define (remove-if-not pred? lst) (let remove-if-not ((lst lst) (result '())) (cond ((null? lst) (reverse result)) ((pred? (car lst)) (remove-if-not (cdr lst) (cons (car lst) result))) (else (remove-if-not (cdr lst) result))))) ;@ (define nconc (if (provided? 'rev2-procedures) append! (lambda args (cond ((null? args) '()) ((null? (cdr args)) (car args)) ((null? (car args)) (apply comlist:nconc (cdr args))) (else (set-cdr! (last-pair (car args)) (apply comlist:nconc (cdr args))) (car args)))))) ;;;@ From: hugh@ear.mit.edu (Hugh Secker-Walker) (define (nreverse rev-it) ;;; Reverse order of elements of LIST by mutating cdrs. (cond ((null? rev-it) rev-it) ((not (list? rev-it)) (slib:error "nreverse: Not a list in arg1" rev-it)) (else (do ((reved '() rev-it) (rev-cdr (cdr rev-it) (cdr rev-cdr)) (rev-it rev-it rev-cdr)) ((begin (set-cdr! rev-it reved) (null? rev-cdr)) rev-it))))) ;@ (define (last lst n) (comlist:nthcdr (- (length lst) n) lst)) ;@ (define (butlast lst n) (comlist:butnthcdr (- (length lst) n) lst)) ;@ (define (nthcdr n lst) (if (zero? n) lst (comlist:nthcdr (+ -1 n) (cdr lst)))) ;@ (define (butnthcdr k lst) (cond ((negative? k) lst) ;(slib:error "negative argument to butnthcdr" k) ; SIMSYNCH FIFO8 uses negative k. ((or (zero? k) (null? lst)) '()) (else (let ((ans (list (car lst)))) (do ((lst (cdr lst) (cdr lst)) (tail ans (cdr tail)) (k (+ -2 k) (+ -1 k))) ((or (negative? k) (null? lst)) ans) (set-cdr! tail (list (car lst)))))))) ;;;; CONDITIONALS ;@ (define (and? . args) (cond ((null? args) #t) ((car args) (apply comlist:and? (cdr args))) (else #f))) ;@ (define (or? . args) (cond ((null? args) #f) ((car args) #t) (else (apply comlist:or? (cdr args))))) ;;;@ Checks to see if a list has any duplicate MEMBERs. (define (has-duplicates? lst) (cond ((null? lst) #f) ((member (car lst) (cdr lst)) #t) (else (comlist:has-duplicates? (cdr lst))))) ;;;@ remove duplicates of MEMBERs of a list (define remove-duplicates (letrec ((rem-dup (lambda (lst nlst) (cond ((null? lst) (reverse nlst)) ((member (car lst) nlst) (rem-dup (cdr lst) nlst)) (else (rem-dup (cdr lst) (cons (car lst) nlst))))))) (lambda (lst) (rem-dup lst '())))) ;@ (define list* (letrec ((list*1 (lambda (obj) (if (null? (cdr obj)) (car obj) (cons (car obj) (list*1 (cdr obj))))))) (lambda (obj1 . obj2) (if (null? obj2) obj1 (cons obj1 (list*1 obj2)))))) ;@ (define (atom? obj) (not (pair? obj))) ;@ (define (delete obj lst) (let delete ((lst lst)) (cond ((null? lst) '()) ((equal? obj (car lst)) (delete (cdr lst))) (else (set-cdr! lst (delete (cdr lst))) lst)))) ;@ (define (delete-if pred lst) (let delete-if ((lst lst)) (cond ((null? lst) '()) ((pred (car lst)) (delete-if (cdr lst))) (else (set-cdr! lst (delete-if (cdr lst))) lst)))) ;@ (define (delete-if-not pred lst) (let delete-if ((lst lst)) (cond ((null? lst) '()) ((not (pred (car lst))) (delete-if (cdr lst))) (else (set-cdr! lst (delete-if (cdr lst))) lst)))) ;;; internal versions safe from name collisions. ;;(define comlist:make-list make-list) ;;(define comlist:copy-list copy-list) (define comlist:adjoin adjoin) ;;(define comlist:union union) ;;(define comlist:intersection intersection) ;;(define comlist:set-difference set-difference) ;;(define comlist:subset? subset?) ;;(define comlist:position position) (define comlist:reduce-init reduce-init) ;;(define comlist:reduce reduce) ; reduce is also in collect.scm (define comlist:some some) (define comlist:every every) ;;(define comlist:notevery notevery) ;;(define comlist:notany notany) (define comlist:find-if find-if) (define comlist:member-if member-if) ;;(define comlist:remove remove) ;;(define comlist:remove-if remove-if) ;;(define comlist:remove-if-not remove-if-not) (define comlist:nconc nconc) ;;(define comlist:nreverse nreverse) ;;(define comlist:last last) ;;(define comlist:butlast butlast) (define comlist:nthcdr nthcdr) (define comlist:butnthcdr butnthcdr) (define comlist:and? and?) (define comlist:or? or?) (define comlist:has-duplicates? has-duplicates?) ;;(define comlist:remove-duplicates remove-duplicates) ;;(define comlist:delete-if-not delete-if-not) ;;(define comlist:delete-if delete-if) ;;(define comlist:delete delete) ;;(define comlist:atom? atom?) ;;(define atom atom?) ;;(define comlist:atom atom?) ;;(define comlist:list* list*) ;;(define comlist:list-of?? list-of??) slib-3b1/comparse.scm0000644001705200017500000001450010612021646012503 0ustar tbtb;;; "comparse.scm" Break command line into arguments. ;Copyright (C) 1995, 1997, 2003 Aubrey Jaffer ; ;Permission to copy this software, to modify it, to redistribute it, ;to distribute modified versions, and to use it for any purpose is ;granted, subject to the following restrictions and understandings. ; ;1. Any copy made of this software must include this copyright notice ;in full. ; ;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; ;3. In conjunction with products arising from the use of this ;material, there shall be no use of my name in any advertising, ;promotional, or sales literature without prior written consent in ;each case. ;;;; This is a simple command-line reader. It could be made fancier ;;; to handle lots of `shell' syntaxes. ;;; Albert L. Ting points out that a similar process can be used for ;;; reading files of options -- therefore READ-OPTIONS-FILE. (require 'string-port) ;;@code{(require 'read-command)} ;;@ftindex read-command (define (read-command-from-port port nl-term?) (define argv '()) (define obj "") (define chars '()) (define readc (lambda () (read-char port))) (define peekc (lambda () (peek-char port))) (define s-expression (lambda () (splice-arg (call-with-output-string (lambda (p) (display (slib:eval (read port)) p)))))) (define backslash (lambda (goto) (readc) (let ((c (readc))) (cond ((eqv? #\newline c) (goto (peekc))) ((and (char-whitespace? c) (eqv? #\newline (peekc)) (eqv? 13 (char->integer c))) (readc) (goto (peekc))) (else (set! chars (cons c chars)) (build-token (peekc))))))) (define loop (lambda (c) (case c ((#\\) (backslash loop)) ((#\") (splice-arg (read port))) ((#\( #\') (s-expression)) ((#\#) (do ((c (readc) (readc))) ((or (eof-object? c) (eqv? #\newline c)) (if nl-term? c (loop (peekc)))))) ((#\;) (readc)) ((#\newline) (readc) (and (not nl-term?) (loop (peekc)))) (else (cond ((eof-object? c) c) ((char-whitespace? c) (readc) (loop (peekc))) (else (build-token c))))))) (define splice-arg (lambda (arg) (set! obj (string-append obj (list->string (reverse chars)) arg)) (set! chars '()) (build-token (peekc)))) (define buildit (lambda () (readc) (set! argv (cons (string-append obj (list->string (reverse chars))) argv)))) (define build-token (lambda (c) (case c ((#\") (splice-arg (read port))) ((#\() (s-expression)) ((#\\) (backslash build-token)) ((#\;) (buildit)) (else (cond ((or (eof-object? c) (char-whitespace? c)) (buildit) (cond ((not (and nl-term? (eqv? c #\newline))) (set! obj "") (set! chars '()) (loop (peekc))))) (else (set! chars (cons (readc) chars)) (build-token (peekc)))))))) (let ((c (loop (peekc)))) (cond ((and (null? argv) (eof-object? c)) c) (else (reverse argv))))) ;;@args port ;;@args ;;@code{read-command} converts a @dfn{command line} into a list of strings ;;@cindex command line ;;suitable for parsing by @code{getopt}. The syntax of command lines ;;supported resembles that of popular @dfn{shell}s. @code{read-command} ;;updates @var{port} to point to the first character past the command ;;delimiter. ;; ;;If an end of file is encountered in the input before any characters are ;;found that can begin an object or comment, then an end of file object is ;;returned. ;; ;;The @var{port} argument may be omitted, in which case it defaults to the ;;value returned by @code{current-input-port}. ;; ;;The fields into which the command line is split are delimited by ;;whitespace as defined by @code{char-whitespace?}. The end of a command ;;is delimited by end-of-file or unescaped semicolon (@key{;}) or ;;@key{newline}. Any character can be literally included in a field by ;;escaping it with a backslach (@key{\}). ;; ;;The initial character and types of fields recognized are: ;;@table @asis ;;@item @samp{\} ;;The next character has is taken literally and not interpreted as a field ;;delimiter. If @key{\} is the last character before a @key{newline}, ;;that @key{newline} is just ignored. Processing continues from the ;;characters after the @key{newline} as though the backslash and ;;@key{newline} were not there. ;;@item @samp{"} ;;The characters up to the next unescaped @key{"} are taken literally, ;;according to [R4RS] rules for literal strings ;;(@pxref{Strings, , ,r4rs, Revised(4) Scheme}). ;;@item @samp{(}, @samp{%'} ;;One scheme expression is @code{read} starting with this character. The ;;@code{read} expression is evaluated, converted to a string ;;(using @code{display}), and replaces the expression in the returned ;;field. ;;@item @samp{;} ;;Semicolon delimits a command. Using semicolons more than one command ;;can appear on a line. Escaped semicolons and semicolons inside strings ;;do not delimit commands. ;;@end table ;; ;;@noindent ;;The comment field differs from the previous fields in that it must be ;;the first character of a command or appear after whitespace in order to ;;be recognized. @key{#} can be part of fields if these conditions are ;;not met. For instance, @code{ab#c} is just the field ab#c. ;; ;;@table @samp ;;@item # ;;Introduces a comment. The comment continues to the end of the line on ;;which the semicolon appears. Comments are treated as whitespace by ;;@code{read-dommand-line} and backslashes before @key{newline}s in ;;comments are also ignored. ;;@end table (define (read-command . port) (read-command-from-port (cond ((null? port) (current-input-port)) ((= 1 (length port)) (car port)) (else (slib:error 'read-command "Wrong Number of ARGs:" port))) #t)) ;;@body ;;@code{read-options-file} converts an @dfn{options file} into a list of ;;@cindex options file ;;strings suitable for parsing by @code{getopt}. The syntax of options ;;files is the same as the syntax for command ;;lines, except that @key{newline}s do not terminate reading (only @key{;} ;;or end of file). ;; ;;If an end of file is encountered before any characters are found that ;;can begin an object or comment, then an end of file object is returned. (define (read-options-file filename) (call-with-input-file filename (lambda (port) (read-command-from-port port #f)))) slib-3b1/comparse.txi0000644001705200017500000000603010747237372012542 0ustar tbtb@code{(require 'read-command)} @ftindex read-command @defun read-command port @defunx read-command @code{read-command} converts a @dfn{command line} into a list of strings @cindex command line @cindex command line suitable for parsing by @code{getopt}. The syntax of command lines supported resembles that of popular @dfn{shell}s. @code{read-command} @cindex shell updates @var{port} to point to the first character past the command delimiter. If an end of file is encountered in the input before any characters are found that can begin an object or comment, then an end of file object is returned. The @var{port} argument may be omitted, in which case it defaults to the value returned by @code{current-input-port}. The fields into which the command line is split are delimited by whitespace as defined by @code{char-whitespace?}. The end of a command is delimited by end-of-file or unescaped semicolon (@key{;}) or @key{newline}. Any character can be literally included in a field by escaping it with a backslach (@key{\}). The initial character and types of fields recognized are: @table @asis @item @samp{\} The next character has is taken literally and not interpreted as a field delimiter. If @key{\} is the last character before a @key{newline}, that @key{newline} is just ignored. Processing continues from the characters after the @key{newline} as though the backslash and @key{newline} were not there. @item @samp{"} The characters up to the next unescaped @key{"} are taken literally, according to [R4RS] rules for literal strings (@pxref{Strings, , ,r4rs, Revised(4) Scheme}). @item @samp{(}, @samp{%'} One scheme expression is @code{read} starting with this character. The @code{read} expression is evaluated, converted to a string (using @code{display}), and replaces the expression in the returned field. @item @samp{;} Semicolon delimits a command. Using semicolons more than one command can appear on a line. Escaped semicolons and semicolons inside strings do not delimit commands. @end table @noindent The comment field differs from the previous fields in that it must be the first character of a command or appear after whitespace in order to be recognized. @key{#} can be part of fields if these conditions are not met. For instance, @code{ab#c} is just the field ab#c. @table @samp @item # Introduces a comment. The comment continues to the end of the line on which the semicolon appears. Comments are treated as whitespace by @code{read-dommand-line} and backslashes before @key{newline}s in comments are also ignored. @end table @end defun @defun read-options-file filename @code{read-options-file} converts an @dfn{options file} into a list of @cindex options file @cindex options file strings suitable for parsing by @code{getopt}. The syntax of options files is the same as the syntax for command lines, except that @key{newline}s do not terminate reading (only @key{;} or end of file). If an end of file is encountered before any characters are found that can begin an object or comment, then an end of file object is returned. @end defun slib-3b1/COPYING0000644001705200017500000000305110504034220011210 0ustar tbtb SLIB LICENSE Each file in SLIB (over a dozen lines in length) is either in the public domain, or comes with a statement of terms permitting users to copy, modify, and redistribute it. The comments at the beginning each file (containing over a dozen lines) must specify its terms. For instance, the comments at the beginning of "Template.scm" declare that it is in the public domain: ;;; "Template.scm" configuration template of *features* for Scheme ;;; Author: Aubrey Jaffer ;;; ;;; This code is in the public domain. Each copyrighted file lists the names of the copyright holders and gives permissions to copy, modify, and redistribute the file. For instance, the beginning of "require.scm" states: ;;;; Implementation of VICINITY and MODULES for Scheme ;Copyright (C) 1991, 1992, 1993, 1994, 1997 Aubrey Jaffer ; ;Permission to copy this software, to modify it, to redistribute it, ;to distribute modified versions, and to use it for any purpose is ;granted, subject to the following restrictions and understandings. ; ;1. Any copy made of this software must include this copyright notice ;in full. ; ;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; ;3. In conjunction with products arising from the use of this ;material, there shall be no use of my name in any advertising, ;promotional, or sales literature without prior written consent in ;each case. slib-3b1/crc.scm0000644001705200017500000001101710170107577011450 0ustar tbtb;;;; "crc.scm" Compute Cyclic Checksums ;;; Copyright (C) 1995, 1996, 1997, 2001, 2002 Aubrey Jaffer ; ;Permission to copy this software, to modify it, to redistribute it, ;to distribute modified versions, and to use it for any purpose is ;granted, subject to the following restrictions and understandings. ; ;1. Any copy made of this software must include this copyright notice ;in full. ; ;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; ;3. In conjunction with products arising from the use of this ;material, there shall be no use of my name in any advertising, ;promotional, or sales literature without prior written consent in ;each case. (require 'byte) (require 'logical) ;;@ (define CRC-32-polynomial "100000100100000010001110110110111") ; IEEE-802, FDDI (define CRC-32-polynomial "100000100110000010001110110110111") ; IEEE-802, AAL5 ;@ (define CRC-CCITT-polynomial "10001000000100001") ; X25 ;@ (define CRC-16-polynomial "11000000000000101") ; IBM Bisync, HDLC, SDLC, USB-Data ;;@ (define CRC-12-polynomial "1100000001101") (define CRC-12-polynomial "1100000001111") ;;@ (define CRC-10-polynomial "11000110001") (define CRC-10-polynomial "11000110011") ;@ (define CRC-08-polynomial "100000111") ;@ (define ATM-HEC-polynomial "100000111") ;@ (define DOWCRC-polynomial "100110001") ;@ (define USB-Token-polynomial "100101") ;;This procedure is careful not to use more than DEG bits in ;;computing (- (expt 2 DEG) 1). It returns #f if the integer would ;;be larger than the implementation supports. (define (crc:make-mask deg) (string->number (make-string deg #\1) 2)) ;@ (define (crc:make-table str) (define deg (+ -1 (string-length str))) (define generator (string->number (substring str 1 (string-length str)) 2)) (define crctab (make-vector 256)) (if (not (eqv? #\1 (string-ref str 0))) (slib:error 'crc:make-table 'first-digit-of-polynomial-must-be-1 str)) (if (< deg 8) (slib:error 'crc:make-table 'degree-must-be>7 deg str)) (and generator (do ((i 0 (+ 1 i)) (deg-1-mask (crc:make-mask (+ -1 deg))) (gen generator (if (logbit? (+ -1 deg) gen) (logxor (ash (logand deg-1-mask gen) 1) generator) (ash (logand deg-1-mask gen) 1))) (gens '() (cons gen gens))) ((>= i 8) (set! gens (reverse gens)) (do ((crc 0 0) (m 0 (+ 1 m))) ((> m 255) crctab) (for-each (lambda (gen i) (set! crc (if (logbit? i m) (logxor crc gen) crc))) gens '(0 1 2 3 4 5 6 7)) (vector-set! crctab m crc)))))) (define crc-32-table (crc:make-table CRC-32-polynomial)) ;;@ Computes the P1003.2/D11.2 (POSIX.2) 32-bit checksum. (define (cksum file) (cond ((not crc-32-table) #f) ((input-port? file) (cksum-port file)) (else (call-with-input-file file cksum-port)))) (define cksum-port (let ((mask-24 (crc:make-mask 24)) (mask-32 (crc:make-mask 32))) (lambda (port) (define crc 0) (define (accumulate-crc byt) (set! crc (logxor (ash (logand mask-24 crc) 8) (vector-ref crc-32-table (logxor (ash crc -24) byt))))) (do ((byt (read-byte port) (read-byte port)) (byte-count 0 (+ 1 byte-count))) ((eof-object? byt) (do ((byte-count byte-count (ash byte-count -8))) ((zero? byte-count) (logxor mask-32 crc)) (accumulate-crc (logand #xff byte-count)))) (accumulate-crc byt))))) ;@ (define (crc16 file) (cond ((not crc-16-table) #f) ((input-port? file) (crc16-port file)) (else (call-with-input-file file crc16-port)))) (define crc-16-table (crc:make-table CRC-16-polynomial)) (define crc16-port (let ((mask-8 (crc:make-mask 8)) (mask-16 (crc:make-mask 16))) (lambda (port) (define crc mask-16) (define (accumulate-crc byt) (set! crc (logxor (ash (logand mask-8 crc) 8) (vector-ref crc-16-table (logxor (ash crc -8) byt))))) (do ((byt (read-byte port) (read-byte port))) ((eof-object? byt) (logxor mask-16 crc)) (accumulate-crc byt))))) ;@ (define (crc5 file) (cond ((input-port? file) (crc5-port file)) (else (call-with-input-file file crc5-port)))) (define (crc5-port port) (define generator #b00101) (define crc #b11111) (do ((byt (read-byte port) (read-byte port))) ((eof-object? byt) (logxor #b11111 crc)) (do ((data byt (ash data 1)) (len (+ -1 8) (+ -1 len))) ((negative? len)) (set! crc (logand #b11111 (if (eqv? (logbit? 7 data) (logbit? 4 crc)) (ash crc 1) (logxor (ash crc 1) generator))))))) slib-3b1/cring.scm0000644001705200017500000004071510602621770012006 0ustar tbtb;;;"cring.scm" Extend Scheme numerics to any commutative ring. ;Copyright (C) 1997, 1998, 2001 Aubrey Jaffer ; ;Permission to copy this software, to modify it, to redistribute it, ;to distribute modified versions, and to use it for any purpose is ;granted, subject to the following restrictions and understandings. ; ;1. Any copy made of this software must include this copyright notice ;in full. ; ;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; ;3. In conjunction with products arising from the use of this ;material, there shall be no use of my name in any advertising, ;promotional, or sales literature without prior written consent in ;each case. (require 'common-list-functions) (require 'relational-database) (require 'databases) (require 'sort) (define number^ expt) (define number* *) (define number+ +) (define number- -) (define number/ /) (define number0? zero?) (define (zero? x) (and (number? x) (number0? x))) ;;(define (sign x) (if (positive? x) 1 (if (negative? x) -1 0))) (define cring:db (create-database #f 'alist-table)) ;@ (define (make-ruleset . rules) (define name #f) (cond ((and (not (null? rules)) (symbol? (car rules))) (set! name (car rules)) (set! rules (cdr rules))) (else (set! name (gentemp)))) (define-tables cring:db (list name '((op symbol) (sub-op1 symbol) (sub-op2 symbol)) '((reduction expression)) rules)) (let ((table ((cring:db 'open-table) name #t))) (and table (list (table 'get 'reduction) (table 'row:update) table)))) ;@ (define *ruleset* (make-ruleset 'default)) (define (cring:define-rule . args) (if *ruleset* ((cadr *ruleset*) args) (slib:warn "No ruleset in *ruleset*"))) ;@ (define (combined-rulesets . rulesets) (define name #f) (cond ((symbol? (car rulesets)) (set! name (car rulesets)) (set! rulesets (cdr rulesets))) (else (set! name (gentemp)))) (apply make-ruleset name (apply append (map (lambda (ruleset) (((caddr ruleset) 'row:retrieve*))) rulesets)))) ;;; Distribute * over + (and -) ;@ (define distribute* (make-ruleset 'distribute* `(* + identity ,(lambda (exp1 exp2) ;;(print 'distributing '* '+ exp1 exp2 '==>) (apply + (map (lambda (trm) (* trm exp2)) (cdr exp1))))) `(* - identity ,(lambda (exp1 exp2) ;;(print 'distributing '* '- exp1 exp2 '==>) (apply - (map (lambda (trm) (* trm exp2)) (cdr exp1))))))) ;;; Distribute / over + (and -) ;@ (define distribute/ (make-ruleset 'distribute/ `(/ + identity ,(lambda (exp1 exp2) ;;(print 'distributing '/ '+ exp1 exp2 '==>) (apply + (map (lambda (trm) (/ trm exp2)) (cdr exp1))))) `(/ - identity ,(lambda (exp1 exp2) ;;(print 'distributing '/ '- exp1 exp2 '==>) (apply - (map (lambda (trm) (/ trm exp2)) (cdr exp1))))))) (define (symbol-alpha? sym) (char-alphabetic? (string-ref (symbol->string sym) 0))) (define (expression-< x y) (cond ((and (number? x) (number? y)) (> x y)) ;want negatives last ((number? x) #t) ((number? y) #f) ((and (symbol? x) (symbol? y)) (cond ((eqv? (symbol-alpha? x) (symbol-alpha? y)) (stringstring x) (symbol->string y))) (else (symbol-alpha? x)))) ((symbol? x) #t) ((symbol? y) #f) ((null? x) #t) ((null? y) #f) ((expression-< (car x) (car y)) #t) ((expression-< (car y) (car x)) #f) (else (expression-< (cdr x) (cdr y))))) (define (expression-sort seq) (sort! seq expression-<)) (define is-term-op? (lambda (term op) (and (pair? term) (eq? op (car term))))) ;; To convert to CR internal form, NUMBER-op all the `numbers' in the ;; argument list and remove them from the argument list. Collect the ;; remaining arguments into equivalence classes, keeping track of the ;; number of arguments in each class. The returned list is thus: ;; ( ( . ) ...) ;;; Converts * argument list to CR internal form (define (cr*-args->fcts args) ;;(print (cons 'cr*-args->fcts args) '==>) (let loop ((args args) (pow 1) (nums 1) (arg_exps '())) ;;(print (list 'loop args pow nums denoms arg_exps) '==>) (cond ((null? args) (cons nums arg_exps)) ((number? (car args)) (let ((num^pow (number^ (car args) (abs pow)))) (if (negative? pow) (loop (cdr args) pow (number/ (number* num^pow nums)) arg_exps) (loop (cdr args) pow (number* num^pow nums) arg_exps)))) ;; Associative Rule ((is-term-op? (car args) '*) (loop (append (cdar args) (cdr args)) pow nums arg_exps)) ;; Do singlet - ((and (is-term-op? (car args) '-) (= 2 (length (car args)))) ;;(print 'got-here (car args)) (set! arg_exps (loop (cdar args) pow (number- nums) arg_exps)) (loop (cdr args) pow (car arg_exps) (cdr arg_exps))) ((and (is-term-op? (car args) '/) (= 2 (length (car args)))) ;; Do singlet / ;;(print 'got-here=cr+ (car args)) (set! arg_exps (loop (cdar args) (number- pow) nums arg_exps)) (loop (cdr args) pow (car arg_exps) (cdr arg_exps))) ((is-term-op? (car args) '/) ;; Do multi-arg / ;;(print 'doing '/ (cddar args) (number- pow)) (set! arg_exps (loop (cddar args) (number- pow) nums arg_exps)) ;;(print 'finishing '/ (cons (cadar args) (cdr args)) pow) (loop (cons (cadar args) (cdr args)) pow (car arg_exps) (cdr arg_exps))) ;; Pull out numeric exponents as powers ((and (is-term-op? (car args) '^) (= 3 (length (car args))) (number? (caddar args))) (set! arg_exps (loop (list (cadar args)) (number* pow (caddar args)) nums arg_exps)) (loop (cdr args) pow (car arg_exps) (cdr arg_exps))) ;; combine with same terms ((assoc (car args) arg_exps) => (lambda (pair) (set-cdr! pair (number+ pow (cdr pair))) (loop (cdr args) pow nums arg_exps))) ;; Add new term to arg_exps (else (loop (cdr args) pow nums (cons (cons (car args) pow) arg_exps)))))) ;;; Converts + argument list to CR internal form (define (cr+-args->trms args) (let loop ((args args) (cof 1) (numbers 0) (arg_exps '())) (cond ((null? args) (cons numbers arg_exps)) ((number? (car args)) (loop (cdr args) cof (number+ (number* (car args) cof) numbers) arg_exps)) ;; Associative Rule ((is-term-op? (car args) '+) (loop (append (cdar args) (cdr args)) cof numbers arg_exps)) ;; Idempotent singlet * ((and (is-term-op? (car args) '*) (= 2 (length (car args)))) (loop (cons (cadar args) (cdr args)) cof numbers arg_exps)) ((and (is-term-op? (car args) '-) (= 2 (length (car args)))) ;; Do singlet - (set! arg_exps (loop (cdar args) (number- cof) numbers arg_exps)) (loop (cdr args) cof (car arg_exps) (cdr arg_exps))) ;; Pull out numeric factors as coefficients ((and (is-term-op? (car args) '*) (some number? (cdar args))) ;;(print 'got-here (car args) '=> (cons '* (remove-if number? (cdar args)))) (set! arg_exps (loop (list (cons '* (remove-if number? (cdar args)))) (apply number* cof (remove-if-not number? (cdar args))) numbers arg_exps)) (loop (cdr args) cof (car arg_exps) (cdr arg_exps))) ((is-term-op? (car args) '-) ;; Do multi-arg - (set! arg_exps (loop (cddar args) (number- cof) numbers arg_exps)) (loop (cons (cadar args) (cdr args)) cof (car arg_exps) (cdr arg_exps))) ;; combine with same terms ((assoc (car args) arg_exps) => (lambda (pair) (set-cdr! pair (number+ cof (cdr pair))) (loop (cdr args) cof numbers arg_exps))) ;; Add new term to arg_exps (else (loop (cdr args) cof numbers (cons (cons (car args) cof) arg_exps)))))) ;;; Converts + or * internal form to Scheme expression (define (cr-terms->form op ident inv-op higher-op res_cofs) (define (negative-cof? fct_cof) (negative? (cdr fct_cof))) (define (finish exprs) (if (null? exprs) ident (if (null? (cdr exprs)) (car exprs) (cons op exprs)))) (define (do-terms sign fct_cofs) (expression-sort (map (lambda (fct_cof) (define cof (number* sign (cdr fct_cof))) (cond ((eqv? 1 cof) (car fct_cof)) ((number? (car fct_cof)) (number* cof (car fct_cof))) ((is-term-op? (car fct_cof) higher-op) (if (eq? higher-op '^) (list '^ (cadar fct_cof) (* cof (caddar fct_cof))) (cons higher-op (cons cof (cdar fct_cof))))) ((eqv? -1 cof) (list inv-op (car fct_cof))) (else (list higher-op (car fct_cof) cof)))) fct_cofs))) (let* ((all_cofs (remove-if (lambda (fct_cof) (or (zero? (cdr fct_cof)) (eqv? ident (car fct_cof)))) res_cofs)) (cofs (map cdr all_cofs)) (some-positive? (some positive? cofs))) ;;(print op 'positive? some-positive? 'negative? (some negative? cofs) all_cofs) (cond ((and some-positive? (some negative? cofs)) (append (list inv-op (finish (do-terms 1 (remove-if negative-cof? all_cofs)))) (do-terms -1 (remove-if-not negative-cof? all_cofs)))) (some-positive? (finish (do-terms 1 all_cofs))) ((not (some negative? cofs)) ident) (else (list inv-op (finish (do-terms -1 all_cofs))))))) (define (* . args) (cond ((null? args) 1) ;;This next line is commented out so ^ will collapse numerical expressions. ;;((null? (cdr args)) (car args)) (else (let ((in (cr*-args->fcts args))) (cond ((zero? (car in)) 0) (else (if (null? (cdr in)) (set-cdr! in (list (cons 1 1)))) (let* ((num #f) (ans (cr-terms->form '* 1 '/ '^ (apply (lambda (numeric red_cofs res_cofs) (set! num numeric) (append ;;(list (cons (abs numeric) 1)) red_cofs res_cofs)) (cr1 '* number* '^ '/ (car in) (cdr in)))))) (cond ((number0? (+ -1 num)) ans) ((number? ans) (number* num ans)) ((number0? (+ 1 num)) (if (and (list? ans) (= 2 (length ans)) (eq? '- (car ans))) (cadr ans) (list '- ans))) ((not (pair? ans)) (list '* num ans)) (else (case (car ans) ((*) (append (list '* num) (cdr ans))) ((+) (apply + (map (lambda (mon) (* num mon)) (cdr ans)))) ((-) (apply - (map (lambda (mon) (* num mon)) (cdr ans)))) (else (list '* num ans)))))))))))) (define (+ . args) (cond ((null? args) 0) ;;((null? (cdr args)) (car args)) (else (let ((in (cr+-args->trms args))) (if (null? (cdr in)) (car in) (cr-terms->form '+ 0 '- '* (apply (lambda (numeric red_cofs res_cofs) (append (list (if (and (number? numeric) (negative? numeric)) (cons (abs numeric) -1) (cons numeric 1))) red_cofs res_cofs)) (cr1 '+ number+ '* '- (car in) (cdr in))))))))) (define (- arg1 . args) (if (null? args) (if (number? arg1) (number- arg1) (* -1 arg1) ;(list '- arg1) ) (+ arg1 (* -1 (apply + args))))) ;;(print `(/ ,arg1 ,@args) '=> ) (define (/ arg1 . args) (if (null? args) (^ arg1 -1) (* arg1 (^ (apply * args) -1)))) (define (^ arg1 arg2) (cond ((and (number? arg2) (integer? arg2)) (* (list '^ arg1 arg2))) (else (list '^ arg1 arg2)))) ;; TRY-EACH-PAIR-ONCE algorithm. I think this does the minimum ;; number of rule lookups given no information about how to sort ;; terms. ;; Pick equivalence classes one at a time and move them into the ;; result set of equivalence classes by searching for rules to ;; multiply an element of the chosen class by itself (if multiple) and ;; the element of each class already in the result group. Each ;; (multiplicative) term resulting from rule application would be put ;; in the result class, if that class exists; or put in an argument ;; class if not. (define (cr1 op number-op hop inv-op numeric in) (define red_pows '()) (define res_pows '()) (define (cring:apply-rule->terms exp1 exp2) ;(display op) (let ((ans (cring:apply-rule op exp1 exp2))) (cond ((not ans) #f) ((number? ans) (list ans)) (else (list (cons ans 1)))))) (define (cring:apply-inv-rule->terms exp1 exp2) ;(display inv-op) (let ((ans (cring:apply-rule inv-op exp1 exp2))) (cond ((not ans) #f) ((number? ans) (list ans)) (else (list (cons ans 1)))))) (let loop_arg_pow_s ((arg (caar in)) (pow (cdar in)) (arg_pows (cdr in))) (define (arg-loop arg_pows) (cond ((not (null? arg_pows)) (loop_arg_pow_s (caar arg_pows) (cdar arg_pows) (cdr arg_pows))) (else (list numeric red_pows res_pows)))) ; Actually return! (define (merge-res tmp_pows multiplicity) (cond ((null? tmp_pows)) ((number? (car tmp_pows)) (do ((m (number+ -1 (abs multiplicity)) (number+ -1 m)) (n numeric (number-op n (abs (car tmp_pows))))) ((negative? m) (set! numeric n))) (merge-res (cdr tmp_pows) multiplicity)) ((or (assoc (car tmp_pows) res_pows) (assoc (car tmp_pows) arg_pows)) => (lambda (pair) (set-cdr! pair (number+ pow (number-op multiplicity (cdar tmp_pows)))) (merge-res (cdr tmp_pows) multiplicity))) ((assoc (car tmp_pows) red_pows) => (lambda (pair) (set! arg_pows (cons (cons (caar tmp_pows) (number+ (cdr pair) (number* multiplicity (cdar tmp_pows)))) arg_pows)) (set-cdr! pair 0) (merge-res (cdr tmp_pows) multiplicity))) (else (set! arg_pows (cons (cons (caar tmp_pows) (number* multiplicity (cdar tmp_pows))) arg_pows)) (merge-res (cdr tmp_pows) multiplicity)))) (define (try-fct_pow fct_pow) ;;(print 'try-fct_pow fct_pow op 'arg arg 'pow pow) (cond ((or (zero? (cdr fct_pow)) (number? (car fct_pow))) #f) ((not (and (number? pow) (number? (cdr fct_pow)) (integer? pow) ;(integer? (cdr fct_pow)) )) #f) ;;((zero? pow) (slib:error "Don't try exp-0 terms") #f) ;;((or (number? arg) (number? (car fct_pow))) ;; (slib:error 'found-number arg fct_pow) #f) ((and (positive? pow) (positive? (cdr fct_pow)) (or (cring:apply-rule->terms arg (car fct_pow)) (cring:apply-rule->terms (car fct_pow) arg))) => (lambda (terms) ;;(print op op terms) (let ((multiplicity (min pow (cdr fct_pow)))) (set-cdr! fct_pow (number- (cdr fct_pow) multiplicity)) (set! pow (number- pow multiplicity)) (merge-res terms multiplicity)))) ((and (negative? pow) (negative? (cdr fct_pow)) (or (cring:apply-rule->terms arg (car fct_pow)) (cring:apply-rule->terms (car fct_pow) arg))) => (lambda (terms) ;;(print inv-op inv-op terms) (let ((multiplicity (max pow (cdr fct_pow)))) (set-cdr! fct_pow (number+ (cdr fct_pow) multiplicity)) (set! pow (number+ pow multiplicity)) (merge-res terms multiplicity)))) ((and (positive? pow) (negative? (cdr fct_pow)) (cring:apply-inv-rule->terms arg (car fct_pow))) => (lambda (terms) ;;(print op inv-op terms) (let ((multiplicity (min pow (number- (cdr fct_pow))))) (set-cdr! fct_pow (number+ (cdr fct_pow) multiplicity)) (set! pow (number- pow multiplicity)) (merge-res terms multiplicity)))) ((and (negative? pow) (positive? (cdr fct_pow)) (cring:apply-inv-rule->terms (car fct_pow) arg)) => (lambda (terms) ;;(print inv-op op terms) (let ((multiplicity (max (number- pow) (cdr fct_pow)))) (set-cdr! fct_pow (number- (cdr fct_pow) multiplicity)) (set! pow (number+ pow multiplicity)) (merge-res terms multiplicity)))) (else #f))) ;;(print op numeric 'arg arg 'pow pow 'arg_pows arg_pows 'red_pows red_pows 'res_pows res_pows) ;;(trace arg-loop cring:apply-rule->terms merge-res try-fct_pow) (set! *qp-width* 333) (cond ((or (zero? pow) (eqv? 1 arg)) ;(number? arg) arg seems to always be 1 (arg-loop arg_pows)) ((assoc arg res_pows) => (lambda (pair) (set-cdr! pair (number+ pow (cdr pair))) (arg-loop arg_pows))) ((and (> (abs pow) 1) (cring:apply-rule->terms arg arg)) => (lambda (terms) (merge-res terms (quotient pow 2)) (if (odd? pow) (loop_arg_pow_s arg 1 arg_pows) (arg-loop arg_pows)))) ((or (some try-fct_pow res_pows) (some try-fct_pow arg_pows)) (loop_arg_pow_s arg pow arg_pows)) (else (set! res_pows (cons (cons arg pow) res_pows)) (arg-loop arg_pows))))) (define (cring:try-rule op sop1 sop2 exp1 exp2) (and *ruleset* (let ((rule ((car *ruleset*) op sop1 sop2))) (and rule (rule exp1 exp2))))) (define (cring:apply-rule op exp1 exp2) (and (pair? exp1) (or (and (pair? exp2) (cring:try-rule op (car exp1) (car exp2) exp1 exp2)) (cring:try-rule op (car exp1) 'identity exp1 exp2)))) ;;(begin (trace cr-terms->form) (set! *qp-width* 333)) slib-3b1/cvs.scm0000644001705200017500000001254410210204415011462 0ustar tbtb;;;;"cvs.scm" enumerate files under CVS control. ;;; Copyright 2002 Aubrey Jaffer ; ;Permission to copy this software, to modify it, to redistribute it, ;to distribute modified versions, and to use it for any purpose is ;granted, subject to the following restrictions and understandings. ; ;1. Any copy made of this software must include this copyright notice ;in full. ; ;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; ;3. In conjunction with products arising from the use of this ;material, there shall be no use of my name in any advertising, ;promotional, or sales literature without prior written consent in ;each case. (require 'scanf) (require 'line-i/o) (require 'string-search) ;;@body Returns a list of the local pathnames (with prefix @1) of all ;;CVS controlled files in @1 and in @1's subdirectories. (define (cvs-files directory/) (cvs:entries directory/ #t)) ;;@body Returns a list of all of @1 and all @1's CVS controlled ;;subdirectories. (define (cvs-directories directory/) (and (file-exists? (in-vicinity directory/ "CVS/Entries")) (cons directory/ (cvs:entries directory/ #f)))) (define (cvs:entries directory do-files?) (define files '()) (define cvse (in-vicinity directory "CVS/Entries")) (define cvsel (in-vicinity directory "CVS/Entries.Log")) (set! directory (substring directory (if (eqv? 0 (substring? "./" directory)) 2 0) (string-length directory))) (if (file-exists? cvse) (call-with-input-file cvse (lambda (port) (do ((line (read-line port) (read-line port))) ((eof-object? line)) (let ((fname #f)) (cond ((eqv? 1 (sscanf line "/%[^/]" fname)) (and do-files? (set! files (cons (in-vicinity directory fname) files)))) ((eqv? 1 (sscanf line "D/%[^/]" fname)) (set! files (append (cvs:entries (sub-vicinity directory fname) do-files?) (if do-files? '() (list (sub-vicinity directory fname))) files)))))))) (slib:warn 'cvs:entries 'missing cvse)) (set! files (reverse files)) (if (file-exists? cvsel) (call-with-input-file cvsel (lambda (port) (do ((line (read-line port) (read-line port))) ((eof-object? line) files) (let ((fname #f)) (cond ((eqv? 1 (sscanf line "A D/%[^/]/" fname)) (set! files (append files (if do-files? '() (list (sub-vicinity directory fname))) (cvs:entries (sub-vicinity directory fname) do-files?))))))))) files)) ;;@body Returns the (string) contents of @var{path/}CVS/Root; ;;or @code{(getenv "CVSROOT")} if Root doesn't exist. (define (cvs-root path/) (if (not (vicinity:suffix? (string-ref path/ (+ -1 (string-length path/))))) (slib:error 'missing 'vicinity-suffix path/)) (let ((rootpath (string-append path/ "CVS/Root"))) (if (file-exists? rootpath) (call-with-input-file rootpath read-line) (getenv "CVSROOT")))) ;;@body Returns the (string) contents of @var{directory/}CVS/Root appended ;;with @var{directory/}CVS/Repository; or #f if @var{directory/}CVS/Repository ;;doesn't exist. (define (cvs-repository directory/) (let ((root (cvs-root directory/)) (repath (in-vicinity (sub-vicinity directory/ "CVS/") "Repository"))) (define root/idx (substring? "/" root)) (define rootlen (string-length root)) (and root/idx (file-exists? repath) (let ((repos (call-with-input-file repath read-line))) (define replen (and (string? repos) (string-length repos))) (cond ((not (and replen (< 1 replen))) #f) ((not (char=? #\/ (string-ref repos 0))) (string-append root "/" repos)) ((eqv? 0 (substring? (substring root root/idx rootlen) repos)) (string-append root (substring repos (- rootlen root/idx) replen))) (else (slib:error 'mismatched root repos))))))) ;;@body ;;Writes @1 to file CVS/Root of @2. (define (cvs-set-root! new-root directory/) (define root (cvs-root directory/)) (define repos (cvs-repository directory/)) (if (not repos) (slib:error 'not 'cvs directory/)) (if (not (eqv? 0 (substring? root repos))) (slib:error 'bad 'cvs root repos)) (call-with-output-file (in-vicinity (sub-vicinity directory/ "CVS") "Root") (lambda (port) (write-line new-root port))) (call-with-output-file (in-vicinity (sub-vicinity directory/ "CVS") "Repository") (lambda (port) (write-line (substring repos (+ 1 (string-length root)) (string-length repos)) port)))) ;;@body ;;Writes @1 to file CVS/Root of @2 and all its CVS subdirectories. (define (cvs-set-roots! new-root directory/) (for-each (lambda (dir/) (cvs-set-root! new-root dir/)) (cvs-directories directory/))) ;;@body ;;Signals an error if CVS/Repository or CVS/Root files in @1 or any ;;subdirectory do not match. (define (cvs-vet directory/) (define diroot (cvs-root directory/)) (for-each (lambda (path/) (define path/CVS (sub-vicinity path/ "CVS/")) (cond ((not (cvs-repository path/)) (slib:error 'bad (in-vicinity path/CVS "Repository"))) ((not (equal? diroot (cvs-root path/))) (slib:error 'mismatched 'root (in-vicinity path/CVS "Root"))))) (or (cvs-directories directory/) (slib:error 'not 'cvs directory/)))) ;;(define cvs-rsh (or (getenv "CVS_RSH") "rsh")) slib-3b1/cvs.txi0000644001705200017500000000214610747237373011531 0ustar tbtb @defun cvs-files directory/ Returns a list of the local pathnames (with prefix @var{directory/}) of all CVS controlled files in @var{directory/} and in @var{directory/}'s subdirectories. @end defun @defun cvs-directories directory/ Returns a list of all of @var{directory/} and all @var{directory/}'s CVS controlled subdirectories. @end defun @defun cvs-root path/ Returns the (string) contents of @var{path/}CVS/Root; or @code{(getenv "CVSROOT")} if Root doesn't exist. @end defun @defun cvs-repository directory/ Returns the (string) contents of @var{directory/}CVS/Root appended with @var{directory/}CVS/Repository; or #f if @var{directory/}CVS/Repository doesn't exist. @end defun @deffn {Procedure} cvs-set-root! new-root directory/ Writes @var{new-root} to file CVS/Root of @var{directory/}. @end deffn @deffn {Procedure} cvs-set-roots! new-root directory/ Writes @var{new-root} to file CVS/Root of @var{directory/} and all its CVS subdirectories. @end deffn @defun cvs-vet directory/ Signals an error if CVS/Repository or CVS/Root files in @var{directory/} or any subdirectory do not match. @end defun slib-3b1/daylight.scm0000644001705200017500000002673410132363331012510 0ustar tbtb;;; "daylight.scm" Model of sun and sky colors. ; Copyright 2001 Aubrey Jaffer ; ;Permission to copy this software, to modify it, to redistribute it, ;to distribute modified versions, and to use it for any purpose is ;granted, subject to the following restrictions and understandings. ; ;1. Any copy made of this software must include this copyright notice ;in full. ; ;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; ;3. In conjunction with products arising from the use of this ;material, there shall be no use of my name in any advertising, ;promotional, or sales literature without prior written consent in ;each case. (require 'color-space) (define pi (* 4 (atan 1))) (define pi/180 (/ pi 180)) ;;@code{(require 'daylight)} ;;@ftindex daylight ;;@ftindex sunlight ;;@ftindex sun ;;@ftindex sky ;; ;;@noindent ;;This package calculates the colors of sky as detailed in:@* ;;@uref{http://www.cs.utah.edu/vissim/papers/sunsky/sunsky.pdf}@* ;;@cite{A Practical Analytic Model for Daylight}@* ;;A. J. Preetham, Peter Shirley, Brian Smits ;;@body ;; ;;Returns the solar-time in hours given the integer @1 in the range 1 to ;;366, and the local time in hours. ;; ;;To be meticulous, subtract 4 minutes for each degree of longitude west ;;of the standard meridian of your time zone. (define (solar-hour julian-day hour) (+ hour (* 0.170 (sin (* 4 pi (- julian-day 80) 1/373))) (* -0.129 (sin (* 2 pi (- julian-day 8) 1/355))))) ;;@body (define (solar-declination julian-day) (/ (* 0.4093 (sin (* 2 pi (- julian-day 81) 1/368))) pi/180)) ;;@body Returns a list of @var{theta_s}, the solar angle from the ;;zenith, and @var{phi_s}, the solar azimuth. 0 <= @var{theta_s} ;;measured in degrees. @var{phi_s} is measured in degrees from due ;;south; west of south being positive. (define (solar-polar declination latitude solar-hour) (define l (* pi/180 latitude)) (define d (* pi/180 declination)) (define pi*t/12 (* pi solar-hour 1/12)) (map (lambda (x) (/ x pi/180)) (list (- (/ pi 2) (asin (- (* (sin l) (sin d)) (* (cos l) (cos d) (cos pi*t/12))))) (atan (* -1 (cos d) (sin pi*t/12)) (- (* (cos l) (sin d)) (* (sin l) (cos d) (cos pi*t/12))))))) ;;@noindent ;;In the following procedures, the number 0 <= @var{theta_s} <= 90 is ;;the solar angle from the zenith in degrees. ;;(plot (lambda (t) (+ -.5 (/ 9 (expt 1.55 t)))) 0 6) ;tweaked ;;@cindex turbidity ;;@noindent ;;Turbidity is a measure of the fraction of scattering due to haze as ;;opposed to molecules. This is a convenient quantity because it can be ;;estimated based on visibility of distant objects. This model fails ;;for turbidity values less than 1.3. ;; ;;@example ;;@group ;; _______________________________________________________________ ;;512|-: | ;; | * pure-air | ;;256|-:** | ;; | : ** exceptionally-clear | ;;128|-: * | ;; | : ** | ;; 64|-: * | ;; | : ** very-clear | ;; 32|-: ** | ;; | : ** | ;; 16|-: *** clear | ;; | : **** | ;; 8|-: **** | ;; | : **** light-haze | ;; 4|-: **** | ;; | : ****** | ;; 2|-: ******** haze thin-| ;; | : *********** fog | ;; 1|-:----------------------------------------------------*******--| ;; |_:____.____:____.____:____.____:____.____:____.____:____.____:_| ;; 1 2 4 8 16 32 64 ;; Meterorological range (km) versus Turbidity ;;@end group ;;@end example (define sol-spec '#(16559.0 16233.7 21127.5 25888.2 25829.1 24232.3 26760.5 29658.3 30545.4 30057.5 30663.7 28830.4 28712.1 27825.0 27100.6 27233.6 26361.3 25503.8 25060.2 25311.6 25355.9 25134.2 24631.5 24173.2 23685.3 23212.1 22827.7 22339.8 21970.2 21526.7 21097.9 20728.3 20240.4 19870.8 19427.2 19072.4 18628.9 18259.2 17960 ;guesses for the rest 17730 17570)) (define k_o-spec '#(0.003 0.006 0.009 0.014 0.021 0.03 0.04 0.048 0.063 0.075 0.085 0.103 0.12 0.12 0.115 0.125 0.12 0.105 0.09 0.079 0.067 0.057 0.048 0.036 0.028 0.023 0.018 0.014 0.011 0.01 0.009 0.007 0.004 0)) ;;@body Returns a vector of 41 values, the spectrum of sunlight from ;;380.nm to 790.nm for a given @1 and @2. (define (sunlight-spectrum turbidity theta_s) (define (solCurve wl) (vector-ref sol-spec (quotient (- wl 380) 10))) (define (k_oCurve wl) (if (>= wl 450) (vector-ref k_o-spec (quotient (- wl 450) 10)) 0)) (define (k_gCurve wl) (case wl ((760) 3.0) ((770) 0.21) (else 0))) (define (k_waCurve wl) (case wl ((690) 0.016) ((700) 0.024) ((710) 0.0125) ((720) 1) ((730) 0.87) ((740) 0.061) ((750) 0.001) ((760) 1.e-05) ((770) 1.e-05) ((780) 0.0006) (else 0))) (define data (make-vector (+ 1 (quotient (- 780 380) 10)) 0.0)) ;;alpha - ratio of small to large particle sizes. (0:4,usually 1.3) (define alpha 1.3) ;;beta - amount of aerosols present (define beta (- (* 0.04608365822050 turbidity) 0.04586025928522)) ;;lOzone - amount of ozone in cm(NTP) (define lOzone .35) ;;w - precipitable water vapor in centimeters (standard = 2) (define w 2.0) ;;m - Relative Optical Mass (define m (/ (+ (cos (* pi/180 theta_s)) (* 0.15 (expt (- 93.885 theta_s) -1.253))))) (and (not (negative? (- 93.885 theta_s))) ;; Compute specturm of sunlight (do ((wl 780 (+ -5 wl))) ((< wl 380) data) (let* (;;Rayleigh Scattering ;; paper and program disagree!! Looks like font-size typo in paper. ;;(tauR (exp (* -0.008735 (expt (/ wl 1000) (* -4.08 m))))) ;sunsky.pdf (tauR (exp (* -0.008735 m (expt (/ wl 1000) -4.08)))) ;RiSunConstants.C ;;Aerosal (water + dust) attenuation ;; paper and program disagree!! Looks like font-size typo in paper. ;;(tauA (exp (* -1 beta (expt (/ wl 1000) (* -1 m alpha))))) (tauA (exp (* -1 m beta (expt (/ wl 1000) (- alpha))))) ;;Attenuation due to ozone absorption (tauO (exp (* -1 m (k_oCurve wl) lOzone))) ;;Attenuation due to mixed gases absorption (tauG (exp (* -1.41 m (k_gCurve wl) (expt (+ 1 (* 118.93 m (k_gCurve wl))) -0.45)))) ;;Attenuation due to water vapor absorbtion (tauWA (exp (* -0.2385 m w (k_waCurve wl) (expt (+ 1 (* 20.07 m w (k_waCurve wl))) -0.45))))) (vector-set! data (quotient (- wl 380) 10) (* (solCurve wl) tauR tauA tauO tauG tauWA)))))) ;;@body Given @1 and @2, @0 returns the CIEXYZ triple for color of ;;sunlight scaled to be just inside the RGB709 gamut. (define (sunlight-chromaticity turbidity theta_s) (define spectrum (sunlight-spectrum turbidity theta_s)) (and spectrum (spectrum->chromaticity spectrum 380.e-9 780.e-9))) ;; Arguments and result in radians (define (angle-between theta phi theta_s phi_s) (define cospsi (+ (* (sin theta) (sin theta_s) (cos (- phi phi_s))) (* (cos theta) (cos theta_s)))) (cond ((> cospsi 1) 0) ((< cospsi -1) pi) (else (acos cospsi)))) ;;@body Returns the xyY (chromaticity and luminance) at the zenith. The ;;Luminance has units kcd/m^2. (define (zenith-xyY turbidity theta_s) (let* ((ths (* theta_s pi/180)) (thetas (do ((th 1 (* ths th)) (lst '() (cons th lst)) (cnt 3 (+ -1 cnt))) ((negative? cnt) lst))) (turbds (do ((tr 1 (* turbidity tr)) (lst '() (cons tr lst)) (cnt 2 (+ -1 cnt))) ((negative? cnt) lst)))) (append (map (lambda (row) (apply + (map * row turbds))) (map color:linear-transform '(((+0.00165 -0.00374 +0.00208 +0 ) (-0.02902 +0.06377 -0.03202 +0.00394) (+0.11693 -0.21196 +0.06052 +0.25885)) ((+0.00275 -0.00610 +0.00316 +0 ) (-0.04214 +0.08970 -0.04153 +0.00515) (+0.15346 -0.26756 +0.06669 +0.26688))) (list thetas thetas))) (list (+ (* (tan (* (+ 4/9 (/ turbidity -120)) (+ pi (* -2 ths)))) (- (* 4.0453 turbidity) 4.9710)) (* -0.2155 turbidity) 2.4192))))) ;;@body @1 is a positive real number expressing the amount of light ;;scattering. The real number @2 is the solar angle from the zenith in ;;degrees. ;; ;;@0 returns a function of one angle @var{theta}, the angle from the ;;zenith of the viewing direction (in degrees); and returning the xyY ;;value for light coming from that elevation of the sky. (define (overcast-sky-color-xyY turbidity theta_s) (define xyY_z (zenith-xyY turbidity theta_s)) (lambda (theta . phi) (list (car xyY_z) (cadr xyY_z) (* 1/3 (caddr xyY_z) (+ 1 (* 2 (cos (* pi/180 theta)))))))) ;;@body @1 is a positive real number expressing the amount of light ;;scattering. The real number @2 is the solar angle from the zenith in ;;degrees. The real number @3 is the solar angle from south. ;; ;;@0 returns a function of two angles, @var{theta} and @var{phi} which ;;specify the angles from the zenith and south meridian of the viewing ;;direction (in degrees); returning the xyY value for light coming from ;;that direction of the sky. ;; ;;@code{sky-color-xyY} calls @code{overcast-sky-color-xyY} for ;;@1 <= 20; otherwise the @0 function. (define (clear-sky-color-xyY turbidity theta_s phi_s) (define xyY_z (zenith-xyY turbidity theta_s)) (define th_s (* pi/180 theta_s)) (define ph_s (* pi/180 phi_s)) (define (F~ A B C D E) (lambda (th gm) (* (+ 1 (* A (exp (/ B (cos th))))) (+ 1 (* C (exp (* D gm))) (* E (expt (cos gm) 2)))))) (let* ((tb1 (list turbidity 1)) (Fs (map (lambda (mat) (apply F~ (color:linear-transform mat tb1))) '((( 0.17872 -1.46303) (-0.35540 +0.42749) (-0.02266 +5.32505) ( 0.12064 -2.57705) (-0.06696 +0.37027)) ((-0.01925 -0.25922) (-0.06651 +0.00081) (-0.00041 +0.21247) (-0.06409 -0.89887) (-0.00325 +0.04517)) ((-0.01669 -0.26078) (-0.09495 +0.00921) (-0.00792 +0.21023) (-0.04405 -1.65369) (-0.01092 +0.05291))))) (F_0s (map (lambda (F) (F 0 th_s)) Fs))) (lambda (theta phi) (let* ((th (* pi/180 theta)) (ph (* pi/180 phi)) (gm (angle-between th_s ph_s th ph))) ;;(print th ph '=> gm) (map (lambda (x F F_0) (* x (/ (F th gm) F_0))) xyY_z Fs F_0s))))) (define (sky-color-xyY turbidity theta_s phi_s) (if (> turbidity 20) (overcast-sky-color-xyY turbidity theta_s) (clear-sky-color-xyY turbidity theta_s phi_s))) slib-3b1/daylight.txi0000644001705200017500000001107110747237372012537 0ustar tbtb@code{(require 'daylight)} @ftindex daylight @ftindex sunlight @ftindex sun @ftindex sky @noindent This package calculates the colors of sky as detailed in:@* @uref{http://www.cs.utah.edu/vissim/papers/sunsky/sunsky.pdf}@* @cite{A Practical Analytic Model for Daylight}@* A. J. Preetham, Peter Shirley, Brian Smits @defun solar-hour julian-day hour Returns the solar-time in hours given the integer @var{julian-day} in the range 1 to 366, and the local time in hours. To be meticulous, subtract 4 minutes for each degree of longitude west of the standard meridian of your time zone. @end defun @defun solar-declination julian-day @end defun @defun solar-polar declination latitude solar-hour Returns a list of @var{theta_s}, the solar angle from the zenith, and @var{phi_s}, the solar azimuth. 0 <= @var{theta_s} measured in degrees. @var{phi_s} is measured in degrees from due south; west of south being positive. @end defun @noindent In the following procedures, the number 0 <= @var{theta_s} <= 90 is the solar angle from the zenith in degrees. @cindex turbidity @noindent Turbidity is a measure of the fraction of scattering due to haze as opposed to molecules. This is a convenient quantity because it can be estimated based on visibility of distant objects. This model fails for turbidity values less than 1.3. @example @group _______________________________________________________________ 512|-: | | * pure-air | 256|-:** | | : ** exceptionally-clear | 128|-: * | | : ** | 64|-: * | | : ** very-clear | 32|-: ** | | : ** | 16|-: *** clear | | : **** | 8|-: **** | | : **** light-haze | 4|-: **** | | : ****** | 2|-: ******** haze thin-| | : *********** fog | 1|-:----------------------------------------------------*******--| |_:____.____:____.____:____.____:____.____:____.____:____.____:_| 1 2 4 8 16 32 64 Meterorological range (km) versus Turbidity @end group @end example @defun sunlight-spectrum turbidity theta_s Returns a vector of 41 values, the spectrum of sunlight from 380.nm to 790.nm for a given @var{turbidity} and @var{theta_s}. @end defun @defun sunlight-chromaticity turbidity theta_s Given @var{turbidity} and @var{theta_s}, @code{sunlight-chromaticity} returns the CIEXYZ triple for color of sunlight scaled to be just inside the RGB709 gamut. @end defun @defun zenith-xyy turbidity theta_s Returns the xyY (chromaticity and luminance) at the zenith. The Luminance has units kcd/m^2. @end defun @defun overcast-sky-color-xyy turbidity theta_s @var{turbidity} is a positive real number expressing the amount of light scattering. The real number @var{theta_s} is the solar angle from the zenith in degrees. @code{overcast-sky-color-xyy} returns a function of one angle @var{theta}, the angle from the zenith of the viewing direction (in degrees); and returning the xyY value for light coming from that elevation of the sky. @end defun @defun clear-sky-color-xyy turbidity theta_s phi_s @defunx sky-color-xyy turbidity theta_s phi_s @var{turbidity} is a positive real number expressing the amount of light scattering. The real number @var{theta_s} is the solar angle from the zenith in degrees. The real number @var{phi_s} is the solar angle from south. @code{clear-sky-color-xyy} returns a function of two angles, @var{theta} and @var{phi} which specify the angles from the zenith and south meridian of the viewing direction (in degrees); returning the xyY value for light coming from that direction of the sky. @code{sky-color-xyY} calls @code{overcast-sky-color-xyY} for @var{turbidity} <= 20; otherwise the @code{clear-sky-color-xyy} function. @end defun slib-3b1/db2html.scm0000644001705200017500000004457110351362043012240 0ustar tbtb;"db2html.scm" Convert relational database to hyperlinked pages. ; Copyright 1997, 1998, 2000, 2001 Aubrey Jaffer ; ;Permission to copy this software, to modify it, to redistribute it, ;to distribute modified versions, and to use it for any purpose is ;granted, subject to the following restrictions and understandings. ; ;1. Any copy made of this software must include this copyright notice ;in full. ; ;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; ;3. In conjunction with products arising from the use of this ;material, there shall be no use of my name in any advertising, ;promotional, or sales literature without prior written consent in ;each case. (require 'uri) (require 'printf) (require 'html-form) (require 'directory) (require 'databases) (require 'string-case) (require 'string-search) (require 'common-list-functions) (require-if 'compiling 'pretty-print) (require-if 'compiling 'database-commands) (require 'hash) (define (crc:hash-obj obj) (number->string (hash obj most-positive-fixnum) 16)) ;;@code{(require 'db->html)} ;;@ftindex db->html ;;@body (define (html:table options . rows) (apply string-append (sprintf #f "\\n" (or options "")) (append rows (list (sprintf #f "
\\n"))))) ;;@args caption align ;;@args caption ;;@2 can be @samp{top} or @samp{bottom}. (define (html:caption caption . align) (if (null? align) (sprintf #f " %s\\n" (html:plain caption)) (sprintf #f " %s\\n" (car align) (html:plain caption)))) ;;@body Outputs a heading row for the currently-started table. (define (html:heading columns) (sprintf #f " \\n%s\\n" (apply string-append (map (lambda (datum) (sprintf #f " %s\\n" (or datum ""))) columns)))) ;;@body Outputs a heading row with column-names @1 linked to URIs @2. (define (html:href-heading columns uris) (html:heading (map (lambda (column uri) (if uri (html:link uri column) column)) columns uris))) (define (row->anchor pkl row) (sprintf #f "" (uri:make-path (butnthcdr pkl row)))) ;;@args k foreigns ;; ;;The positive integer @1 is the primary-key-limit (number of ;;primary-keys) of the table. @2 is a list of the filenames of ;;foreign-key field pages and #f for non foreign-key fields. ;; ;;@0 returns a procedure taking a row for its single argument. This ;;returned procedure returns the html string for that table row. (define (html:linked-row-converter pkl foreigns) (define idxs (do ((idx (length foreigns) (+ -1 idx)) (nats '() (cons idx nats))) ((not (positive? idx)) nats))) (require 'pretty-print) (lambda (row) (define (present datum) (if (or (string? datum) (symbol? datum)) (html:plain datum) (let* ((str (pretty-print->string datum)) (len (+ -1 (string-length str)))) (cond ((eqv? (string-index str #\newline) len) (string-append "" (substring str 0 len) "")) (else (html:pre str)))))) (sprintf #f " \\n%s\\n" (apply string-append (map (lambda (idx datum foreign) (sprintf #f " %s%s\\n" (if (eqv? 1 idx) (row->anchor pkl row) "") (cond ((or (not datum) (null? datum)) "") ((not foreign) (present datum)) ((equal? "catalog-data.html" foreign) (html:link (make-uri (table-name->filename datum) #f #f) (present datum))) (else (html:link (make-uri foreign #f datum) (present datum)))))) idxs row foreigns))))) ;;@body ;;Returns the symbol @1 converted to a filename. (define (table-name->filename table-name) (and table-name (string-append (string-subst (symbol->string table-name) "*" "" ":" "_") ".html"))) (define (table-name->column-table-name db table-name) ((((db 'open-table) '*catalog-data* #f) 'get 'coltab-name) table-name)) ;;@args caption db table-name match-key1 @dots{} ;;Returns HTML string for @2 table @3 chopped into 50-row HTML tables. ;;Every foreign-key value is linked to the page (of the table) ;;defining that key. ;; ;;The optional @4 @dots{} arguments restrict actions to a subset of ;;the table. @xref{Table Operations, match-key}. (define (table->linked-html caption db table-name . args) (let* ((table ((db 'open-table) table-name #f)) (foreigns (table 'column-foreigns)) (tags (map table-name->filename foreigns)) (names (table 'column-names)) (primlim (table 'primary-limit))) (define tables '()) (define rows '()) (define cnt 0) (define (make-table rows) (apply html:table "CELLSPACING=0 BORDER=1" (html:caption caption 'BOTTOM) (html:href-heading names (append (make-list primlim (table-name->filename (table-name->column-table-name db table-name))) (make-list (- (length names) primlim) #f))) (html:heading (table 'column-domains)) (html:href-heading foreigns tags) (html:heading (table 'column-types)) rows)) (apply (table 'for-each-row) (lambda (row) (set! cnt (+ 1 cnt)) (set! rows (cons row rows)) (cond ((<= 50 cnt) (set! tables (cons (make-table (map (html:linked-row-converter primlim tags) (reverse rows))) tables)) (set! cnt 0) (set! rows '())))) args) (apply string-append (reverse (if (and (null? rows) (not (null? tables))) tables (cons (make-table (map (html:linked-row-converter primlim tags) (reverse rows))) tables)))))) ;;@body ;;Returns a complete HTML page. The string @3 names the page which ;;refers to this one. ;; ;;The optional @4 @dots{} arguments restrict actions to a subset of ;;the table. @xref{Table Operations, match-key}. (define (table->linked-page db table-name index-filename . args) (string-append (if index-filename (html:head table-name (html:link (make-uri index-filename #f table-name) (html:plain table-name))) (html:head table-name)) (html:body (apply table->linked-html table-name db table-name args)))) (define (html:catalog-row-converter row foreigns) (sprintf #f " \\n%s\\n" (apply string-append (map (lambda (datum foreign) (sprintf #f " %s%s\\n" (html:anchor (sprintf #f "%s" datum)) (html:link (make-uri foreign #f #f) datum))) row foreigns)))) ;;@body ;;Returns HTML string for the catalog table of @1. (define (catalog->html db caption . args) (apply html:table "BORDER=1" (html:caption caption 'BOTTOM) (html:heading '(table columns)) (map (lambda (row) (cond ((and (eq? '*columns* (caddr row)) (not (eq? '*columns* (car row)))) "") (else (html:catalog-row-converter (list (car row) (caddr row)) (list (table-name->filename (car row)) (table-name->filename (caddr row))))))) (apply (((db 'open-table) '*catalog-data* #f) 'row:retrieve*) args)))) ;;Returns complete HTML page (string) for the catalog table of @1. (define (catalog->page db caption . args) (string-append (html:head caption) (html:body (apply catalog->html db caption args)))) ;;@subsection HTML editing tables ;;@noindent A client can modify one row of an editable table at a time. ;;For any change submitted, these routines check if that row has been ;;modified during the time the user has been editing the form. If so, ;;an error page results. ;; ;;@noindent The behavior of edited rows is: ;; ;;@itemize @bullet ;;@item ;;If no fields are changed, then no change is made to the table. ;;@item ;;If the primary keys equal null-keys (parameter defaults), and no other ;;user has modified that row, then that row is deleted. ;;@item ;;If only primary keys are changed, there are non-key fields, and no ;;row with the new keys is in the table, then the old row is ;;deleted and one with the new keys is inserted. ;;@item ;;If only non-key fields are changed, and that row has not been ;;modified by another user, then the row is changed to reflect the ;;fields. ;;@item ;;If both keys and non-key fields are changed, and no row with the ;;new keys is in the table, then a row is created with the new ;;keys and fields. ;;@item ;;If fields are changed, all fields are primary keys, and no row with ;;the new keys is in the table, then a row is created with the new ;;keys. ;;@end itemize ;; ;;@noindent After any change to the table, a @code{sync-database} of the ;;database is performed. ;;@args table-name null-keys update delete retrieve ;;@args table-name null-keys update delete ;;@args table-name null-keys update ;;@args table-name null-keys ;; ;;Returns procedure (of @var{db}) which returns procedure to modify ;;row of @1. @2 is the list of @dfn{null} keys indicating the row is ;;to be deleted when any matches its corresponding primary key. ;;Optional arguments @3, @4, and @5 default to the @code{row:update}, ;;@code{row:delete}, and @code{row:retrieve} of @1 in @var{db}. (define (command:modify-table table-name null-keys . args) (define argc (length args)) (lambda (rdb) (define table ((rdb 'open-table) table-name #t)) (let ((table:update (or (and (> argc 0) (car args)) (table 'row:update))) (table:delete (or (and (> argc 1) (cadr args)) (table 'row:delete))) (table:retrieve (or (and (> argc 2) (caddr args)) (table 'row:retrieve))) (pkl (length null-keys))) (define ptypes (butnthcdr pkl (table 'column-types))) (if (> argc 4) (slib:error 'command:modify-table 'too-many-args table-name null-keys args)) (lambda (*keys* *row-hash* . new-row) (let* ((new-pkeys (butnthcdr pkl new-row)) (pkeys (uri:path->keys (uri:split-fields *keys* #\/) ptypes)) (row (apply table:retrieve pkeys)) (same-nonkeys? (equal? (nthcdr pkl new-row) (nthcdr pkl row)))) (cond ((equal? pkeys new-pkeys) ;did not change keys (cond ((not row) '("Row deleted by other user")) ((equal? (crc:hash-obj row) *row-hash*) (table:update new-row) ((rdb 'sync-database)) #t) (else '("Row changed by other user")))) ((command:null-key? null-keys new-pkeys) ;blanked keys (cond ((not row) #t) ((equal? (crc:hash-obj row) *row-hash*) ;;(slib:warn (sprintf #f "Removing key: %#a => %#a" new-pkeys )) (apply table:delete pkeys) ((rdb 'sync-database)) #t) (else '("Row changed by other user")))) (else ;changed keys (set! row (apply table:retrieve new-pkeys)) (cond (row (list "Row already exists" (sprintf #f "%#a" row))) (else (table:update new-row) (if (and same-nonkeys? (not (null? (nthcdr pkl new-row)))) (apply table:delete pkeys)) ((rdb 'sync-database)) #t))))))))) (define (command:null-key? null-keys new-pkeys) (define sts #f) (for-each (lambda (nuk nep) (if (equal? nuk nep) (set! sts #t))) null-keys new-pkeys) sts) (define (make-defaulter arity type) `(lambda (pl) ',(case arity ((optional nary) '()) ((boolean) #f) ((single nary1) (case type ((string) '("")) ((symbol) '(nil)) ((number) '(0)) (else '(#f)))) (else (slib:error 'make-defaulter 'unknown 'arity arity))))) ;;@body Given @2 in @1, creates parameter and @code{*command*} tables ;;for editing one row of @2 at a time. @0 returns a procedure taking a ;;row argument which returns the HTML string for editing that row. ;; ;;Optional @3 are expressions (lists) added to the call to ;;@code{command:modify-table}. ;; ;;The domain name of a column determines the expected arity of the data ;;stored in that column. Domain names ending in: ;; ;;@table @samp ;;@item * ;;have arity @samp{nary}; ;;@item + ;;have arity @samp{nary1}. ;;@end table (define (command:make-editable-table rdb table-name . args) (define table ((rdb 'open-table) table-name #t)) (require 'database-commands) (let ((pkl (table 'primary-limit)) (columns (table 'column-names)) (domains (table 'column-domains)) (types (table 'column-types)) (idxs (do ((idx (length (table 'column-names)) (+ -1 idx)) (nats '() (cons (+ 2 idx) nats))) ((not (positive? idx)) nats))) (ftn (((rdb 'open-table) '*domains-data* #f) 'get 'foreign-table))) (define field-specs (map (lambda (idx column domain type) (let* ((dstr (symbol->string domain)) (len (+ -1 (string-length dstr)))) (define arity (case (string-ref dstr len) ((#\*) 'nary) ((#\+) 'nary1) (else (if (eq? 'boolean type) 'boolean 'single)))) (case (string-ref dstr len) ((#\* #\+) (set! type (string->symbol (substring dstr 0 len))) (set! domain type))) `(,idx ,column ,arity ,domain ,(make-defaulter arity type) #f ""))) idxs columns domains types)) (define foreign-choice-lists (map (lambda (domain-name) (define tab-name (ftn domain-name)) (if tab-name (get-foreign-choices ((rdb 'open-table) tab-name #f)) '())) domains)) (define-tables rdb `(,(symbol-append table-name '- 'params) *parameter-columns* *parameter-columns* ((1 *keys* single string #f #f "") (2 *row-hash* single string #f #f "") ,@field-specs)) `(,(symbol-append table-name '- 'pname) ((name string)) ((parameter-index ordinal)) ;should be address-params (("*keys*" 1) ("*row-hash*" 2) ,@(map (lambda (idx column) (list (symbol->string column) idx)) idxs columns))) `(*commands* desc:*commands* desc:*commands* ((,(symbol-append 'edit '- table-name) ,(symbol-append table-name '- 'params) ,(symbol-append table-name '- 'pname) (command:modify-table ',table-name ',(map (lambda (fs) (define dfl ((slib:eval (car (cddddr fs))) '())) (if (pair? dfl) (car dfl) dfl)) (butnthcdr pkl field-specs)) ,@args) ,(string-append "Modify " (symbol->string table-name)))))) (let ((arities (map caddr field-specs))) (lambda (row) (define elements (map form:element columns arities (map (lambda (fld arity) (case arity ((nary nary1) fld) (else (list fld)))) row arities) foreign-choice-lists)) (sprintf #f " \\n %s%s\\n\\n" (string-append (html:hidden '*row-hash* (crc:hash-obj row)) (html:hidden '*keys* (uri:make-path (butnthcdr pkl row))) ;; (html:hidden '*suggest* '<>) (car elements) (form:submit '<> (symbol-append 'edit '- table-name)) ;; (form:image "Modify Row" "/icons/bang.png") ) (apply string-append (map (lambda (elt) (sprintf #f " %s\\n" elt)) (cdr elements)))))))) ;;@args k names edit-point edit-converter ;; ;;The positive integer @1 is the primary-key-limit (number of ;;primary-keys) of the table. @2 is a list of the field-names. @3 is ;;the list of primary-keys denoting the row to edit (or #f). @4 is the ;;procedure called with @1, @2, and the row to edit. ;; ;;@0 returns a procedure taking a row for its single argument. This ;;returned procedure returns the html string for that table row. ;; ;;Each HTML table constructed using @0 has first @1 fields (typically ;;the primary key fields) of each row linked to a text encoding of these ;;fields (the result of calling @code{row->anchor}). The page so ;;referenced typically allows the user to edit fields of that row. (define (html:editable-row-converter pkl names edit-point edit-converter) (require 'pretty-print) (let ((idxs (do ((idx (length names) (+ -1 idx)) (nats '() (cons idx nats))) ((not (positive? idx)) nats))) (datum->html (lambda (datum) (if (or (string? datum) (symbol? datum)) (html:plain datum) (let* ((str (pretty-print->string datum)) (len (+ -1 (string-length str)))) (cond ((eqv? (string-index str #\newline) len) (string-append "" (substring str 0 len) "")) (else (html:pre str)))))))) (lambda (row) (string-append (sprintf #f " \\n%s\\n" (apply string-append (map (lambda (idx datum foreign) (sprintf #f " %s%s\\n" (if (eqv? 1 idx) (row->anchor pkl row) "") (cond ((or (not datum) (null? datum)) "") ((<= idx pkl) (let ((keystr (uri:make-path (butnthcdr pkl row)))) (sprintf #f "%s" keystr keystr (datum->html datum)))) (else (datum->html datum))))) idxs row names))) (if (and edit-point edit-converter (equal? (butnthcdr pkl edit-point) (butnthcdr pkl row))) (edit-converter row) ""))))) ;;@subsection HTML databases ;;@body @1 must be a relational database. @2 must be #f or a ;;non-empty string naming an existing sub-directory of the current ;;directory. ;; ;;@0 creates an html page for each table in the database @1 in the ;;sub-directory named @2, or the current directory if @2 is #f. The ;;top level page with the catalog of tables (captioned @4) is written ;;to a file named @3. (define (db->html-files db dir index-filename caption) (set! dir (if dir (sub-vicinity "" dir) "")) (call-with-output-file (in-vicinity dir index-filename) (lambda (port) (display (catalog->page db caption) port))) (let ((catdat ((db 'open-table) '*catalog-data* #f))) ((or (catdat 'for-each-row-in-order) (catdat 'for-each-row)) (lambda (row) (call-with-output-file (in-vicinity dir (table-name->filename (car row))) (lambda (port) (display (table->linked-page db (car row) index-filename) port))))))) ;;@args db dir index-filename ;;@args db dir ;;@1 must be a relational database. @2 must be a non-empty ;;string naming an existing sub-directory of the current directory or ;;one to be created. The optional string @3 names the filename of the ;;top page, which defaults to @file{index.html}. ;; ;;@0 creates sub-directory @2 if neccessary, and calls ;;@code{(db->html-files @1 @2 @3 @2)}. The @samp{file:} URI of @3 is ;;returned. (define (db->html-directory db dir . index-filename) (set! index-filename (if (null? index-filename) "index.html" (car index-filename))) (if (symbol? dir) (set! dir (symbol->string dir))) (if (not (file-exists? dir)) (make-directory dir)) (db->html-files db dir index-filename dir) (path->uri (in-vicinity (sub-vicinity (user-vicinity) dir) index-filename))) ;;@args db dir index-filename ;;@args db dir ;;@0 is just like @code{db->html-directory}, but calls ;;@code{browse-url} with the uri for the top page after the ;;pages are created. (define (db->netscape . args) (browse-url (apply db->html-directory args))) slib-3b1/db2html.txi0000644001705200017500000001463310747237372012275 0ustar tbtb@code{(require 'db->html)} @ftindex db->html @defun html:table options row @dots{} @end defun @defun html:caption caption align @defunx html:caption caption @var{align} can be @samp{top} or @samp{bottom}. @end defun @defun html:heading columns Outputs a heading row for the currently-started table. @end defun @defun html:href-heading columns uris Outputs a heading row with column-names @var{columns} linked to URIs @var{uris}. @end defun @defun html:linked-row-converter k foreigns The positive integer @var{k} is the primary-key-limit (number of primary-keys) of the table. @var{foreigns} is a list of the filenames of foreign-key field pages and #f for non foreign-key fields. @code{html:linked-row-converter} returns a procedure taking a row for its single argument. This returned procedure returns the html string for that table row. @end defun @defun table-name->filename table-name Returns the symbol @var{table-name} converted to a filename. @end defun @defun table->linked-html caption db table-name match-key1 @dots{} Returns HTML string for @var{db} table @var{table-name} chopped into 50-row HTML tables. Every foreign-key value is linked to the page (of the table) defining that key. The optional @var{match-key1} @dots{} arguments restrict actions to a subset of the table. @xref{Table Operations, match-key}. @end defun @defun table->linked-page db table-name index-filename arg @dots{} Returns a complete HTML page. The string @var{index-filename} names the page which refers to this one. The optional @var{args} @dots{} arguments restrict actions to a subset of the table. @xref{Table Operations, match-key}. @end defun @defun catalog->html db caption arg @dots{} Returns HTML string for the catalog table of @var{db}. @end defun @subsection HTML editing tables @noindent A client can modify one row of an editable table at a time. For any change submitted, these routines check if that row has been modified during the time the user has been editing the form. If so, an error page results. @noindent The behavior of edited rows is: @itemize @bullet @item If no fields are changed, then no change is made to the table. @item If the primary keys equal null-keys (parameter defaults), and no other user has modified that row, then that row is deleted. @item If only primary keys are changed, there are non-key fields, and no row with the new keys is in the table, then the old row is deleted and one with the new keys is inserted. @item If only non-key fields are changed, and that row has not been modified by another user, then the row is changed to reflect the fields. @item If both keys and non-key fields are changed, and no row with the new keys is in the table, then a row is created with the new keys and fields. @item If fields are changed, all fields are primary keys, and no row with the new keys is in the table, then a row is created with the new keys. @end itemize @noindent After any change to the table, a @code{sync-database} of the database is performed. @defun command:modify-table table-name null-keys update delete retrieve @defunx command:modify-table table-name null-keys update delete @defunx command:modify-table table-name null-keys update @defunx command:modify-table table-name null-keys Returns procedure (of @var{db}) which returns procedure to modify row of @var{table-name}. @var{null-keys} is the list of @dfn{null} keys indicating the row is @cindex null to be deleted when any matches its corresponding primary key. Optional arguments @var{update}, @var{delete}, and @var{retrieve} default to the @code{row:update}, @code{row:delete}, and @code{row:retrieve} of @var{table-name} in @var{db}. @end defun @defun command:make-editable-table rdb table-name arg @dots{} Given @var{table-name} in @var{rdb}, creates parameter and @code{*command*} tables for editing one row of @var{table-name} at a time. @code{command:make-editable-table} returns a procedure taking a row argument which returns the HTML string for editing that row. Optional @var{args} are expressions (lists) added to the call to @code{command:modify-table}. The domain name of a column determines the expected arity of the data stored in that column. Domain names ending in: @table @samp @item * have arity @samp{nary}; @item + have arity @samp{nary1}. @end table @end defun @defun html:editable-row-converter k names edit-point edit-converter The positive integer @var{k} is the primary-key-limit (number of primary-keys) of the table. @var{names} is a list of the field-names. @var{edit-point} is the list of primary-keys denoting the row to edit (or #f). @var{edit-converter} is the procedure called with @var{k}, @var{names}, and the row to edit. @code{html:editable-row-converter} returns a procedure taking a row for its single argument. This returned procedure returns the html string for that table row. Each HTML table constructed using @code{html:editable-row-converter} has first @var{k} fields (typically the primary key fields) of each row linked to a text encoding of these fields (the result of calling @code{row->anchor}). The page so referenced typically allows the user to edit fields of that row. @end defun @subsection HTML databases @defun db->html-files db dir index-filename caption @var{db} must be a relational database. @var{dir} must be #f or a non-empty string naming an existing sub-directory of the current directory. @code{db->html-files} creates an html page for each table in the database @var{db} in the sub-directory named @var{dir}, or the current directory if @var{dir} is #f. The top level page with the catalog of tables (captioned @var{caption}) is written to a file named @var{index-filename}. @end defun @defun db->html-directory db dir index-filename @defunx db->html-directory db dir @var{db} must be a relational database. @var{dir} must be a non-empty string naming an existing sub-directory of the current directory or one to be created. The optional string @var{index-filename} names the filename of the top page, which defaults to @file{index.html}. @code{db->html-directory} creates sub-directory @var{dir} if neccessary, and calls @code{(db->html-files @var{db} @var{dir} @var{index-filename} @var{dir})}. The @samp{file:} URI of @var{index-filename} is returned. @end defun @defun db->netscape db dir index-filename @defunx db->netscape db dir @code{db->netscape} is just like @code{db->html-directory}, but calls @code{browse-url} with the uri for the top page after the pages are created. @end defun slib-3b1/dbcom.scm0000644001705200017500000001644207751112010011761 0ustar tbtb;;; "dbcom.scm" embed commands in relational-database ; Copyright 1994, 1995, 1997, 2000, 2001 Aubrey Jaffer ; ;Permission to copy this software, to modify it, to redistribute it, ;to distribute modified versions, and to use it for any purpose is ;granted, subject to the following restrictions and understandings. ; ;1. Any copy made of this software must include this copyright notice ;in full. ; ;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; ;3. In conjunction with products arising from the use of this ;material, there shall be no use of my name in any advertising, ;promotional, or sales literature without prior written consent in ;each case. (require 'common-list-functions) ;for position (require 'relational-database) (require 'databases) ;@ (define (wrap-command-interface rdb) (let* ((rdms:commands ((rdb 'open-table) '*commands* #f)) (command:get (and rdms:commands (rdms:commands 'get 'procedure)))) (and command:get (letrec ((wdb (lambda (command) (let ((com (command:get command))) (if com ((slib:eval com) wdb) (rdb command)))))) (let ((init (wdb '*initialize*))) (if (procedure? init) init wdb)))))) ;@ (define (open-command-database! path . arg) (define bt (apply open-database! path arg)) (and bt (wrap-command-interface bt))) ;@ (define (open-command-database path . arg) (define bt (apply open-database path arg)) (and bt (wrap-command-interface bt))) ;@ (define (add-command-tables rdb) (define-tables rdb '(type ((name symbol)) () ((atom) (symbol) (string) (number) (money) (date-time) (boolean) (foreign-key) (expression) (virtual))) '(parameter-arity ((name symbol)) ((predicate? expression) (procedure expression)) ((single (lambda (a) (and (pair? a) (null? (cdr a)))) car) (optional (lambda (lambda (a) (or (null? a) (and (pair? a) (null? (cdr a)))))) identity) (boolean (lambda (a) (or (null? a) (and (pair? a) (null? (cdr a)) (boolean? (car a))))) (lambda (a) (if (null? a) #f (car a)))) (nary (lambda (a) #t) identity) (nary1 (lambda (a) (not (null? a))) identity)))) (for-each (((rdb 'open-table) '*domains-data* #t) 'row:insert) '((parameter-list *catalog-data* #f symbol 1) (parameter-name-translation *catalog-data* #f symbol 1) (parameter-arity parameter-arity #f symbol 1) (table *catalog-data* #f atom 1))) (define-tables rdb '(*parameter-columns* *columns* *columns* ((1 #t index #f ordinal) (2 #f name #f symbol) (3 #f arity #f parameter-arity) (4 #f domain #f domain) (5 #f defaulter #f expression) (6 #f expander #f expression) (7 #f documentation #f string))) '(no-parameters *parameter-columns* *parameter-columns* ()) '(no-parameter-names ((name string)) ((parameter-index ordinal)) ()) '(add-domain-params *parameter-columns* *parameter-columns* ((1 domain-name single atom #f #f "new domain name") (2 foreign-table optional table #f #f "if present, domain-name must be existing key into this table") (3 domain-integrity-rule optional expression #f #f "returns #t if single argument is good") (4 type-id single type #f #f "base type of new domain") (5 type-param optional expression #f #f "which (key) field of the foreign-table") )) '(add-domain-pnames ((name string)) ((parameter-index ordinal)) ;should be add-domain-params ( ("n" 1) ("name" 1) ("f" 2) ("foreign (key) table" 2) ("r" 3) ("domain integrity rule" 3) ("t" 4) ("type" 4) ("p" 5) ("type param" 5) )) '(del-domain-params *parameter-columns* *parameter-columns* ((1 domain-name single domain #f #f "domain name"))) '(del-domain-pnames ((name string)) ((parameter-index ordinal)) ;should be del-domain-params (("n" 1) ("name" 1))) '(*commands* ((name symbol)) ((parameters parameter-list) (parameter-names parameter-name-translation) (procedure expression) (documentation string)) ((domain-checker no-parameters no-parameter-names dbcom:check-domain "return procedure to check given domain name") (add-domain add-domain-params add-domain-pnames (lambda (rdb) (((rdb 'open-table) '*domains-data* #t) 'row:update)) "add a new domain") (delete-domain del-domain-params del-domain-pnames (lambda (rdb) (((rdb 'open-table) '*domains-data* #t) 'row:remove)) "delete a domain")))) (let* ((tab ((rdb 'open-table) '*domains-data* #t)) (row ((tab 'row:retrieve) 'type))) ((tab 'row:update) (cons 'type (cdr row)))) (wrap-command-interface rdb)) ;@ (define (define-*commands* rdb . cmd-defs) (define defcmd (((rdb 'open-table) '*commands* #t) 'row:update)) (for-each (lambda (def) (define procname (caar def)) (define args (cdar def)) (define body (cdr def)) (let ((comment (and (string? (car body)) (car body)))) (define nbody (if comment (cdr body) body)) (defcmd (list procname 'no-parameters 'no-parameter-names `(lambda ,args ,@nbody) (or comment ""))))) cmd-defs)) ;; Actually put into command table by add-command-tables (define (dbcom:check-domain rdb) (let* ((ro:domains ((rdb 'open-table) '*domains-data* #f)) (ro:get-dir (ro:domains 'get 'domain-integrity-rule)) (ro:for-tab (ro:domains 'get 'foreign-table))) (lambda (domain) (let ((fkname (ro:for-tab domain)) (dir (slib:eval (ro:get-dir domain)))) (if fkname (let* ((fktab ((rdb 'open-table) fkname #f)) (p? (fktab 'get 1))) (if dir (lambda (e) (and (dir e) (p? e))) p?)) dir))))) ;@ (define (make-command-server rdb command-table) (let* ((comtab ((rdb 'open-table) command-table #f)) (names (comtab 'column-names)) (row-ref (lambda (row name) (list-ref row (position name names)))) (comgetrow (comtab 'row:retrieve))) (lambda (comname command-callback) (cond ((not comname) (set! comname '*default*))) (cond ((not (comgetrow comname)) (slib:error 'command 'not 'known: comname))) (let* ((command:row (comgetrow comname)) (parameter-table ((rdb 'open-table) (row-ref command:row 'parameters) #f)) (parameter-names ((rdb 'open-table) (row-ref command:row 'parameter-names) #f)) (comval ((slib:eval (row-ref command:row 'procedure)) rdb)) (options ((parameter-table 'get* 'name))) (positions ((parameter-table 'get* 'index))) (arities ((parameter-table 'get* 'arity))) (defaulters (map slib:eval ((parameter-table 'get* 'defaulter)))) (domains ((parameter-table 'get* 'domain))) (types (map (((rdb 'open-table) '*domains-data* #f) 'get 'type-id) domains)) (dirs (map (or (rdb 'domain-checker) (lambda (domain) (lambda (domain) #t))) domains)) (aliases (map list ((parameter-names 'get* 'name)) (map (parameter-table 'get 'name) ((parameter-names 'get* 'parameter-index)))))) (command-callback comname comval options positions arities types defaulters dirs aliases))))) slib-3b1/dbinterp.scm0000644001705200017500000000335110665342032012506 0ustar tbtb;;; "dbinterp.scm" Interpolate function from database table. ;Copyright 2003 Aubrey Jaffer ; ;Permission to copy this software, to modify it, to redistribute it, ;to distribute modified versions, and to use it for any purpose is ;granted, subject to the following restrictions and understandings. ; ;1. Any copy made of this software must include this copyright notice ;in full. ; ;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; ;3. In conjunction with products arising from the use of this ;material, there shall be no use of my name in any advertising, ;promotional, or sales literature without prior written consent in ;each case. ;;; The procedures returned by MEMOIZE are not reentrant! (define (dbinterp:memoize proc k) (define recent (vector->list (make-vector k '(#f)))) (let ((tailr (last-pair recent))) (lambda args (define asp (assoc args recent)) (if asp (cdr asp) (let ((val (apply proc args))) (set-cdr! tailr (list (cons args val))) (set! tailr (cdr tailr)) (set! recent (cdr recent)) val))))) ;;@ This procedure works only for tables with a single primary key. (define (interpolate-from-table table column) (define get (table 'get column)) (define prev (table 'isam-prev)) (define next (table 'isam-next)) (dbinterp:memoize (lambda (x) (let ((nxt (next x))) (if nxt (set! nxt (car nxt))) (let ((prv (prev (or nxt x)))) (if prv (set! prv (car prv))) (cond ((not nxt) (get prv)) ((not prv) (get nxt)) (else (/ (+ (* (- x prv) (get nxt)) (* (- nxt x) (get prv))) (- nxt prv))))))) 3)) slib-3b1/dbrowse.scm0000644001705200017500000000632307776076457012376 0ustar tbtb;;; "dbrowse.scm" relational-database-browser ; Copyright 1996, 1997, 1998 Aubrey Jaffer ; ;Permission to copy this software, to modify it, to redistribute it, ;to distribute modified versions, and to use it for any purpose is ;granted, subject to the following restrictions and understandings. ; ;1. Any copy made of this software must include this copyright notice ;in full. ; ;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; ;3. In conjunction with products arising from the use of this ;material, there shall be no use of my name in any advertising, ;promotional, or sales literature without prior written consent in ;each case. (require 'databases) (require 'printf) (define browse:db #f) ;@ (define (browse . args) (define table-name #f) (cond ((null? args)) ((procedure? (car args)) (set! browse:db (car args)) (set! args (cdr args))) ((string? (car args)) (set! browse:db (open-database (car args))) (set! args (cdr args)))) (cond ((null? args)) (else (set! table-name (car args)))) (let* ((open-table (browse:db 'open-table)) (catalog (and open-table (open-table '*catalog-data* #f)))) (cond ((not catalog) (slib:error 'browse "could not open catalog")) ((not table-name) (browse:display-dir '*catalog-data* catalog)) (else (let ((table (open-table table-name #f))) (cond (table (browse:display-table table-name table) (table 'close-table)) (else (slib:error 'browse "could not open table" table-name)))))))) (define (browse:display-dir table-name table) (printf "%s Tables:\\n" table-name) ((or (table 'for-each-row-in-order) (table 'for-each-row)) (lambda (row) (printf "\\t%a\\n" (car row))))) (define (browse:display-table table-name table) (let* ((width 18) (dw (string-append "%-" (number->string width))) (dwp (string-append "%-" (number->string width) "." (number->string (+ -1 width)))) (dwp-string (string-append dwp "s")) (dwp-any (string-append dwp "a")) (dw-integer (string-append dw "d")) (underline (string-append (make-string (+ -1 width) #\=) " ")) (form "")) (printf "Table: %s\\n" table-name) (for-each (lambda (name) (printf dwp-string name)) (table 'column-names)) (newline) (for-each (lambda (foreign) (printf dwp-any foreign)) (table 'column-foreigns)) (newline) (for-each (lambda (domain) (printf dwp-string domain)) (table 'column-domains)) (newline) (for-each (lambda (type) (case type ((integer number ordinal base-id uint) (set! form (string-append form dw-integer))) ((boolean domain expression atom) (set! form (string-append form dwp-any))) ((string symbol) (set! form (string-append form dwp-string))) (else (slib:error 'browse:display-table "unknown type" type))) (printf dwp-string type)) (table 'column-types)) (newline) (set! form (string-append form "\\n")) (for-each (lambda (domain) (printf underline)) (table 'column-domains)) (newline) ((or (table 'for-each-row-in-order) (table 'for-each-row)) (lambda (row) (apply printf form row))))) slib-3b1/dbsyn.scm0000644001705200017500000000720307772220256012026 0ustar tbtb;;; "dbsyn.scm" -- Syntactic extensions for RDMS -*- scheme -*- ;; Features: within-database ;;; Copyright (C) 2002, 2003 Ivan Shmakov ;; ;; Permission to copy this software, to modify it, to redistribute it, ;; to distribute modified versions, and to use it for any purpose is ;; granted, subject to the following restrictions and understandings. ;; ;; 1. Any copy made of this software must include this copyright notice ;; in full. ;; ;; 2. I have made no warranty or representation that the operation of ;; this software will be error-free, and I am under no obligation to ;; provide any services, by way of maintenance, update, or otherwise. ;; ;; 3. In conjunction with products arising from the use of this ;; material, there shall be no use of my name in any advertising, ;; promotional, or sales literature without prior written consent in ;; each case. ;;; History: ;; 2002-08-01: I've tired of tracking database description elements ;; (such as `(define-tables ...)'); so I decided to use `etags'. But ;; its hard (if possible) to create regexp to match against RDMS' table ;; specs. So I wrote `within-database' syntax extension and now I can ;; simply use something like: ;; $ etags -l scheme \ ;; -r '/ *(define-\(command\|table\) (\([^; \t]+\)/\2/' \ ;; source1.scm ... ;; ... and get TAGS table with all of my database commands and tables. ;;; Code: (require 'database-commands) (require 'databases) (require 'relational-database) ;@ (define-syntax within-database (syntax-rules (define-table define-command define-macro) ; ((within-database database) database) ; define-table ((within-database database (define-table (name primary columns) row ...) rest ...) (begin (define-tables database '(name primary columns (row ...))) (within-database database rest ...))) ; define-command ((within-database database (define-command template arg-1 arg-2 ...) rest ...) (begin (define-*commands* database '(template arg-1 arg-2 ...)) (within-database database rest ...))) ; ((within-database database (command arg-1 ...) rest ...) (begin (cond ((let ((p (database '*macro*))) (and p (slib:eval (p 'command)))) => (lambda (proc) (slib:eval (apply proc database '(arg-1 ...))))) (else ((database 'command) arg-1 ...))) (within-database database rest ...))))) (define (define-*macros* rdb . specs) (define defmac (((rdb 'open-table) '*macros* #t) 'row:update)) (for-each (lambda (spec) (let* ((procname (caar spec)) (args (cdar spec)) (body-1 (cdr spec)) (comment (and (string? (car body-1)) (car body-1))) (body (if comment (cdr body-1) body-1))) (defmac (list procname `(lambda ,args . ,body) (or comment ""))))) specs)) ;@ (define (add-macro-support rdb) (define-tables rdb '(*macros* ((name symbol)) ((procedure expression) (documentation string)) ((define-macro (lambda (db . args) (define-*macros* db args) #t) "")))) (define-*commands* rdb '((*macro* rdb) (((rdb 'open-table) '*macros* #f) 'get 'procedure))) rdb) slib-3b1/dbutil.scm0000644001705200017500000004256310612021646012167 0ustar tbtb;;; "dbutil.scm" relational-database-utilities ; Copyright 1994, 1995, 1997, 2000, 2001, 2002 Aubrey Jaffer ; ;Permission to copy this software, to modify it, to redistribute it, ;to distribute modified versions, and to use it for any purpose is ;granted, subject to the following restrictions and understandings. ; ;1. Any copy made of this software must include this copyright notice ;in full. ; ;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; ;3. In conjunction with products arising from the use of this ;material, there shall be no use of my name in any advertising, ;promotional, or sales literature without prior written consent in ;each case. (require 'common-list-functions) ;for nthcdr and butnthcdr (require 'relational-database) (require 'dynamic-wind) (require 'transact) (require-if 'compiling 'printf) ;used only by mdbm:report (require-if 'compiling 'alist-table) ;;@code{(require 'databases)} ;;@ftindex databases ;; ;;@noindent ;;This enhancement wraps a utility layer on @code{relational-database} ;;which provides: ;; ;;@itemize @bullet ;;@item ;;Identification of open databases by filename. ;;@item ;;Automatic sharing of open (immutable) databases. ;;@item ;;Automatic loading of base-table package when creating a database. ;;@item ;;Detection and automatic loading of the appropriate base-table package ;;when opening a database. ;;@item ;;Table and data definition from Scheme lists. ;;@end itemize ;;;Each entry in mdbm:*databases* is a list of: ;;; * database (procedure) ;;; * number of opens (integer) ;;; * type (symbol) ;;; * lock-certificate ;;;Because of WRITE-DATABASE, database filenames can change, so we must ;;;have a global lock. (define mdbm:*databases* (make-exchanger '())) (define (mdbm:return-dbs dbs) (if (mdbm:*databases* dbs) (slib:error 'mdbm:*databases* 'double 'set!))) (define (mdbm:find-db? rdb dbs) (and dbs (do ((dbs dbs (cdr dbs))) ((or (null? dbs) (equal? ((caar dbs) 'filename) (if (procedure? rdb) (rdb 'filename) rdb))) (and (not (null? dbs)) (if (and (procedure? rdb) (not (eq? ((caar dbs) 'filename) (rdb 'filename)))) (slib:error ((caar dbs) 'filename) 'open 'twice) (car dbs))))))) (define (mdbm:remove-entry dbs entry) (cond ((null? dbs) (slib:error 'mdbm:remove-entry 'not 'found entry)) ((eq? entry (car dbs)) (cdr dbs)) (else (cons (car dbs) (mdbm:remove-entry (cdr dbs) entry))))) ;;@subsubheading Database Sharing ;;@noindent ;;@dfn{Auto-sharing} refers to a call to the procedure ;;@code{open-database} returning an already open database (procedure), ;;rather than opening the database file a second time. ;; ;;@quotation ;;@emph{Note:} Databases returned by @code{open-database} do not include ;;wrappers applied by packages like @ref{Embedded Commands}. But ;;wrapped databases do work as arguments to these functions. ;;@end quotation ;; ;;@noindent ;;When a database is created, it is mutable by the creator and not ;;auto-sharable. A database opened mutably is also not auto-sharable. ;;But any number of readers can (open) share a non-mutable database file. ;;@noindent ;;This next set of procedures mirror the whole-database methods in ;;@ref{Database Operations}. Except for @code{create-database}, each ;;procedure will accept either a filename or database procedure for its ;;first argument. (define (mdbm:try-opens filename mutable?) (define (try base) (let ((rdb (base 'open-database))) (and rdb (rdb filename mutable?)))) (define certificate (and mutable? (file-lock! filename))) (define (loop bti) (define rdb (try (cadar bti))) (cond ((procedure? rdb) (list rdb 1 (caar bti) certificate)) ((null? (cdr bti)) #f) (else (loop (cdr bti))))) (if (null? *base-table-implementations*) (require 'alist-table)) (cond ((and (not (and mutable? (not certificate))) (loop *base-table-implementations*))) ((and (not (memq 'alist-table *base-table-implementations*)) (let () (require 'alist-table) (loop (list (car *base-table-implementations*)))))) (else (and certificate (file-unlock! filename certificate)) #f))) (define (mdbm:open-type filename type mutable?) (require type) (let ((certificate (and mutable? (file-lock! filename)))) (and (not (and mutable? (not certificate))) (let* ((sys (cadr (assq type *base-table-implementations*))) (open (and sys (sys 'open-database))) (ndb (and open (open filename mutable?)))) (cond (ndb (list ndb 1 type certificate)) (else (and certificate (file-unlock! filename certificate)) #f)))))) ;;@args filename base-table-type ;;@1 should be a string naming a file; or @code{#f}. @2 must be a ;;symbol naming a feature which can be passed to @code{require}. @0 ;;returns a new, open relational database (with base-table type @2) ;;associated with @1, or a new ephemeral database if @1 is @code{#f}. ;; ;;@code{create-database} is the only run-time use of require in SLIB ;;which crosses module boundaries. When @2 is @code{require}d by @0; it ;;adds an association of @2 with its @dfn{relational-system} procedure ;;to @var{mdbm:*databases*}. ;; ;;alist-table is the default base-table type: ;; ;;@example ;;(require 'databases) ;;(define my-rdb (create-database "my.db" 'alist-table)) ;;@end example (define (create-database filename type) (require type) (let ((dbs #f) (certificate (and filename (file-lock! filename)))) (and (or certificate (not filename)) (dynamic-wind (lambda () (set! dbs (mdbm:*databases* #f))) (lambda () (define entry (mdbm:find-db? filename dbs)) (cond (entry (slib:warn 'close ((car entry) 'filename) 'before 'create-database) #f) (else (let ((pair (assq type *base-table-implementations*))) (define ndb (and pair (((cadr pair) 'create-database) filename))) (if (and ndb dbs) (set! dbs (cons (list ndb 1 type certificate) dbs))) ndb)))) (lambda () (and dbs (mdbm:return-dbs dbs))))))) ;;@noindent ;;Only @code{alist-table} and base-table modules which have been ;;@code{require}d will dispatch correctly from the ;;@code{open-database} procedures. Therefore, either pass two ;;arguments to @code{open-database}, or require the base-table of your ;;database file uses before calling @code{open-database} with one ;;argument. ;;@args rdb base-table-type ;;Returns @emph{mutable} open relational database or #f. (define (open-database! filename . type) (set! type (and (not (null? type)) (car type))) (let ((dbs #f)) (dynamic-wind (lambda () (set! dbs (mdbm:*databases* #f))) (lambda () (cond ((and (procedure? filename) (not (filename 'delete-table))) (slib:warn (filename 'filename) 'not 'mutable) #f) ((mdbm:find-db? filename dbs) (cond ((procedure? filename) filename) (else (slib:warn filename 'already 'open) #f))) (else (let ((entry (if type (mdbm:open-type filename type #t) (mdbm:try-opens filename #t)))) (cond (entry (and dbs (set! dbs (cons entry dbs))) (car entry)) (else #f)))))) (lambda () (and dbs (mdbm:return-dbs dbs)))))) ;;@args rdb base-table-type ;;Returns an open relational database associated with @1. The ;;database will be opened with base-table type @2). ;; ;;@args rdb ;;Returns an open relational database associated with @1. ;;@0 will attempt to deduce the correct base-table-type. (define (open-database rdb . type) (set! type (and (not (null? type)) (car type))) (let ((dbs #f)) (dynamic-wind (lambda () (set! dbs (mdbm:*databases* #f))) (lambda () (define entry (mdbm:find-db? rdb dbs)) (and entry (set! rdb (car entry))) (cond ((and entry type (not (eqv? (caddr entry) type))) (slib:warn (rdb 'filename) 'type type '<> (caddr entry)) #f) ((and (procedure? rdb) (rdb 'delete-table)) (slib:warn (rdb 'filename) 'mutable) #f) (entry (set-car! (cdr entry) (+ 1 (cadr entry))) rdb) (else (set! entry (cond ((procedure? rdb) (list rdb 1 type #f)) (type (mdbm:open-type rdb type #f)) (else (mdbm:try-opens rdb #f)))) (cond (entry (and dbs (set! dbs (cons entry dbs))) (car entry)) (else #f))))) (lambda () (and dbs (mdbm:return-dbs dbs)))))) ;;@body ;;Writes the mutable relational-database @1 to @2. (define (write-database rdb filename) (let ((dbs #f)) (dynamic-wind (lambda () (set! dbs (mdbm:*databases* #f))) (lambda () (define entry (mdbm:find-db? rdb dbs)) (and entry (set! rdb (car entry))) (cond ((and (not entry) (procedure? rdb)) (set! entry (list rdb 1 #f (file-lock! filename))) (and dbs (set! dbs (cons entry dbs))))) (cond ((not entry) #f) ((and (not (equal? filename (rdb 'filename))) (mdbm:find-db? filename dbs)) (slib:warn filename 'already 'open) #f) (else (let ((dbwrite (rdb 'write-database))) (and dbwrite (dbwrite filename)))))) (lambda () (and dbs (mdbm:return-dbs dbs)))))) ;;@args rdb ;;Writes the mutable relational-database @1 to the filename it was ;;opened with. (define (sync-database rdb) (let ((dbs #f)) (dynamic-wind (lambda () (set! dbs (mdbm:*databases* #f))) (lambda () (define entry (mdbm:find-db? rdb dbs)) (and entry (set! rdb (car entry))) (cond ((and (not entry) (procedure? rdb)) (set! entry (list rdb 1 #f (file-lock! (rdb 'filename)))) (and dbs (set! dbs (cons entry dbs))))) (cond (entry (let ((db-op (rdb 'sync-database))) (and db-op (db-op)))) (else #f))) (lambda () (and dbs (mdbm:return-dbs dbs)))))) ;;@args rdb ;;Syncs @1 and makes it immutable. (define (solidify-database rdb) ; (let ((dbs #f)) (dynamic-wind (lambda () (set! dbs (mdbm:*databases* #f))) (lambda () (define entry (mdbm:find-db? rdb dbs)) (define certificate #f) (cond (entry (set! rdb (car entry)) (set! certificate (cadddr entry))) ((procedure? rdb) (set! entry (list rdb 1 #f (file-lock! (rdb 'filename)))) (and dbs (set! dbs (cons entry dbs))) (set! certificate (cadddr entry)))) (cond ((or (not certificate) (not (procedure? rdb))) #f) (else (let* ((filename (rdb 'filename)) (dbsolid (rdb 'solidify-database)) (ret (and dbsolid (dbsolid)))) (if (file-unlock! filename certificate) (set-car! (cdddr entry) #f) (slib:warn 'file-unlock! filename certificate 'failed)) ret)))) (lambda () (and dbs (mdbm:return-dbs dbs)))))) ;;@body ;;@1 will only be closed when the count of @code{open-database} - @0 ;;calls for @1 (and its filename) is 0. @0 returns #t if successful; ;;and #f otherwise. (define (close-database rdb) (let ((dbs #f)) (dynamic-wind (lambda () (set! dbs (mdbm:*databases* #f))) (lambda () (define entry (mdbm:find-db? rdb dbs)) (define certificate #f) (and entry (set! rdb (car entry))) (and (procedure? rdb) (set! certificate (and entry (cadddr entry)))) (cond ((and entry (not (eqv? 1 (cadr entry)))) (set-car! (cdr entry) (+ -1 (cadr entry))) #f) ((not (procedure? rdb)) (slib:warn 'close-database 'not 'procedure? rdb) #f) ((not certificate) (and dbs (set! dbs (mdbm:remove-entry dbs entry))) #t) (else (let* ((filename (rdb 'filename)) (dbclose (rdb 'close-database)) (ret (and dbclose (dbclose)))) (if (not (file-unlock! filename certificate)) (slib:warn 'file-unlock! filename certificate 'failed)) (cond ((not dbclose) (slib:warn 'database? rdb)) ((not entry)) (dbs (set! dbs (mdbm:remove-entry dbs entry)))) ret)))) (lambda () (and dbs (mdbm:return-dbs dbs)))))) ;;@body ;;Prints a table of open database files. The columns are the ;;base-table type, number of opens, @samp{!} for mutable, the ;;filename, and the lock certificate (if locked). (define (mdbm:report) (require 'printf) (let ((dbs #f)) (dynamic-wind (lambda () (set! dbs (mdbm:*databases* #f))) (lambda () (cond (dbs (for-each (lambda (entry) (printf "%15s %03d %1s %s %s\\n" (or (caddr entry) "?") (cadr entry) (if ((car entry) 'delete-table) '! "") (or ((car entry) 'filename) '-) (or (cadddr entry) ""))) dbs)) (else (printf "%s lock broken.\\n" 'mdbm:*databases*)))) (lambda () (and dbs (mdbm:return-dbs dbs)))))) ;;@example ;;(mdbm:report) ;;@print{} ;; alist-table 003 /usr/local/lib/slib/clrnamdb.scm ;; alist-table 001 ! sdram.db jaffer@@aubrey.jaffer.3166:1038628199 ;;@end example ;;@subsubheading Opening Tables ;;@body ;;@1 must be a relational database and @2 a symbol. ;; ;;@0 returns a "methods" procedure for an existing relational table in ;;@1 if it exists and can be opened for reading, otherwise returns ;;@code{#f}. (define (open-table rdb table-name) ((rdb 'open-table) table-name #f)) ;;@body ;;@1 must be a relational database and @2 a symbol. ;; ;;@0 returns a "methods" procedure for an existing relational table in ;;@1 if it exists and can be opened in mutable mode, otherwise returns ;;@code{#f}. (define (open-table! rdb table-name) ((rdb 'open-table) table-name #t)) ;;@subsubheading Defining Tables ;;@body ;;Adds the domain rows @2 @dots{} to the @samp{*domains-data*} table ;;in @1. The format of the row is given in @ref{Catalog Representation}. ;; ;;@example ;;(define-domains rdb '(permittivity #f complex? c64 #f)) ;;@end example (define (define-domains rdb . row5) (define add-domain (((rdb 'open-table) '*domains-data* #t) 'row:update)) (for-each add-domain row5)) ;;@body ;;Use @code{define-domains} instead. (define (add-domain rdb row5) ((((rdb 'open-table) '*domains-data* #t) 'row:update) row5)) ;;@args rdb spec-0 @dots{} ;;Adds tables as specified in @var{spec-0} @dots{} to the open ;;relational-database @1. Each @var{spec} has the form: ;; ;;@lisp ;;(@r{} @r{} @r{} @r{}) ;;@end lisp ;;or ;;@lisp ;;(@r{} @r{} @r{} @r{}) ;;@end lisp ;; ;;where @r{} is the table name, @r{} is the symbol ;;name of a descriptor table, @r{} and ;;@r{} describe the primary keys and other fields ;;respectively, and @r{} is a list of data rows to be added to the ;;table. ;; ;;@r{} and @r{} are lists of field ;;descriptors of the form: ;; ;;@lisp ;;(@r{} @r{}) ;;@end lisp ;;or ;;@lisp ;;(@r{} @r{} @r{}) ;;@end lisp ;; ;;where @r{} is the column name, @r{} is the domain ;;of the column, and @r{} is an expression whose ;;value is a procedure of one argument (which returns @code{#f} to signal ;;an error). ;; ;;If @r{} is not a defined domain name and it matches the name of ;;this table or an already defined (in one of @var{spec-0} @dots{}) single ;;key field table, a foreign-key domain will be created for it. (define (define-tables rdb . spec-list) (define new-tables '()) (define dom:typ (((rdb 'open-table) '*domains-data* #f) 'get 4)) (define create-table (rdb 'create-table)) (define open-table (rdb 'open-table)) (define table-exists? (rdb 'table-exists?)) (define (check-domain dname) (cond ((dom:typ dname)) ((member dname new-tables) (let ((ftab (open-table (string->symbol (string-append "desc:" (symbol->string dname))) #f))) ((((rdb 'open-table) '*domains-data* #t) 'row:insert) (list dname dname #f (dom:typ ((ftab 'get 'domain-name) 1)) 1)))))) (define (define-table name prikeys slots data) (cond ((table-exists? name) (let ((tab (open-table name #t))) ((tab 'row:update*) data) ((tab 'close-table)))) ((and (symbol? prikeys) (eq? prikeys slots)) (cond ((not (table-exists? slots)) (slib:error "Table doesn't exist:" slots))) (set! new-tables (cons name new-tables)) (let ((tab (create-table name slots))) ((tab 'row:insert*) data) ((tab 'close-table)))) (else (let* ((descname (string->symbol (string-append "desc:" (symbol->string name)))) (tab (create-table descname)) (row:insert (tab 'row:insert)) (j 0)) (set! new-tables (cons name new-tables)) (for-each (lambda (des) (set! j (+ 1 j)) (check-domain (cadr des)) (row:insert (list j #t (car des) (if (null? (cddr des)) #f (caddr des)) (cadr des)))) prikeys) (for-each (lambda (des) (set! j (+ 1 j)) (check-domain (cadr des)) (row:insert (list j #f (car des) (if (null? (cddr des)) #f (caddr des)) (cadr des)))) slots) ((tab 'close-table)) (set! tab (create-table name descname)) ((tab 'row:insert*) data) ((tab 'close-table)))))) (for-each (lambda (spec) (apply define-table spec)) spec-list)) ;;@subsubheading Listing Tables ;;@body ;;If symbol @2 exists in the open relational-database ;;@1, then returns a list of the table-name, its primary key names ;;and domains, its other key names and domains, and the table's records ;;(as lists). Otherwise, returns #f. ;; ;;The list returned by @0, when passed as an ;;argument to @code{define-tables}, will recreate the table. (define (list-table-definition rdb table-name) (cond (((rdb 'table-exists?) table-name) (let* ((table ((rdb 'open-table) table-name #f)) (prilimit (table 'primary-limit)) (coldefs (map list (table 'column-names) (table 'column-domains)))) (list table-name (butnthcdr prilimit coldefs) (nthcdr prilimit coldefs) ((table 'row:retrieve*))))) (else #f))) ;;(trace-all "/home/jaffer/slib/dbutil.scm") (untrace define-tables) slib-3b1/dbutil.txi0000644001705200017500000001521110747237372012215 0ustar tbtb@code{(require 'databases)} @ftindex databases @noindent This enhancement wraps a utility layer on @code{relational-database} which provides: @itemize @bullet @item Identification of open databases by filename. @item Automatic sharing of open (immutable) databases. @item Automatic loading of base-table package when creating a database. @item Detection and automatic loading of the appropriate base-table package when opening a database. @item Table and data definition from Scheme lists. @end itemize @subsubheading Database Sharing @noindent @dfn{Auto-sharing} refers to a call to the procedure @cindex Auto-sharing @code{open-database} returning an already open database (procedure), rather than opening the database file a second time. @quotation @emph{Note:} Databases returned by @code{open-database} do not include wrappers applied by packages like @ref{Embedded Commands}. But wrapped databases do work as arguments to these functions. @end quotation @noindent When a database is created, it is mutable by the creator and not auto-sharable. A database opened mutably is also not auto-sharable. But any number of readers can (open) share a non-mutable database file. @noindent This next set of procedures mirror the whole-database methods in @ref{Database Operations}. Except for @code{create-database}, each procedure will accept either a filename or database procedure for its first argument. @defun create-database filename base-table-type @var{filename} should be a string naming a file; or @code{#f}. @var{base-table-type} must be a symbol naming a feature which can be passed to @code{require}. @code{create-database} returns a new, open relational database (with base-table type @var{base-table-type}) associated with @var{filename}, or a new ephemeral database if @var{filename} is @code{#f}. @code{create-database} is the only run-time use of require in SLIB which crosses module boundaries. When @var{base-table-type} is @code{require}d by @code{create-database}; it adds an association of @var{base-table-type} with its @dfn{relational-system} procedure @cindex relational-system to @var{mdbm:*databases*}. alist-table is the default base-table type: @example (require 'databases) (define my-rdb (create-database "my.db" 'alist-table)) @end example @end defun @noindent Only @code{alist-table} and base-table modules which have been @code{require}d will dispatch correctly from the @code{open-database} procedures. Therefore, either pass two arguments to @code{open-database}, or require the base-table of your database file uses before calling @code{open-database} with one argument. @deffn {Procedure} open-database! rdb base-table-type Returns @emph{mutable} open relational database or #f. @end deffn @defun open-database rdb base-table-type Returns an open relational database associated with @var{rdb}. The database will be opened with base-table type @var{base-table-type}). @defunx open-database rdb Returns an open relational database associated with @var{rdb}. @code{open-database} will attempt to deduce the correct base-table-type. @end defun @defun write-database rdb filename Writes the mutable relational-database @var{rdb} to @var{filename}. @end defun @defun sync-database rdb Writes the mutable relational-database @var{rdb} to the filename it was opened with. @end defun @defun solidify-database rdb Syncs @var{rdb} and makes it immutable. @end defun @defun close-database rdb @var{rdb} will only be closed when the count of @code{open-database} - @code{close-database} calls for @var{rdb} (and its filename) is 0. @code{close-database} returns #t if successful; and #f otherwise. @end defun @defun mdbm:report Prints a table of open database files. The columns are the base-table type, number of opens, @samp{!} for mutable, the filename, and the lock certificate (if locked). @end defun @example (mdbm:report) @print{} alist-table 003 /usr/local/lib/slib/clrnamdb.scm alist-table 001 ! sdram.db jaffer@@aubrey.jaffer.3166:1038628199 @end example @subsubheading Opening Tables @defun open-table rdb table-name @var{rdb} must be a relational database and @var{table-name} a symbol. @code{open-table} returns a "methods" procedure for an existing relational table in @var{rdb} if it exists and can be opened for reading, otherwise returns @code{#f}. @end defun @deffn {Procedure} open-table! rdb table-name @var{rdb} must be a relational database and @var{table-name} a symbol. @code{open-table!} returns a "methods" procedure for an existing relational table in @var{rdb} if it exists and can be opened in mutable mode, otherwise returns @code{#f}. @end deffn @subsubheading Defining Tables @defun define-domains rdb row5 @dots{} Adds the domain rows @var{row5} @dots{} to the @samp{*domains-data*} table in @var{rdb}. The format of the row is given in @ref{Catalog Representation}. @example (define-domains rdb '(permittivity #f complex? c64 #f)) @end example @end defun @defun add-domain rdb row5 Use @code{define-domains} instead. @end defun @defun define-tables rdb spec-0 @dots{} Adds tables as specified in @var{spec-0} @dots{} to the open relational-database @var{rdb}. Each @var{spec} has the form: @lisp (@r{} @r{} @r{} @r{}) @end lisp or @lisp (@r{} @r{} @r{} @r{}) @end lisp where @r{} is the table name, @r{} is the symbol name of a descriptor table, @r{} and @r{} describe the primary keys and other fields respectively, and @r{} is a list of data rows to be added to the table. @r{} and @r{} are lists of field descriptors of the form: @lisp (@r{} @r{}) @end lisp or @lisp (@r{} @r{} @r{}) @end lisp where @r{} is the column name, @r{} is the domain of the column, and @r{} is an expression whose value is a procedure of one argument (which returns @code{#f} to signal an error). If @r{} is not a defined domain name and it matches the name of this table or an already defined (in one of @var{spec-0} @dots{}) single key field table, a foreign-key domain will be created for it. @end defun @subsubheading Listing Tables @defun list-table-definition rdb table-name If symbol @var{table-name} exists in the open relational-database @var{rdb}, then returns a list of the table-name, its primary key names and domains, its other key names and domains, and the table's records (as lists). Otherwise, returns #f. The list returned by @code{list-table-definition}, when passed as an argument to @code{define-tables}, will recreate the table. @end defun slib-3b1/debug.scm0000644001705200017500000000573707776076457012027 0ustar tbtb;;;; "debug.scm" Utility functions for debugging in Scheme. ;;; Copyright (C) 1991, 1992, 1993, 1995, 1999 Aubrey Jaffer ; ;Permission to copy this software, to modify it, to redistribute it, ;to distribute modified versions, and to use it for any purpose is ;granted, subject to the following restrictions and understandings. ; ;1. Any copy made of this software must include this copyright notice ;in full. ; ;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; ;3. In conjunction with products arising from the use of this ;material, there shall be no use of my name in any advertising, ;promotional, or sales literature without prior written consent in ;each case. (require 'trace) (require 'break) (require 'line-i/o) (define (for-each-top-level-definition-in-file file proc) (call-with-input-file file (lambda (port) (letrec ((walk (lambda (exp) (cond ((not (and (pair? exp) (list? exp)))) ((not (symbol? (car exp)))) (else (case (car exp) ((begin) (for-each walk (cdr exp))) ((cond) (for-each (lambda (exp) (for-each walk (if (list? (car exp)) exp (cdr exp)))) (cdr exp))) ((if) (for-each walk (if (list? (cadr exp)) (cdr exp) (cddr exp)))) ((defmacro define-syntax) (proc exp)) ((define) (proc exp)))))))) (if (eqv? #\# (peek-char port)) (read-line port)) ;remove `magic-number' (do ((form (read port) (read port))) ((eof-object? form)) (walk form)))))) (define (for-each-top-level-defined-procedure-symbol-in-file file proc) (letrec ((get-defined-symbol (lambda (form) (if (pair? form) (get-defined-symbol (car form)) form)))) (for-each-top-level-definition-in-file file (lambda (form) (and (eqv? 'define (car form)) (let ((sym (get-defined-symbol (cadr form)))) (cond ((procedure? (slib:eval sym)) (proc sym))))))))) ;@ (define (trace-all file . ...) (for-each (lambda (file) (for-each-top-level-defined-procedure-symbol-in-file file (lambda (sym) (slib:eval `(set! ,sym (trace:trace-procedure 'trace ,sym ',sym)))))) (cons file ...))) (define (track-all file . ...) (for-each (lambda (file) (for-each-top-level-defined-procedure-symbol-in-file file (lambda (sym) (slib:eval `(set! ,sym (trace:trace-procedure 'track ,sym ',sym)))))) (cons file ...))) (define (stack-all file . ...) (for-each (lambda (file) (for-each-top-level-defined-procedure-symbol-in-file file (lambda (sym) (slib:eval `(set! ,sym (trace:trace-procedure 'stack ,sym ',sym)))))) (cons file ...))) ;@ (define (break-all file . ...) (for-each (lambda (file) (for-each-top-level-defined-procedure-symbol-in-file file (lambda (sym) (slib:eval `(set! ,sym (break:breakf ,sym ',sym)))))) (cons file ...))) slib-3b1/defmacex.scm0000644001705200017500000000604710733363452012465 0ustar tbtb;;;"defmacex.scm" defmacro:expand* for any Scheme dialect. ;;;Copyright 1993-1994 Dorai Sitaram and Aubrey Jaffer. ; ;Permission to copy this software, to modify it, to redistribute it, ;to distribute modified versions, and to use it for any purpose is ;granted, subject to the following restrictions and understandings. ; ;1. Any copy made of this software must include this copyright notice ;in full. ; ;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; ;3. In conjunction with products arising from the use of this ;material, there shall be no use of my name in any advertising, ;promotional, or sales literature without prior written consent in ;each case. ;;;expand thoroughly, not just topmost expression. While expanding ;;;subexpressions, the primitive forms quote, lambda, set!, let/*/rec, ;;;cond, case, do, quasiquote: need to be destructured properly. (if, ;;;and, or, begin: don't need special treatment.) (define (defmacro:iqq e depth) (letrec ((map1 (lambda (f x) (if (pair? x) (cons (f (car x)) (map1 f (cdr x))) x))) (iqq (lambda (e depth) (if (pair? e) (case (car e) ((quasiquote) (list (car e) (iqq (cadr e) (+ 1 depth)))) ((unquote unquote-splicing) (list (car e) (if (= 1 depth) (defmacro:expand* (cadr e)) (iqq (cadr e) (+ -1 depth))))) (else (map1 (lambda (e) (iqq e depth)) e))) e)))) (iqq e depth))) ;@ (define (defmacro:expand* e) (if (pair? e) (let* ((c (macroexpand e))) (if (not (eq? e c)) (defmacro:expand* c) (case (car e) ((quote) e) ((quasiquote) (defmacro:iqq e 0)) ((lambda define set!) (cons (car e) (cons (cadr e) (map defmacro:expand* (cddr e))))) ((let) (let ((b (cadr e))) (if (symbol? b) ;named let `(let ,b ,(map (lambda (vv) `(,(car vv) ,(defmacro:expand* (cadr vv)))) (caddr e)) ,@(map defmacro:expand* (cdddr e))) `(let ,(map (lambda (vv) `(,(car vv) ,(defmacro:expand* (cadr vv)))) b) ,@(map defmacro:expand* (cddr e)))))) ((let* letrec) `(,(car e) ,(map (lambda (vv) `(,(car vv) ,(defmacro:expand* (cadr vv)))) (cadr e)) ,@(map defmacro:expand* (cddr e)))) ((cond) `(cond ,@(map (lambda (c) (map defmacro:expand* c)) (cdr e)))) ((case) `(case ,(defmacro:expand* (cadr e)) ,@(map (lambda (c) `(,(car c) ,@(map defmacro:expand* (cdr c)))) (cddr e)))) ((do) `(do ,(map (lambda (initsteps) `(,(car initsteps) ,@(map defmacro:expand* (cdr initsteps)))) (cadr e)) ,(map defmacro:expand* (caddr e)) ,@(map defmacro:expand* (cdddr e)))) ((defmacro) (cons (car e) (cons (cadr e) (cons (caddr e) (map defmacro:expand* (cdddr e)))))) (else (map defmacro:expand* e))))) e)) slib-3b1/determ.scm0000644001705200017500000001222410736747161012171 0ustar tbtb;;; "determ.scm" Matrix Algebra ;Copyright 2002, 2004 Aubrey Jaffer ; ;Permission to copy this software, to modify it, to redistribute it, ;to distribute modified versions, and to use it for any purpose is ;granted, subject to the following restrictions and understandings. ; ;1. Any copy made of this software must include this copyright notice ;in full. ; ;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; ;3. In conjunction with products arising from the use of this ;material, there shall be no use of my name in any advertising, ;promotional, or sales literature without prior written consent in ;each case. (require 'array) ;;@code{(require 'determinant)} ;;@ftindex determinant ;;@noindent ;;A Matrix can be either a list of lists (rows) or an array. ;;Unlike linear-algebra texts, this package uses 0-based coordinates. ;;; Internal conversion routines (define (matrix2array matrix prototype) (let* ((dim1 (length matrix)) (dim2 (length (car matrix))) (mat (make-array '#() dim1 dim2))) (do ((idx 0 (+ 1 idx)) (rows matrix (cdr rows))) ((>= idx dim1) rows) (do ((jdx 0 (+ 1 jdx)) (row (car rows) (cdr row))) ((>= jdx dim2)) (array-set! mat (car row) idx jdx))) mat)) (define (matrix2lists matrix) (let ((dims (array-dimensions matrix))) (do ((idx (+ -1 (car dims)) (+ -1 idx)) (rows '() (cons (do ((jdx (+ -1 (cadr dims)) (+ -1 jdx)) (row '() (cons (array-ref matrix idx jdx) row))) ((< jdx 0) row)) rows))) ((< idx 0) rows)))) (define (coerce-like-arg matrix arg) (cond ((array? arg) (matrix2array matrix arg)) (else matrix))) ;;@body ;;Returns the list-of-lists form of @1. (define (matrix->lists matrix) (cond ((array? matrix) (if (not (eqv? 2 (array-rank matrix))) (slib:error 'not 'matrix matrix)) (matrix2lists matrix)) ((and (pair? matrix) (list? (car matrix))) matrix) ((vector? matrix) (list (vector->list matrix))) (else (slib:error 'not 'matrix matrix)))) ;;@body ;;Returns the array form of @1. (define (matrix->array matrix) (cond ((array? matrix) (if (not (eqv? 2 (array-rank matrix))) (slib:error 'not 'matrix matrix)) matrix) ((and (pair? matrix) (list? (car matrix))) (matrix2array matrix '#())) ((vector? matrix) matrix) (else (slib:error 'not 'matrix matrix)))) (define (matrix:cofactor matrix i j) (define mat (matrix->lists matrix)) (define (butnth n lst) (if (<= n 1) (cdr lst) (cons (car lst) (butnth (+ -1 n) (cdr lst))))) (define (minor matrix i j) (map (lambda (x) (butnth j x)) (butnth i mat))) (coerce-like-arg (* (if (odd? (+ i j)) -1 1) (determinant (minor mat i j))) matrix)) ;;@body ;;@1 must be a square matrix. ;;@0 returns the determinant of @1. ;; ;;@example ;;(require 'determinant) ;;(determinant '((1 2) (3 4))) @result{} -2 ;;(determinant '((1 2 3) (4 5 6) (7 8 9))) @result{} 0 ;;@end example (define (determinant matrix) (define mat (matrix->lists matrix)) (let ((n (length mat))) (if (eqv? 1 n) (caar mat) (do ((j n (+ -1 j)) (ans 0 (+ ans (* (list-ref (car mat) (+ -1 j)) (matrix:cofactor mat 1 j))))) ((<= j 0) ans))))) ;;@body ;;Returns a copy of @1 flipped over the diagonal containing the 1,1 ;;element. (define (transpose matrix) (if (number? matrix) matrix (let ((mat (matrix->lists matrix))) (coerce-like-arg (apply map list mat) matrix)))) ;;@body ;;Returns the element-wise sum of matricies @1 and @2. (define (matrix:sum m1 m2) (define mat1 (matrix->lists m1)) (define mat2 (matrix->lists m2)) (coerce-like-arg (map (lambda (row1 row2) (map + row1 row2)) mat1 mat2) m1)) ;;@body ;;Returns the element-wise difference of matricies @1 and @2. (define (matrix:difference m1 m2) (define mat1 (matrix->lists m1)) (define mat2 (matrix->lists m2)) (coerce-like-arg (map (lambda (row1 row2) (map - row1 row2)) mat1 mat2) m1)) (define (matrix:scale m1 scl) (coerce-like-arg (map (lambda (row1) (map (lambda (x) (* scl x)) row1)) (matrix->lists m1)) m1)) ;;@args m1 m2 ;;Returns the product of matrices @1 and @2. ;;@args m1 z ;;Returns matrix @var{m1} times scalar @var{z}. ;;@args z m1 ;;Returns matrix @var{m1} times scalar @var{z}. (define (matrix:product m1 m2) (cond ((number? m1) (matrix:scale m2 m1)) ((number? m2) (matrix:scale m1 m2)) (else (let ((mat1 (matrix->lists m1)) (mat2 (matrix->lists m2))) (define (dot-product v1 v2) (apply + (map * v1 v2))) (coerce-like-arg (map (lambda (arow) (apply map (lambda bcol (dot-product bcol arow)) mat2)) mat1) m1))))) ;;@body ;;@1 must be a square matrix. ;;If @1 is singular, then @0 returns #f; otherwise @0 returns the ;;@code{matrix:product} inverse of @1. (define (matrix:inverse matrix) (let* ((mat (matrix->lists matrix)) (det (determinant mat)) (rank (length mat))) (and (not (zero? det)) (do ((i rank (+ -1 i)) (inv '() (cons (do ((j rank (+ -1 j)) (row '() (cons (/ (matrix:cofactor mat j i) det) row))) ((<= j 0) row)) inv))) ((<= i 0) (coerce-like-arg inv matrix)))))) slib-3b1/determ.txi0000644001705200017500000000267710747237372012226 0ustar tbtb@code{(require 'determinant)} @ftindex determinant @noindent A Matrix can be either a list of lists (rows) or an array. Unlike linear-algebra texts, this package uses 0-based coordinates. @defun matrix->lists matrix Returns the list-of-lists form of @var{matrix}. @end defun @defun matrix->array matrix Returns the array form of @var{matrix}. @end defun @defun determinant matrix @var{matrix} must be a square matrix. @code{determinant} returns the determinant of @var{matrix}. @example (require 'determinant) (determinant '((1 2) (3 4))) @result{} -2 (determinant '((1 2 3) (4 5 6) (7 8 9))) @result{} 0 @end example @end defun @defun transpose matrix Returns a copy of @var{matrix} flipped over the diagonal containing the 1,1 element. @end defun @defun matrix:sum m1 m2 Returns the element-wise sum of matricies @var{m1} and @var{m2}. @end defun @defun matrix:difference m1 m2 Returns the element-wise difference of matricies @var{m1} and @var{m2}. @end defun @defun matrix:product m1 m2 Returns the product of matrices @var{m1} and @var{m2}. @defunx matrix:product m1 z Returns matrix @var{m1} times scalar @var{z}. @defunx matrix:product z m1 Returns matrix @var{m1} times scalar @var{z}. @end defun @defun matrix:inverse matrix @var{matrix} must be a square matrix. If @var{matrix} is singular, then @code{matrix:inverse} returns #f; otherwise @code{matrix:inverse} returns the @code{matrix:product} inverse of @var{matrix}. @end defun slib-3b1/dft.scm0000644001705200017500000001502110506356761011461 0ustar tbtb;;;"dft.scm" Discrete Fourier Transform ;Copyright (C) 1999, 2003, 2006 Aubrey Jaffer ; ;Permission to copy this software, to modify it, to redistribute it, ;to distribute modified versions, and to use it for any purpose is ;granted, subject to the following restrictions and understandings. ; ;1. Any copy made of this software must include this copyright notice ;in full. ; ;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; ;3. In conjunction with products arising from the use of this ;material, there shall be no use of my name in any advertising, ;promotional, or sales literature without prior written consent in ;each case. ;;;; For one-dimensional power-of-two length see: ;;; Introduction to Algorithms (MIT Electrical ;;; Engineering and Computer Science Series) ;;; by Thomas H. Cormen, Charles E. Leiserson (Contributor), ;;; Ronald L. Rivest (Contributor) ;;; MIT Press; ISBN: 0-262-03141-8 (July 1990) ;;; Flipped polarity of exponent to agree with ;;; http://en.wikipedia.org/wiki/Discrete_Fourier_transform (require 'array) (require 'logical) (require 'subarray) ;;@code{(require 'dft)} or ;;@code{(require 'Fourier-transform)} ;;@ftindex dft, Fourier-transform ;; ;;@code{fft} and @code{fft-1} compute the Fast-Fourier-Transforms ;;(O(n*log(n))) of arrays whose dimensions are all powers of 2. ;; ;;@code{sft} and @code{sft-1} compute the Discrete-Fourier-Transforms ;;for all combinations of dimensions (O(n^2)). (define (dft:sft1d! new ara n dir) (define scl (if (negative? dir) (/ 1.0 n) 1)) (define pi2i/n (/ (* 0-8i (atan 1) dir) n)) (do ((k (+ -1 n) (+ -1 k))) ((negative? k) new) (let ((sum 0)) (do ((j (+ -1 n) (+ -1 j))) ((negative? j) (array-set! new sum k)) (set! sum (+ sum (* (exp (* pi2i/n j k)) (array-ref ara j) scl))))))) (define (dft:fft1d! new ara n dir) (define scl (if (negative? dir) (/ 1.0 n) 1)) (define lgn (integer-length (+ -1 n))) (define pi2i (* 0-8i (atan 1) dir)) (do ((k 0 (+ 1 k))) ((>= k n)) (array-set! new (* (array-ref ara k) scl) (reverse-bit-field k 0 lgn))) (do ((s 1 (+ 1 s)) (m (expt 2 1) (expt 2 (+ 1 s)))) ((> s lgn) new) (let ((w_m (exp (/ pi2i m))) (m/2-1 (+ (quotient m 2) -1))) (do ((j 0 (+ 1 j)) (w 1 (* w w_m))) ((> j m/2-1)) (do ((k j (+ m k)) (k+m/2 (+ j m/2-1 1) (+ m k m/2-1 1))) ((>= k n)) (let ((t (* w (array-ref new k+m/2))) (u (array-ref new k))) (array-set! new (+ u t) k) (array-set! new (- u t) k+m/2))))))) ;;; Row-major order is suboptimal for Scheme. ;;; N are copied into and operated on in place ;;; A[a, *, c] --> N1[c, a, *] ;;; N1[c, *, b] --> N2[b, c, *] ;;; N2[b, *, a] --> N3[a, b, *] (define (dft:rotate-indexes idxs) (define ridxs (reverse idxs)) (cons (car ridxs) (reverse (cdr ridxs)))) (define (dft:dft prot ara dir transform-1d) (define (ranker ara rdx dims) (define ndims (dft:rotate-indexes dims)) (if (negative? rdx) ara (let ((new (apply make-array prot ndims)) (rdxlen (car (last-pair ndims)))) (define x1d (cond (transform-1d) ((eqv? rdxlen (expt 2 (integer-length (+ -1 rdxlen)))) dft:fft1d!) (else dft:sft1d!))) (define (ramap rdims inds) (cond ((null? rdims) (x1d (apply subarray new (dft:rotate-indexes inds)) (apply subarray ara inds) rdxlen dir)) ((null? inds) (do ((i (+ -1 (car rdims)) (+ -1 i))) ((negative? i)) (ramap (cddr rdims) (cons #f (cons i inds))))) (else (do ((i (+ -1 (car rdims)) (+ -1 i))) ((negative? i)) (ramap (cdr rdims) (cons i inds)))))) (if (= 1 (length dims)) (x1d new ara rdxlen dir) (ramap (reverse dims) '())) (ranker new (+ -1 rdx) ndims)))) (ranker ara (+ -1 (array-rank ara)) (array-dimensions ara))) ;;@args array prot ;;@args array ;;@var{array} is an array of positive rank. @code{sft} returns an ;;array of type @2 (defaulting to @1) of complex numbers comprising ;;the @dfn{Discrete Fourier Transform} of @var{array}. (define (sft ara . prot) (dft:dft (if (null? prot) ara (car prot)) ara 1 dft:sft1d!)) ;;@args array prot ;;@args array ;;@var{array} is an array of positive rank. @code{sft-1} returns an ;;array of type @2 (defaulting to @1) of complex numbers comprising ;;the inverse Discrete Fourier Transform of @var{array}. (define (sft-1 ara . prot) (dft:dft (if (null? prot) ara (car prot)) ara -1 dft:sft1d!)) (define (dft:check-dimensions ara name) (for-each (lambda (n) (if (not (eqv? n (expt 2 (integer-length (+ -1 n))))) (slib:error name "array length not power of 2" n))) (array-dimensions ara))) ;;@args array prot ;;@args array ;;@var{array} is an array of positive rank whose dimensions are all ;;powers of 2. @code{fft} returns an array of type @2 (defaulting to ;;@1) of complex numbers comprising the Discrete Fourier Transform of ;;@var{array}. (define (fft ara . prot) (dft:check-dimensions ara 'fft) (dft:dft (if (null? prot) ara (car prot)) ara 1 dft:fft1d!)) ;;@args array prot ;;@args array ;;@var{array} is an array of positive rank whose dimensions are all ;;powers of 2. @code{fft-1} returns an array of type @2 (defaulting ;;to @1) of complex numbers comprising the inverse Discrete Fourier ;;Transform of @var{array}. (define (fft-1 ara . prot) (dft:check-dimensions ara 'fft-1) (dft:dft (if (null? prot) ara (car prot)) ara -1 dft:fft1d!)) ;;@code{dft} and @code{dft-1} compute the discrete Fourier transforms ;;using the best method for decimating each dimension. ;;@args array prot ;;@args array ;;@0 returns an array of type @2 (defaulting to @1) of complex ;;numbers comprising the Discrete Fourier Transform of @var{array}. (define (dft ara . prot) (dft:dft (if (null? prot) ara (car prot)) ara 1 #f)) ;;@args array prot ;;@args array ;;@0 returns an array of type @2 (defaulting to @1) of ;;complex numbers comprising the inverse Discrete Fourier Transform of ;;@var{array}. (define (dft-1 ara . prot) (dft:dft (if (null? prot) ara (car prot)) ara -1 #f)) ;;@noindent ;;@code{(fft-1 (fft @var{array}))} will return an array of values close to ;;@var{array}. ;; ;;@example ;;(fft '#(1 0+i -1 0-i 1 0+i -1 0-i)) @result{} ;; ;;#(0.0 0.0 0.0+628.0783185208527e-18i 0.0 ;; 0.0 0.0 8.0-628.0783185208527e-18i 0.0) ;; ;;(fft-1 '#(0 0 0 0 0 0 8 0)) @result{} ;; ;;#(1.0 -61.23031769111886e-18+1.0i -1.0 61.23031769111886e-18-1.0i ;; 1.0 -61.23031769111886e-18+1.0i -1.0 61.23031769111886e-18-1.0i) ;;@end example slib-3b1/dft.txi0000644001705200017500000000462210747237372011513 0ustar tbtb@code{(require 'dft)} or @code{(require 'Fourier-transform)} @ftindex dft, Fourier-transform @code{fft} and @code{fft-1} compute the Fast-Fourier-Transforms (O(n*log(n))) of arrays whose dimensions are all powers of 2. @code{sft} and @code{sft-1} compute the Discrete-Fourier-Transforms for all combinations of dimensions (O(n^2)). @defun sft array prot @defunx sft array @var{array} is an array of positive rank. @code{sft} returns an array of type @var{prot} (defaulting to @var{array}) of complex numbers comprising the @dfn{Discrete Fourier Transform} of @var{array}. @cindex Discrete Fourier Transform @end defun @defun sft-1 array prot @defunx sft-1 array @var{array} is an array of positive rank. @code{sft-1} returns an array of type @var{prot} (defaulting to @var{array}) of complex numbers comprising the inverse Discrete Fourier Transform of @var{array}. @end defun @defun fft array prot @defunx fft array @var{array} is an array of positive rank whose dimensions are all powers of 2. @code{fft} returns an array of type @var{prot} (defaulting to @var{array}) of complex numbers comprising the Discrete Fourier Transform of @var{array}. @end defun @defun fft-1 array prot @defunx fft-1 array @var{array} is an array of positive rank whose dimensions are all powers of 2. @code{fft-1} returns an array of type @var{prot} (defaulting to @var{array}) of complex numbers comprising the inverse Discrete Fourier Transform of @var{array}. @end defun @code{dft} and @code{dft-1} compute the discrete Fourier transforms using the best method for decimating each dimension. @defun dft array prot @defunx dft array @code{dft} returns an array of type @var{prot} (defaulting to @var{array}) of complex numbers comprising the Discrete Fourier Transform of @var{array}. @end defun @defun dft-1 array prot @defunx dft-1 array @code{dft-1} returns an array of type @var{prot} (defaulting to @var{array}) of complex numbers comprising the inverse Discrete Fourier Transform of @var{array}. @end defun @noindent @code{(fft-1 (fft @var{array}))} will return an array of values close to @var{array}. @example (fft '#(1 0+i -1 0-i 1 0+i -1 0-i)) @result{} #(0.0 0.0 0.0+628.0783185208527e-18i 0.0 0.0 0.0 8.0-628.0783185208527e-18i 0.0) (fft-1 '#(0 0 0 0 0 0 8 0)) @result{} #(1.0 -61.23031769111886e-18+1.0i -1.0 61.23031769111886e-18-1.0i 1.0 -61.23031769111886e-18+1.0i -1.0 61.23031769111886e-18-1.0i) @end example slib-3b1/differ.scm0000644001705200017500000003641510606017711012143 0ustar tbtb;;;; "differ.scm" O(NP) Sequence Comparison Algorithm. ;;; Copyright (C) 2001, 2002, 2003, 2004, 2007 Aubrey Jaffer ; ;Permission to copy this software, to modify it, to redistribute it, ;to distribute modified versions, and to use it for any purpose is ;granted, subject to the following restrictions and understandings. ; ;1. Any copy made of this software must include this copyright notice ;in full. ; ;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; ;3. In conjunction with products arising from the use of this ;material, there shall be no use of my name in any advertising, ;promotional, or sales literature without prior written consent in ;each case. ;;@noindent ;;@code{diff:edit-length} implements the algorithm: ;; ;;@ifinfo ;;@example ;;S. Wu, E. Myers, U. Manber, and W. Miller, ;; "An O(NP) Sequence Comparison Algorithm," ;; Information Processing Letters 35, 6 (1990), 317-323. ;; @url{http://www.cs.arizona.edu/people/gene/PAPERS/np_diff.ps} ;;@end example ;;@end ifinfo ;;@ifset html ;;S. Wu, ;;E. Myers, U. Manber, and W. Miller, ;; ;;"An O(NP) Sequence Comparison Algorithm", ;;Information Processing Letters 35, 6 (1990), 317-323. ;;@end ifset ;; ;;@noindent ;;The values returned by @code{diff:edit-length} can be used to gauge ;;the degree of match between two sequences. ;; ;;@noindent ;;@code{diff:edits} and @code{diff:longest-common-subsequence} combine ;;the algorithm with the divide-and-conquer method outlined in: ;; ;;@ifinfo ;;@example ;;E. Myers and W. Miller, ;; "Optimal alignments in linear space", ;; Computer Application in the Biosciences (CABIOS), 4(1):11-17, 1988. ;; @url{http://www.cs.arizona.edu/people/gene/PAPERS/linear.ps} ;;@end example ;;@end ifinfo ;;@ifset html ;; ;;E. Myers, and W. Miller, ;; ;;"Optimal alignments in linear space", ;;Computer Application in the Biosciences (CABIOS), 4(1):11-17, 1988. ;;@end ifset ;; ;;@noindent ;;If the items being sequenced are text lines, then the computed ;;edit-list is equivalent to the output of the @dfn{diff} utility ;;program. If the items being sequenced are words, then it is like the ;;lesser known @dfn{spiff} program. (require 'array) ;;; p-lim is half the number of gratuitous edits for strings of given ;;; lengths. ;;; When passed #f CC, fp:compare returns edit-distance if successful; ;;; #f otherwise (p > p-lim). When passed CC, fp:compare returns #f. (define (fp:compare fp fpoff CC A M B N p-lim) (define Delta (- N M)) ;;(if (negative? Delta) (slib:error 'fp:compare (fp:subarray A 0 M) '> (fp:subarray B 0 N))) ;;(set! compares (+ 1 compares)) ;(print 'fp:compare M N p-lim) (let loop ((p 0)) (do ((k (- p) (+ 1 k))) ((>= k Delta)) (fp:run fp fpoff k A M B N CC p)) (do ((k (+ Delta p) (+ -1 k))) ((<= k Delta)) (fp:run fp fpoff k A M B N CC p)) (let ((fpval (fp:run fp fpoff Delta A M B N CC p))) ;; At this point, the cost to (fpval-Delta, fpval) is Delta + 2*p (cond ((and (not CC) (<= N fpval)) (+ Delta (* 2 p))) ((and (not (negative? p-lim)) (>= p p-lim)) #f) (else (loop (+ 1 p))))))) ;;; Traces runs of matches until they end; then set fp[k]=y. ;;; If CC is supplied, set each CC[y] = min(CC[y], cost) for run. ;;; Returns furthest y reached. (define (fp:run fp fpoff k A M B N CC p) (define cost (+ k p p)) (let snloop ((y (max (+ (array-ref fp (+ -1 k fpoff)) 1) (array-ref fp (+ 1 k fpoff))))) (define x (- y k)) (and CC (<= y N) (let ((xcst (- M x))) (cond ((negative? xcst)) (else (array-set! CC (min (+ xcst cost) (array-ref CC y)) y))))) ;;(set! tick (+ 1 tick)) (cond ((and (< x M) (< y N) (eqv? (array-ref A x) (array-ref B y))) (snloop (+ 1 y))) (else (array-set! fp y (+ fpoff k)) y)))) ;;; Check that only 1 and -1 steps between adjacent CC entries. ;;(define (fp:step-check A M B N CC) ;; (do ((cdx (+ -1 N) (+ -1 cdx))) ;; ((negative? cdx)) ;; (case (- (array-ref CC cdx) (array-ref CC (+ 1 cdx))) ;; ((1 -1) #t) ;; (else (cond ((> 30 (car (array-dimensions CC))) ;; (display "A: ") (print A) ;; (display "B: ") (print B))) ;; (slib:warn ;; "CC" (append (list (max 0 (+ -5 cdx)) ': (min (+ 1 N) (+ 5 cdx)) ;; 'of) ;; (array-dimensions CC)) ;; (fp:subarray CC (max 0 (+ -5 cdx)) (min (+ 1 N) (+ 5 cdx)))))))) ;;; Correct cost jumps left by fp:compare [which visits only a few (x,y)]. ;;(define (smooth-costs CC N) ;; (do ((cdx (+ -1 N) (+ -1 cdx))) ; smooth from end ;; ((negative? cdx)) ;; (array-set! CC (min (array-ref CC cdx) (+ 1 (array-ref CC (+ 1 cdx)))) ;; cdx)) ;; (do ((cdx 1 (+ 1 cdx))) ; smooth toward end ;; ((> cdx N)) ;; (array-set! CC (min (array-ref CC cdx) (+ 1 (array-ref CC (+ -1 cdx)))) ;; cdx)) ;; CC) (define (diff:mid-split N RR CC cost) ;; RR is not longer than CC. So do for each element of RR. (let loop ((cdx (+ 1 (quotient N 2))) (rdx (quotient N 2))) ;;(if (negative? rdx) (slib:error 'negative? 'rdx)) (cond ((eqv? cost (+ (array-ref CC rdx) (array-ref RR (- N rdx)))) rdx) ((eqv? cost (+ (array-ref CC cdx) (array-ref RR (- N cdx)))) cdx) (else (loop (+ 1 cdx) (+ -1 rdx)))))) ;;; Return 0-based shared array. ;;; Reverse RA if END < START. (define (fp:subarray RA start end) (define n-len (abs (- end start))) (if (< end start) (make-shared-array RA (lambda (idx) (list (+ -1 (- start idx)))) n-len) (make-shared-array RA (lambda (idx) (list (+ start idx))) n-len))) (define (fp:init! fp fpoff fill mindx maxdx) (define mlim (+ fpoff mindx)) (do ((idx (+ fpoff maxdx) (+ -1 idx))) ((< idx mlim)) (array-set! fp fill idx))) ;;; Split A[start-a..end-a] (shorter array) into smaller and smaller chunks. ;;; EDX is index into EDITS. ;;; EPO is insert/delete polarity (+1 or -1) (define (diff:divide-and-conquer fp fpoff CCRR A start-a end-a B start-b end-b edits edx epo p-lim) (define mid-a (quotient (+ start-a end-a) 2)) (define len-b (- end-b start-b)) (define len-a (- end-a start-a)) (let ((tcst (+ p-lim p-lim (- len-b len-a)))) (define CC (fp:subarray CCRR 0 (+ len-b 1))) (define RR (fp:subarray CCRR (+ len-b 1) (* 2 (+ len-b 1)))) (define M2 (- end-a mid-a)) (define M1 (- mid-a start-a)) (fp:init! CC 0 (+ len-a len-b) 0 len-b) (fp:init! fp fpoff -1 (- (+ 1 p-lim)) (+ 1 p-lim (- len-b M1))) (fp:compare fp fpoff CC (fp:subarray A start-a mid-a) M1 (fp:subarray B start-b end-b) len-b (min p-lim len-a)) (fp:init! RR 0 (+ len-a len-b) 0 len-b) (fp:init! fp fpoff -1 (- (+ 1 p-lim)) (+ 1 p-lim (- len-b M2))) (fp:compare fp fpoff RR (fp:subarray A end-a mid-a) M2 (fp:subarray B end-b start-b) len-b (min p-lim len-a)) ;;(smooth-costs CC len-b) (smooth-costs RR len-b) (let ((b-splt (diff:mid-split len-b RR CC tcst))) (define est-c (array-ref CC b-splt)) (define est-r (array-ref RR (- len-b b-splt))) ;;(display "A: ") (array-for-each display (fp:subarray A start-a mid-a)) (display " + ") (array-for-each display (fp:subarray A mid-a end-a)) (newline) ;;(display "B: ") (array-for-each display (fp:subarray B start-b end-b)) (newline) ;;(print 'cc cc) (print 'rr (fp:subarray RR (+ 1 len-b) 0)) ;;(print (make-string (+ 12 (* 2 b-splt)) #\-) '^ (list b-splt)) (check-cost! 'CC est-c (diff2et fp fpoff CCRR A start-a mid-a B start-b (+ start-b b-splt) edits edx epo (quotient (- est-c (- b-splt (- mid-a start-a))) 2))) (check-cost! 'RR est-r (diff2et fp fpoff CCRR A mid-a end-a B (+ start-b b-splt) end-b edits (+ est-c edx) epo (quotient (- est-r (- (- len-b b-splt) (- end-a mid-a))) 2))) (+ est-c est-r)))) ;;; Trim; then diff sub-arrays; either one longer. Returns edit-length (define (diff2et fp fpoff CCRR A start-a end-a B start-b end-b edits edx epo p-lim) ;; (if (< (- end-a start-a) p-lim) (slib:warn 'diff2et 'len-a (- end-a start-a) 'len-b (- end-b start-b) 'p-lim p-lim)) (do ((bdx (+ -1 end-b) (+ -1 bdx)) (adx (+ -1 end-a) (+ -1 adx))) ((not (and (<= start-b bdx) (<= start-a adx) (eqv? (array-ref A adx) (array-ref B bdx)))) (do ((bsx start-b (+ 1 bsx)) (asx start-a (+ 1 asx))) ((not (and (< bsx bdx) (< asx adx) (eqv? (array-ref A asx) (array-ref B bsx)))) ;;(print 'trim-et (- asx start-a) '+ (- end-a adx)) (let ((delta (- (- bdx bsx) (- adx asx)))) (if (negative? delta) (diff2ez fp fpoff CCRR B bsx (+ 1 bdx) A asx (+ 1 adx) edits edx (- epo) (+ delta p-lim)) (diff2ez fp fpoff CCRR A asx (+ 1 adx) B bsx (+ 1 bdx) edits edx epo p-lim)))) ;;(set! tick (+ 1 tick)) )) ;;(set! tick (+ 1 tick)) )) ;;; Diff sub-arrays, A not longer than B. Returns edit-length (define (diff2ez fp fpoff CCRR A start-a end-a B start-b end-b edits edx epo p-lim) (define len-a (- end-a start-a)) (define len-b (- end-b start-b)) ;;(if (> len-a len-b) (slib:error 'diff2ez len-a '> len-b)) (cond ((zero? p-lim) ; B inserts only (if (= len-b len-a) 0 ; A = B; no edits (let loop ((adx start-a) (bdx start-b) (edx edx)) (cond ((>= bdx end-b) (- len-b len-a)) ((>= adx end-a) (do ((idx bdx (+ 1 idx)) (edx edx (+ 1 edx))) ((>= idx end-b) (- len-b len-a)) (array-set! edits (* epo (+ 1 idx)) edx))) ((eqv? (array-ref A adx) (array-ref B bdx)) ;;(set! tick (+ 1 tick)) (loop (+ 1 adx) (+ 1 bdx) edx)) (else (array-set! edits (* epo (+ 1 bdx)) edx) ;;(set! tick (+ 1 tick)) (loop adx (+ 1 bdx) (+ 1 edx))))))) ((<= len-a p-lim) ; delete all A; insert all B ;;(if (< len-a p-lim) (slib:error 'diff2ez len-a len-b 'p-lim p-lim)) (do ((idx start-a (+ 1 idx)) (jdx start-b (+ 1 jdx))) ((and (>= idx end-a) (>= jdx end-b)) (+ len-a len-b)) (cond ((< jdx end-b) (array-set! edits (* epo (+ 1 jdx)) edx) (set! edx (+ 1 edx)))) (cond ((< idx end-a) (array-set! edits (* epo (- -1 idx)) edx) (set! edx (+ 1 edx)))))) (else (diff:divide-and-conquer fp fpoff CCRR A start-a end-a B start-b end-b edits edx epo p-lim)))) (define (check-cost! name est cost) (if (not (eqv? est cost)) (slib:warn name "cost check failed" est '!= cost))) ;;;; Routines interfacing API layer to algorithms. (define (diff:invert-edits! edits) (define cost (car (array-dimensions edits))) (do ((idx (+ -1 cost) (+ -1 idx))) ((negative? idx)) (array-set! edits (- (array-ref edits idx)) idx))) ;;; len-a < len-b (define (edits2lcs! lcs edits A) (define cost (car (array-dimensions edits))) (define len-a (car (array-dimensions A))) (let loop ((edx 0) (sdx 0) (adx 0)) (let ((edit (if (< edx cost) (array-ref edits edx) 0))) (cond ((>= adx len-a)) ((positive? edit) (loop (+ 1 edx) sdx adx)) ((zero? edit) (array-set! lcs (array-ref A adx) sdx) (loop edx (+ 1 sdx) (+ 1 adx))) ((>= adx (- -1 edit)) (loop (+ 1 edx) sdx (+ 1 adx))) (else (array-set! lcs (array-ref A adx) sdx) (loop edx (+ 1 sdx) (+ 1 adx))))))) ;; A not longer than B (M <= N) (define (diff2edits! edits fp CCRR A B) (define N (car (array-dimensions B))) (define M (car (array-dimensions A))) (define est (car (array-dimensions edits))) (let ((p-lim (quotient (- est (- N M)) 2))) (check-cost! 'diff2edits! est (diff2et fp (+ 1 p-lim) CCRR A 0 M B 0 N edits 0 1 p-lim)))) ;; A not longer than B (M <= N) (define (diff2editlen fp A B p-lim) (define N (car (array-dimensions B))) (define M (car (array-dimensions A))) (let ((maxdx (if (negative? p-lim) (+ 1 N) (+ 1 p-lim (- N M)))) (mindx (if (negative? p-lim) (- (+ 1 M)) (- (+ 1 p-lim))))) (fp:init! fp (- mindx) -1 mindx maxdx) (fp:compare fp (- mindx) #f A M B N p-lim))) ;;;; API ;;@args array1 array2 p-lim ;;@args array1 array2 ;;@1 and @2 are one-dimensional arrays. ;; ;;The non-negative integer @3, if provided, is maximum number of ;;deletions of the shorter sequence to allow. @0 will return @code{#f} ;;if more deletions would be necessary. ;; ;;@0 returns a one-dimensional array of length @code{(quotient (- (+ ;;len1 len2) (diff:edit-length @1 @2)) 2)} holding the longest sequence ;;common to both @var{array}s. (define (diff:longest-common-subsequence A B . p-lim) (define M (car (array-dimensions A))) (define N (car (array-dimensions B))) (set! p-lim (if (null? p-lim) -1 (car p-lim))) (let ((edits (if (< N M) (diff:edits B A p-lim) (diff:edits A B p-lim)))) (and edits (let* ((cost (car (array-dimensions edits))) (lcs (make-array A (/ (- (+ N M) cost) 2)))) (edits2lcs! lcs edits (if (< N M) B A)) lcs)))) ;;@args array1 array2 p-lim ;;@args array1 array2 ;;@1 and @2 are one-dimensional arrays. ;; ;;The non-negative integer @3, if provided, is maximum number of ;;deletions of the shorter sequence to allow. @0 will return @code{#f} ;;if more deletions would be necessary. ;; ;;@0 returns a vector of length @code{(diff:edit-length @1 @2)} composed ;;of a shortest sequence of edits transformaing @1 to @2. ;; ;;Each edit is an integer: ;;@table @asis ;;@item @var{k} > 0 ;;Inserts @code{(array-ref @1 (+ -1 @var{j}))} into the sequence. ;;@item @var{k} < 0 ;;Deletes @code{(array-ref @2 (- -1 @var{k}))} from the sequence. ;;@end table (define (diff:edits A B . p-lim) (define M (car (array-dimensions A))) (define N (car (array-dimensions B))) (define est (diff:edit-length A B (if (null? p-lim) -1 (car p-lim)))) (and est (let ((CCRR (make-array (A:fixZ32b) (* 2 (+ (max M N) 1)))) (edits (make-array (A:fixZ32b) est))) (define fp (make-array (A:fixZ32b) (+ (max (- N (quotient M 2)) (- M (quotient N 2))) (- est (abs (- N M))) ; 2 * p-lim 3))) (cond ((< N M) (diff2edits! edits fp CCRR B A) (diff:invert-edits! edits)) (else (diff2edits! edits fp CCRR A B))) ;;(diff:order-edits! edits est) edits))) ;;@args array1 array2 p-lim ;;@args array1 array2 ;;@1 and @2 are one-dimensional arrays. ;; ;;The non-negative integer @3, if provided, is maximum number of ;;deletions of the shorter sequence to allow. @0 will return @code{#f} ;;if more deletions would be necessary. ;; ;;@0 returns the length of the shortest sequence of edits transformaing ;;@1 to @2. (define (diff:edit-length A B . p-lim) (define M (car (array-dimensions A))) (define N (car (array-dimensions B))) (set! p-lim (if (null? p-lim) -1 (car p-lim))) (let ((fp (make-array (A:fixZ32b) (if (negative? p-lim) (+ 3 M N) (+ 3 (abs (- N M)) p-lim p-lim))))) (if (< N M) (diff2editlen fp B A p-lim) (diff2editlen fp A B p-lim)))) ;;@example ;;(diff:longest-common-subsequence "fghiejcklm" "fgehijkpqrlm") ;;@result{} "fghijklm" ;; ;;(diff:edit-length "fghiejcklm" "fgehijkpqrlm") ;;@result{} 6 ;; ;;(diff:edits "fghiejcklm" "fgehijkpqrlm") ;;@result{} #A:fixZ32b(3 -5 -7 8 9 10) ;; ; e c h p q r ;;@end example ;;(trace-all "/home/jaffer/slib/differ.scm")(set! *qp-width* 999)(untrace fp:run) ; fp:subarray slib-3b1/differ.txi0000644001705200017500000000733510747237373012202 0ustar tbtb@noindent @code{diff:edit-length} implements the algorithm: @ifinfo @example S. Wu, E. Myers, U. Manber, and W. Miller, "An O(NP) Sequence Comparison Algorithm," Information Processing Letters 35, 6 (1990), 317-323. @url{http://www.cs.arizona.edu/people/gene/PAPERS/np_diff.ps} @end example @end ifinfo @ifset html S. Wu, E. Myers, U. Manber, and W. Miller, "An O(NP) Sequence Comparison Algorithm", Information Processing Letters 35, 6 (1990), 317-323. @end ifset @noindent The values returned by @code{diff:edit-length} can be used to gauge the degree of match between two sequences. @noindent @code{diff:edits} and @code{diff:longest-common-subsequence} combine the algorithm with the divide-and-conquer method outlined in: @ifinfo @example E. Myers and W. Miller, "Optimal alignments in linear space", Computer Application in the Biosciences (CABIOS), 4(1):11-17, 1988. @url{http://www.cs.arizona.edu/people/gene/PAPERS/linear.ps} @end example @end ifinfo @ifset html E. Myers, and W. Miller, "Optimal alignments in linear space", Computer Application in the Biosciences (CABIOS), 4(1):11-17, 1988. @end ifset @noindent If the items being sequenced are text lines, then the computed edit-list is equivalent to the output of the @dfn{diff} utility @cindex diff program. If the items being sequenced are words, then it is like the lesser known @dfn{spiff} program. @cindex spiff @defun diff:longest-common-subsequence array1 array2 p-lim @defunx diff:longest-common-subsequence array1 array2 @var{array1} and @var{array2} are one-dimensional arrays. The non-negative integer @var{p-lim}, if provided, is maximum number of deletions of the shorter sequence to allow. @code{diff:longest-common-subsequence} will return @code{#f} if more deletions would be necessary. @code{diff:longest-common-subsequence} returns a one-dimensional array of length @code{(quotient (- (+ len1 len2) (diff:edit-length @var{array1} @var{array2})) 2)} holding the longest sequence common to both @var{array}s. @end defun @defun diff:edits array1 array2 p-lim @defunx diff:edits array1 array2 @var{array1} and @var{array2} are one-dimensional arrays. The non-negative integer @var{p-lim}, if provided, is maximum number of deletions of the shorter sequence to allow. @code{diff:edits} will return @code{#f} if more deletions would be necessary. @code{diff:edits} returns a vector of length @code{(diff:edit-length @var{array1} @var{array2})} composed of a shortest sequence of edits transformaing @var{array1} to @var{array2}. Each edit is an integer: @table @asis @item @var{k} > 0 Inserts @code{(array-ref @var{array1} (+ -1 @var{j}))} into the sequence. @item @var{k} < 0 Deletes @code{(array-ref @var{array2} (- -1 @var{k}))} from the sequence. @end table @end defun @defun diff:edit-length array1 array2 p-lim @defunx diff:edit-length array1 array2 @var{array1} and @var{array2} are one-dimensional arrays. The non-negative integer @var{p-lim}, if provided, is maximum number of deletions of the shorter sequence to allow. @code{diff:edit-length} will return @code{#f} if more deletions would be necessary. @code{diff:edit-length} returns the length of the shortest sequence of edits transformaing @var{array1} to @var{array2}. @end defun @example (diff:longest-common-subsequence "fghiejcklm" "fgehijkpqrlm") @result{} "fghijklm" (diff:edit-length "fghiejcklm" "fgehijkpqrlm") @result{} 6 (diff:edits "fghiejcklm" "fgehijkpqrlm") @result{} #A:fixZ32b(3 -5 -7 8 9 10) ; e c h p q r @end example slib-3b1/dirs.scm0000644001705200017500000000650410733635474011656 0ustar tbtb;;; "dirs.scm" Directories. ; Copyright 1998, 2002 Aubrey Jaffer ; ;Permission to copy this software, to modify it, to redistribute it, ;to distribute modified versions, and to use it for any purpose is ;granted, subject to the following restrictions and understandings. ; ;1. Any copy made of this software must include this copyright notice ;in full. ; ;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; ;3. In conjunction with products arising from the use of this ;material, there shall be no use of my name in any advertising, ;promotional, or sales literature without prior written consent in ;each case. (require 'filename) (require 'line-i/o) (require 'system) (require 'filename) ;;@code{(require 'directory)} ;;@ftindex directory ;;@args ;;@0 returns a string containing the absolute file ;;name representing the current working directory. If this string ;;cannot be obtained, #f is returned. ;; ;;If @0 cannot be supported by the platform, then #f is returned. (define current-directory (case (software-type) ;;((amiga) ) ;;((macos thinkc) ) ((ms-dos windows atarist os/2) (lambda () (system->line "cd"))) ;;((nosve) ) ((unix coherent plan9) (lambda () (system->line "pwd"))) ;;((vms) ) (else #f))) ;;@body ;;Creates a sub-directory @1 of the current-directory. If ;;successful, @0 returns #t; otherwise #f. (define (make-directory name) (eqv? 0 (system (string-append "mkdir \"" name "\"")))) (define (dir:lister dirname tmp) (case (software-type) ((unix coherent plan9) (zero? (system (string-append "ls '" dirname "' > " tmp)))) ((ms-dos windows os/2 atarist) (zero? (system (string-append "DIR /B \"" dirname "\" > " tmp)))) (else (slib:error (software-type) 'list?)))) ;;@args proc directory ;;@var{proc} must be a procedure taking one argument. ;;@samp{Directory-For-Each} applies @var{proc} to the (string) name of ;;each file in @var{directory}. The dynamic order in which @var{proc} is ;;applied to the filenames is unspecified. The value returned by ;;@samp{directory-for-each} is unspecified. ;; ;;@args proc directory pred ;;Applies @var{proc} only to those filenames for which the procedure ;;@var{pred} returns a non-false value. ;; ;;@args proc directory match ;;Applies @var{proc} only to those filenames for which ;;@code{(filename:match?? @var{match})} would return a non-false value ;;(@pxref{Filenames, , , slib, SLIB}). ;; ;;@example ;;(require 'directory) ;;(directory-for-each print "." "[A-Z]*.scm") ;;@print{} ;;"Bev2slib.scm" ;;"Template.scm" ;;@end example (define (directory-for-each proc dirname . args) (define selector (cond ((null? args) identity) ((> (length args) 1) (slib:error 'directory-for-each 'too-many-arguments (cdr args))) ((procedure? (car args)) (car args)) ((string? (car args)) (filename:match?? (car args))) (else (slib:error 'directory-for-each 'filter? (car args))))) (call-with-tmpnam (lambda (tmp) (and (dir:lister dirname tmp) (file-exists? tmp) (call-with-input-file tmp (lambda (port) (do ((filename (read-line port) (read-line port))) ((or (eof-object? filename) (equal? "" filename))) (and (selector filename) (proc filename))))))))) slib-3b1/dirs.txi0000644001705200017500000000251410747237373011676 0ustar tbtb@code{(require 'directory)} @ftindex directory @defun current-directory @code{current-directory} returns a string containing the absolute file name representing the current working directory. If this string cannot be obtained, #f is returned. If @code{current-directory} cannot be supported by the platform, then #f is returned. @end defun @defun make-directory name Creates a sub-directory @var{name} of the current-directory. If successful, @code{make-directory} returns #t; otherwise #f. @end defun @defun directory-for-each proc directory @var{proc} must be a procedure taking one argument. @samp{Directory-For-Each} applies @var{proc} to the (string) name of each file in @var{directory}. The dynamic order in which @var{proc} is applied to the filenames is unspecified. The value returned by @samp{directory-for-each} is unspecified. @defunx directory-for-each proc directory pred Applies @var{proc} only to those filenames for which the procedure @var{pred} returns a non-false value. @defunx directory-for-each proc directory match Applies @var{proc} only to those filenames for which @code{(filename:match?? @var{match})} would return a non-false value (@pxref{Filenames, , , slib, SLIB}). @example (require 'directory) (directory-for-each print "." "[A-Z]*.scm") @print{} "Bev2slib.scm" "Template.scm" @end example @end defun slib-3b1/dwindtst.scm0000644001705200017500000000443607776076457012574 0ustar tbtb;;;; "dwindtst.scm", routines for characterizing dynamic-wind. ;Copyright (C) 1992 Aubrey Jaffer ; ;Permission to copy this software, to modify it, to redistribute it, ;to distribute modified versions, and to use it for any purpose is ;granted, subject to the following restrictions and understandings. ; ;1. Any copy made of this software must include this copyright notice ;in full. ; ;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; ;3. In conjunction with products arising from the use of this ;material, there shall be no use of my name in any advertising, ;promotional, or sales literature without prior written consent in ;each case. (require 'dynamic-wind) (define (dwtest n) (define cont #f) (display "testing escape from thunk") (display n) (newline) (display "visiting:") (newline) (call-with-current-continuation (lambda (x) (set! cont x))) (if n (dynamic-wind (lambda () (display "thunk1") (newline) (if (eqv? n 1) (let ((ntmp n)) (set! n #f) (cont ntmp)))) (lambda () (display "thunk2") (newline) (if (eqv? n 2) (let ((ntmp n)) (set! n #f) (cont ntmp)))) (lambda () (display "thunk3") (newline) (if (eqv? n 3) (let ((ntmp n)) (set! n #f) (cont ntmp))))))) (define (dwctest n) (define cont #f) (define ccont #f) (display "creating continuation thunk") (newline) (display "visiting:") (newline) (call-with-current-continuation (lambda (x) (set! cont x))) (if n (set! n (- n))) (if n (dynamic-wind (lambda () (display "thunk1") (newline) (if (eqv? n 1) (let ((ntmp n)) (set! n #f) (cont ntmp)))) (lambda () (call-with-current-continuation (lambda (x) (set! ccont x))) (display "thunk2") (newline) (if (eqv? n 2) (let ((ntmp n)) (set! n #f) (cont ntmp)))) (lambda () (display "thunk3") (newline) (if (eqv? n 3) (let ((ntmp n)) (set! n #f) (cont ntmp)))))) (cond (n (set! n (- n)) (display "testing escape from continuation thunk") (display n) (newline) (display "visiting:") (newline) (ccont #f)))) (dwtest 1) (dwtest 2) (dwtest 3) (dwctest 1) (dwctest 2) (dwctest 3) slib-3b1/dynamic.scm0000644001705200017500000000504007776076457012350 0ustar tbtb; "dynamic.scm", DYNAMIC data type for Scheme ; Copyright 1992 Andrew Wilcox. ; ; You may freely copy, redistribute and modify this package. (require 'record) (require 'dynamic-wind) (define dynamic-environment-rtd (make-record-type "dynamic environment" '(dynamic value parent))) (define make-dynamic-environment (record-constructor dynamic-environment-rtd)) (define dynamic-environment:dynamic (record-accessor dynamic-environment-rtd 'dynamic)) (define dynamic-environment:value (record-accessor dynamic-environment-rtd 'value)) (define dynamic-environment:set-value! (record-modifier dynamic-environment-rtd 'value)) (define dynamic-environment:parent (record-accessor dynamic-environment-rtd 'parent)) (define *current-dynamic-environment* #f) (define (extend-current-dynamic-environment dynamic obj) (set! *current-dynamic-environment* (make-dynamic-environment dynamic obj *current-dynamic-environment*))) (define dynamic-rtd (make-record-type "dynamic" '())) ;@ (define make-dynamic (let ((dynamic-constructor (record-constructor dynamic-rtd))) (lambda (obj) (let ((dynamic (dynamic-constructor))) (extend-current-dynamic-environment dynamic obj) dynamic)))) ;@ (define dynamic? (record-predicate dynamic-rtd)) (define (guarantee-dynamic dynamic) (or (dynamic? dynamic) (slib:error "Not a dynamic" dynamic))) (define dynamic:errmsg "No value defined for this dynamic in the current dynamic environment") ;@ (define (dynamic-ref dynamic) (guarantee-dynamic dynamic) (let loop ((env *current-dynamic-environment*)) (cond ((not env) (slib:error dynamic:errmsg dynamic)) ((eq? (dynamic-environment:dynamic env) dynamic) (dynamic-environment:value env)) (else (loop (dynamic-environment:parent env)))))) ;@ (define (dynamic-set! dynamic obj) (guarantee-dynamic dynamic) (let loop ((env *current-dynamic-environment*)) (cond ((not env) (slib:error dynamic:errmsg dynamic)) ((eq? (dynamic-environment:dynamic env) dynamic) (dynamic-environment:set-value! env obj)) (else (loop (dynamic-environment:parent env)))))) ;@ (define (call-with-dynamic-binding dynamic obj thunk) (let ((out-thunk-env #f) (in-thunk-env (make-dynamic-environment dynamic obj *current-dynamic-environment*))) (dynamic-wind (lambda () (set! out-thunk-env *current-dynamic-environment*) (set! *current-dynamic-environment* in-thunk-env)) thunk (lambda () (set! in-thunk-env *current-dynamic-environment*) (set! *current-dynamic-environment* out-thunk-env))))) slib-3b1/dynwind.scm0000644001705200017500000000530010227621450012345 0ustar tbtb; "dynwind.scm", wind-unwind-protect for Scheme ; Copyright (c) 1992, 1993 Aubrey Jaffer ; ;Permission to copy this software, to modify it, to redistribute it, ;to distribute modified versions, and to use it for any purpose is ;granted, subject to the following restrictions and understandings. ; ;1. Any copy made of this software must include this copyright notice ;in full. ; ;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; ;3. In conjunction with products arising from the use of this ;material, there shall be no use of my name in any advertising, ;promotional, or sales literature without prior written consent in ;each case. ;This facility is a generalization of Common Lisp `unwind-protect', ;designed to take into account the fact that continuations produced by ;CALL-WITH-CURRENT-CONTINUATION may be reentered. ; (dynamic-wind ) procedure ;The arguments , , and must all be procedures ;of no arguments (thunks). ;DYNAMIC-WIND calls , , and then . The value ;returned by is returned as the result of DYNAMIC-WIND. ; is also called just before control leaves the dynamic ;context of by calling a continuation created outside that ;context. Furthermore, is called before reentering the ;dynamic context of by calling a continuation created inside ;that context. (Control is inside the context of if ;is on the current return stack). ;;;WARNING: This code has no provision for dealing with errors or ;;;interrupts. If an error or interrupt occurs while using ;;;dynamic-wind, the dynamic environment will be that in effect at the ;;;time of the error or interrupt. (define dynamic:winds '()) ;@ (define (dynamic-wind ) () (set! dynamic:winds (cons (cons ) dynamic:winds)) (let ((ans ())) (set! dynamic:winds (cdr dynamic:winds)) () ans)) ;@ (define call-with-current-continuation (let ((oldcc call-with-current-continuation)) (lambda (proc) (let ((winds dynamic:winds)) (oldcc (lambda (cont) (proc (lambda (c2) (dynamic:do-winds winds (- (length dynamic:winds) (length winds))) (cont c2))))))))) (define (dynamic:do-winds to delta) (cond ((eq? dynamic:winds to)) ((negative? delta) (dynamic:do-winds (cdr to) (+ 1 delta)) ((caar to)) (set! dynamic:winds to)) (else (let ((from (cdar dynamic:winds))) (set! dynamic:winds (cdr dynamic:winds)) (from) (dynamic:do-winds to (+ -1 delta)))))) slib-3b1/elk.init0000644001705200017500000003315110733633204011634 0ustar tbtb;;;"elk.init" Initialisation file for SLIB for ELK 3.0 -*- Scheme -*- ;;; Author: Aubrey Jaffer ;;; ;;; This code is in the public domain. ; No guarantees are given about the correctness of any of the ; choices made below. Only enough work was done to get the require ; mechanism to work correctly. ; ; Stephen J. Bevan 19920912 modified by Mike ; Sperber to work correctly with statically-linked Elk and slib1d. Be ; sure to change the library vicinities according to your local ; configuration. If you're running MS-DOS (which is possible since ; 2.1), you probably have to change this file to make everything work ; correctly. ;;; (software-type) should be set to the generic operating system type. ;;; UNIX, VMS, MACOS, AMIGA and MS-DOS are supported. (define (software-type) 'unix) ;;; (scheme-implementation-type) should return the name of the scheme ;;; implementation loading this file. (define (scheme-implementation-type) 'Elk) ;;; (scheme-implementation-home-page) should return a (string) URI ;;; (Uniform Resource Identifier) for this scheme implementation's home ;;; page; or false if there isn't one. (define (scheme-implementation-home-page) "http://www.informatik.uni-bremen.de/~net/elk/") ;;; (scheme-implementation-version) should return a string describing ;;; the version the scheme implementation loading this file. (define (scheme-implementation-version) "3.0") ;;; (implementation-vicinity) should be defined to be the pathname of ;;; the directory where any auxillary files to your Scheme ;;; implementation reside. (define implementation-vicinity (let ((impl-path (or (getenv "ELK_IMPLEMENTATION_PATH") (case (software-type) ((unix) "/usr/share/elk/") ((vms) "scheme$src:") ((ms-dos) "C:\\scheme\\") (else ""))))) (lambda () impl-path))) ;;; (library-vicinity) should be defined to be the pathname of the ;;; directory where files of Scheme library functions reside. (require 'unix) (define getenv unix-getenv) (define system unix-system) (define library-vicinity (let ((library-path (or (getenv "SCHEME_LIBRARY_PATH") ;; Uses this path if SCHEME_LIBRARY_PATH is not defined. (case (software-type) ((unix) "/usr/local/lib/slib/") ((vms) "lib$scheme:") ((ms-dos) "C:\\SLIB\\") (else ""))))) (lambda () library-path))) ;;; (home-vicinity) should return the vicinity of the user's HOME ;;; directory, the directory which typically contains files which ;;; customize a computer environment for a user. (define (home-vicinity) (let ((home (getenv "HOME"))) (and home (case (software-type) ((unix coherent ms-dos) ;V7 unix has a / on HOME (if (eqv? #\/ (string-ref home (+ -1 (string-length home)))) home (string-append home "/"))) (else home))))) ;@ (define in-vicinity string-append) ;@ (define (user-vicinity) (case (software-type) ((vms) "[.]") (else ""))) (define *load-pathname* #f) ;@ (define vicinity:suffix? (let ((suffi (case (software-type) ((amiga) '(#\: #\/)) ((macos thinkc) '(#\:)) ((ms-dos windows atarist os/2) '(#\\ #\/)) ((nosve) '(#\: #\.)) ((unix coherent plan9) '(#\/)) ((vms) '(#\: #\])) (else (slib:warn "require.scm" 'unknown 'software-type (software-type)) "/")))) (lambda (chr) (and (memv chr suffi) #t)))) ;@ (define (pathname->vicinity pathname) (let loop ((i (- (string-length pathname) 1))) (cond ((negative? i) "") ((vicinity:suffix? (string-ref pathname i)) (substring pathname 0 (+ i 1))) (else (loop (- i 1)))))) (define (program-vicinity) (if *load-pathname* (pathname->vicinity *load-pathname*) (slib:error 'program-vicinity " called; use slib:load to load"))) ;@ (define sub-vicinity (case (software-type) ((vms) (lambda (vic name) (let ((l (string-length vic))) (if (or (zero? (string-length vic)) (not (char=? #\] (string-ref vic (- l 1))))) (string-append vic "[" name "]") (string-append (substring vic 0 (- l 1)) "." name "]"))))) (else (let ((*vicinity-suffix* (case (software-type) ((nosve) ".") ((macos thinkc) ":") ((ms-dos windows atarist os/2) "\\") ((unix coherent plan9 amiga) "/")))) (lambda (vic name) (string-append vic name *vicinity-suffix*)))))) ;@ (define (make-vicinity ) ) ;@ (define with-load-pathname (let ((exchange (lambda (new) (let ((old *load-pathname*)) (set! *load-pathname* new) old)))) (lambda (path thunk) (let* ((old (exchange path)) (val (thunk))) (exchange old) val)))) ;;@ SLIB:FEATURES is a list of symbols naming the (SLIB) features ;;; initially supported by this implementation. (define slib:features '( source ;can load scheme source files ;(SLIB:LOAD-SOURCE "filename") compiled ;can load compiled files ;(SLIB:LOAD-COMPILED "filename") vicinity srfi-59 srfi-96 ;; Scheme report features ;; R5RS-compliant implementations should provide all 9 features. ;;; r5rs ;conforms to ;;; eval ;R5RS two-argument eval ;;; values ;R5RS multiple values ;;; dynamic-wind ;R5RS dynamic-wind ;;; macro ;R5RS high level macros delay ;has DELAY and FORCE multiarg-apply ;APPLY can take more than 2 args. ;;; char-ready? rev4-optional-procedures ;LIST-TAIL, STRING-COPY, ;STRING-FILL!, and VECTOR-FILL! ;; These four features are optional in both R4RS and R5RS multiarg/and- ;/ and - can take more than 2 args. ;;; rationalize transcript ;TRANSCRIPT-ON and TRANSCRIPT-OFF ;;; with-file ;has WITH-INPUT-FROM-FILE and ;WITH-OUTPUT-TO-FILE r4rs ;conforms to ieee-p1178 ;conforms to ;;; r3rs ;conforms to rev2-procedures ;SUBSTRING-MOVE-LEFT!, ;SUBSTRING-MOVE-RIGHT!, ;SUBSTRING-FILL!, ;STRING-NULL?, APPEND!, 1+, ;-1+, ?, >=? ;;; object-hash ;has OBJECT-HASH full-continuation ;can return multiple times ;;; ieee-floating-point ;conforms to IEEE Standard 754-1985 ;IEEE Standard for Binary ;Floating-Point Arithmetic. ;; Other common features ;;; srfi-0 ;srfi-0, COND-EXPAND finds all srfi-* sicp ;runs code from Structure and ;Interpretation of Computer ;Programs by Abelson and Sussman. defmacro ;has Common Lisp DEFMACRO ;;; record ;has user defined data structures string-port ;has CALL-WITH-INPUT-STRING and ;CALL-WITH-OUTPUT-STRING sort ;;; pretty-print ;;; object->string format ;Common-lisp output formatting ;;; trace ;has macros: TRACE and UNTRACE ;;; compiler ;has (COMPILER) ;;; ed ;(ED) is editor system ;posix (system ) getenv ;posix (getenv ) program-arguments ;returns list of strings (argv) ;;; current-time ;returns time in seconds since 1/1/1970 ;; Implementation Specific features )) ;------------ (define (program-arguments) (cons (symbol->string (scheme-implementation-type)) (command-line-args))) ; EXACT? appears to always return #f which isn't very useful. ; Approximating it with INTEGER? at least means that some ; of the code in the library will work correctly (define exact? integer?) ; WARNING: redefining EXACT? (define (inexact? arg) (not (exact? arg))) ;;; (TMPNAM) makes a temporary file name. (define tmpnam (let ((cntr 100)) (lambda () (set! cntr (+ 1 cntr)) (let ((tmp (string-append "slib_" (number->string cntr)))) (if (file-exists? tmp) (tmpnam) tmp))))) ; Pull in GENTENV and SYSTEM ;;; (FILE-EXISTS? ) already here. ;;; (DELETE-FILE ) (define (delete-file f) (system (string-append "rm '" f "'"))) ;------------ ;;@ (FILE-POSITION . k) (define (file-position . args) #f) ;;; (OUTPUT-PORT-WIDTH ) (define (output-port-width . arg) 79) ;;; (OUTPUT-PORT-HEIGHT ) (define (output-port-height . arg) 24) ;;; (CURRENT-ERROR-PORT) ;;; is already defined in Elk 2.1 ;;; FORCE-OUTPUT flushes any pending output on optional arg output port ;;; use this definition if your system doesn't have such a procedure. (define force-output flush-output-port) ;;; CALL-WITH-INPUT-STRING and CALL-WITH-OUTPUT-STRING are the string ;;; port versions of CALL-WITH-*PUT-FILE. (define (call-with-output-string f) (let ((outsp (open-output-string))) (f outsp) (let ((s (get-output-string outsp))) (close-output-port outsp) s))) (define (call-with-input-string s f) (let* ((insp (open-input-string s)) (res (f insp))) (close-input-port insp) res)) (define (make-exchanger obj) (lambda (rep) (let ((old obj)) (set! obj rep) old))) (define (open-file filename modes) (case modes ((r rb) (open-input-file filename)) ((w wb) (open-output-file filename)) (else (slib:error 'open-file 'mode? modes)))) (define (port? obj) (or (input-port? port) (output-port? port))) (define (call-with-open-ports . ports) (define proc (car ports)) (cond ((procedure? proc) (set! ports (cdr ports))) (else (set! ports (reverse ports)) (set! proc (car ports)) (set! ports (reverse (cdr ports))))) (let ((ans (apply proc ports))) (for-each close-port ports) ans)) (define (close-port port) (cond ((input-port? port) (close-input-port port) (if (output-port? port) (close-output-port port))) ((output-port? port) (close-output-port port)) (else (slib:error 'close-port 'port? port)))) (define (browse-url url) (define (try cmd end) (zero? (system (string-append cmd url end)))) (or (try "netscape-remote -remote 'openURL(" ")'") (try "netscape -remote 'openURL(" ")'") (try "netscape '" "'&") (try "netscape '" "'"))) ;;; CHAR-CODE-LIMIT is one greater than the largest integer which can ;;; be returned by CHAR->INTEGER. (define char-code-limit 256) ;;; MOST-POSITIVE-FIXNUM is used in modular.scm (define most-positive-fixnum 8388608) ; 23 bit integers ? ;;; Return argument (define (identity x) x) ;;; SLIB:EVAL is single argument eval using the top-level (user) environment. (define slib:eval eval) (define *macros* '()) (define (defmacro? m) (and (assq m *macros*) #t)) (define-macro (defmacro key pattern . body) `(begin (define-macro ,(cons key pattern) ,@body) (set! *macros* (cons (cons ',key (lambda ,pattern ,@body)) *macros*)))) (define (macroexpand-1 e) (if (pair? e) (let ((a (car e))) (cond ((symbol? a) (set! a (assq a *macros*)) (if a (apply (cdr a) (cdr e)) e)) (else e))) e)) (define (macroexpand e) (if (pair? e) (let ((a (car e))) (cond ((symbol? a) (set! a (assq a *macros*)) (if a (macroexpand (apply (cdr a) (cdr e))) e)) (else e))) e)) (define gentemp (let ((*gensym-counter* -1)) (lambda () (set! *gensym-counter* (+ *gensym-counter* 1)) (string->symbol (string-append "slib:G" (number->string *gensym-counter*)))))) (define defmacro:eval slib:eval) (define defmacro:load load) (define slib:warn (lambda args (let ((cep (current-error-port))) (if (provided? 'trace) (print-call-stack cep)) (display "Warn: " cep) (for-each (lambda (x) (display #\space cep) (write x cep)) args)))) ;;; define an error procedure for the library (define slib:error (let ((error error)) (lambda args (if (provided? 'trace) (print-call-stack (current-error-port))) (let ((port (open-output-string)) (err (if (and (pair? args) (symbol? (car args))) (car args) 'slib)) (args (if (and (pair? args) (symbol? (car args))) (cdr args) args))) (for-each (lambda (x) (display x port) (display " " port)) args) (let ((str (get-output-string port))) (close-output-port port) (error err str)))))) ;;; define these as appropriate for your system. (define slib:tab #\tab) (define slib:form-feed #\formfeed) ;;; Define these if your implementation's syntax can support it and if ;;; they are not already defined. ;(define (1+ n) (+ n 1)) ;(define (-1+ n) (+ n -1)) ;(define 1- -1+) ;;; Define SLIB:EXIT to be the implementation procedure to exit or ;;; return if exiting not supported. (define slib:exit (lambda args (exit (cond ((null? args) 0) ((eqv? #t (car args)) 0) ((and (number? (car args)) (integer? (car args))) (car args)) (else 1))))) ;;; Here for backward compatability (define scheme-file-suffix (let ((suffix (case (software-type) ((nosve) "_scm") (else ".scm")))) (lambda () suffix))) ;;; (SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever ;;; suffix all the module files in SLIB have. See feature 'SOURCE. ; Modify the already modified _load_ so that it copes with ; environments correctly. The change involves using ; _(global-environment)_ if none is explicitly specified. ; If this is not done, definitions in files loaded by other files will ; not be loaded in the correct environment. (define slib:load-source (let ((primitive-load load)) (lambda ( . rest) (let ((env (if (null? rest) (list (global-environment)) rest))) (apply primitive-load (string-append (scheme-file-suffix)) env))))) ;;; (SLIB:LOAD-COMPILED "foo") should load the file that was produced ;;; by compiling "foo.scm" if this implementation can compile files. ;;; See feature 'COMPILED. (define slib:load-compiled (let ((primitive-load load)) (lambda ( . rest) (apply primitive-load (string->symbol (string-append name ".o")) rest)))) ;;; At this point SLIB:LOAD must be able to load SLIB files. (define slib:load slib:load-source) ;WARNING: redefining LOAD ;;; If your implementation provides R4RS macros: ;;(define macro:eval slib:eval) ;;(define macro:load slib:load-source) ;;; If your implementation provides syntax-case macros: ;;(define syncase:eval slib:eval) ;;(define syncase:load slib:load-source) (slib:load (in-vicinity (library-vicinity) "require")) slib-3b1/eval.scm0000644001705200017500000001300210137475772011634 0ustar tbtb; "eval.scm", Eval proposed by Guillermo (Bill) J. Rozas for R5RS. ; Copyright (C) 1997, 1998 Aubrey Jaffer ; ;Permission to copy this software, to modify it, to redistribute it, ;to distribute modified versions, and to use it for any purpose is ;granted, subject to the following restrictions and understandings. ; ;1. Any copy made of this software must include this copyright notice ;in full. ; ;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; ;3. In conjunction with products arising from the use of this ;material, there shall be no use of my name in any advertising, ;promotional, or sales literature without prior written consent in ;each case. ;;; Rather than worry over the status of all the optional procedures, ;;; just require as many as possible. (require 'rev4-optional-procedures) (require 'dynamic-wind) (require 'transcript) (require 'with-file) (require 'values) (define eval:make-environment (let ((eval-1 slib:eval)) (lambda (identifiers) ((lambda args args) #f identifiers (lambda (expression) (eval-1 `(lambda ,identifiers ,expression))))))) (define eval:capture-environment! (let ((set-car! set-car!) (eval-1 slib:eval) (apply apply)) (lambda (environment) (set-car! environment (apply (lambda (environment-values identifiers procedure) (eval-1 `((lambda args args) ,@identifiers))) environment))))) ;@ (define interaction-environment (let ((env (eval:make-environment '()))) (lambda () env))) ;;;@ null-environment is set by first call to scheme-report-environment at ;;; the end of this file. (define null-environment #f) ;@ (define scheme-report-environment (let* ((r4rs-procedures (append (cond ((provided? 'inexact) (append '(acos angle asin atan cos exact->inexact exp expt imag-part inexact->exact log magnitude make-polar make-rectangular real-part sin sqrt tan) (if (let ((n (string->number "1/3"))) (and (number? n) (exact? n))) '(denominator numerator) '()))) (else '())) (cond ((provided? 'rationalize) '(rationalize)) (else '())) (cond ((provided? 'delay) '(force)) (else '())) (cond ((provided? 'char-ready?) '(char-ready?)) (else '())) '(* + - / < <= = > >= abs append apply assoc assq assv boolean? caaaar caaadr caaar caadar caaddr caadr caar cadaar cadadr cadar caddar cadddr caddr cadr call-with-current-continuation call-with-input-file call-with-output-file car cdaaar cdaadr cdaar cdadar cdaddr cdadr cdar cddaar cddadr cddar cdddar cddddr cdddr cddr cdr ceiling char->integer char-alphabetic? char-ci<=? char-ci=? char-ci>? char-downcase char-lower-case? char-numeric? char-upcase char-upper-case? char-whitespace? char<=? char=? char>? char? close-input-port close-output-port complex? cons current-input-port current-output-port display eof-object? eq? equal? eqv? even? exact? floor for-each gcd inexact? input-port? integer->char integer? lcm length list list->string list->vector list-ref list-tail list? load make-string make-vector map max member memq memv min modulo negative? newline not null? number->string number? odd? open-input-file open-output-file output-port? pair? peek-char positive? procedure? quotient rational? read read-char real? remainder reverse round set-car! set-cdr! string string->list string->number string->symbol string-append string-ci<=? string-ci=? string-ci>? string-copy string-fill! string-length string-ref string-set! string<=? string=? string>? string? substring symbol->string symbol? transcript-off transcript-on truncate vector vector->list vector-fill! vector-length vector-ref vector-set! vector? with-input-from-file with-output-to-file write write-char zero? ))) (r5rs-procedures (append '(call-with-values dynamic-wind eval interaction-environment null-environment scheme-report-environment values) r4rs-procedures)) (r4rs-environment (eval:make-environment r4rs-procedures)) (r5rs-environment (eval:make-environment r5rs-procedures))) (let ((car car)) (lambda (version) (cond ((car r5rs-environment)) (else (let ((null-env (eval:make-environment r5rs-procedures))) (set-car! null-env (map (lambda (i) #f) r5rs-procedures)) (set! null-environment (lambda version null-env))) (eval:capture-environment! r4rs-environment) (eval:capture-environment! r5rs-environment))) (case version ((4) r4rs-environment) ((5) r5rs-environment) (else (slib:error 'eval 'version version 'not 'available))))))) ;@ (define eval (let ((eval-1 slib:eval) (apply apply) (null? null?) (eq? eq?)) (lambda (expression . environment) (if (null? environment) (eval-1 expression) (apply (lambda (environment) (if (eq? (interaction-environment) environment) (eval-1 expression) (apply (lambda (environment-values identifiers procedure) (apply (procedure expression) environment-values)) environment))) environment))))) (set! slib:eval eval) ;;; Now that all the R5RS procedures are defined, capture r5rs-environment. (and (scheme-report-environment 5) #t) slib-3b1/factor.scm0000644001705200017500000002144307776076457012207 0ustar tbtb;;;; "factor.scm" factorization, prime test and generation ;;; Copyright (C) 1991, 1992, 1993, 1998 Aubrey Jaffer ; ;Permission to copy this software, to modify it, to redistribute it, ;to distribute modified versions, and to use it for any purpose is ;granted, subject to the following restrictions and understandings. ; ;1. Any copy made of this software must include this copyright notice ;in full. ; ;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; ;3. In conjunction with products arising from the use of this ;material, there shall be no use of my name in any advertising, ;promotional, or sales literature without prior written consent in ;each case. (require 'modular) (require 'random) (require 'byte) ;;@body ;;@0 is the random-state (@pxref{Random Numbers}) used by these ;;procedures. If you call these procedures from more than one thread ;;(or from interrupt), @code{random} may complain about reentrant ;;calls. (define prime:prngs (make-random-state "repeatable seed for primes")) ;;@emph{Note:} The prime test and generation procedures implement (or ;;use) the Solovay-Strassen primality test. See ;; ;;@itemize @bullet ;;@item Robert Solovay and Volker Strassen, ;;@cite{A Fast Monte-Carlo Test for Primality}, ;;SIAM Journal on Computing, 1977, pp 84-85. ;;@end itemize ;;; Solovay-Strassen Prime Test ;;; if n is prime, then J(a,n) is congruent mod n to a**((n-1)/2) ;;; (modulo p 16) is because we care only about the low order bits. ;;; The odd? tests are inline of (expt -1 ...) (define (prime:jacobi-symbol p q) (cond ((zero? p) 0) ((= 1 p) 1) ((odd? p) (if (odd? (quotient (* (- (modulo p 16) 1) (- q 1)) 4)) (- (prime:jacobi-symbol (modulo q p) p)) (prime:jacobi-symbol (modulo q p) p))) (else (let ((qq (modulo q 16))) (if (odd? (quotient (- (* qq qq) 1) 8)) (- (prime:jacobi-symbol (quotient p 2) q)) (prime:jacobi-symbol (quotient p 2) q)))))) ;;@args p q ;;Returns the value (+1, @minus{}1, or 0) of the Jacobi-Symbol of ;;exact non-negative integer @1 and exact positive odd integer @2. (define jacobi-symbol prime:jacobi-symbol) ;;@body ;;@0 the maxinum number of iterations of Solovay-Strassen that will ;;be done to test a number for primality. (define prime:trials 30) ;;; checks if n is prime. Returns #f if not prime. #t if (probably) prime. ;;; probability of a mistake = (expt 2 (- prime:trials)) ;;; choosing prime:trials=30 should be enough (define (Solovay-Strassen-prime? n) (do ((i prime:trials (- i 1)) (a (+ 2 (random (- n 2) prime:prngs)) (+ 2 (random (- n 2) prime:prngs)))) ((not (and (positive? i) (= (gcd a n) 1) (= (modulo (prime:jacobi-symbol a n) n) (modular:expt n a (quotient (- n 1) 2))))) (if (positive? i) #f #t)))) ;;; prime:products are products of small primes. ;;; was (comlist:notevery (lambda (prd) (= 1 (gcd n prd))) comps)) (define (primes-gcd? n comps) (not (let mapf ((lst comps)) (or (null? lst) (and (= 1 (gcd n (car lst))) (mapf (cdr lst))))))) (define prime:prime-sqr 121) (define prime:products '(105)) (define prime:sieve (bytes 0 0 1 1 0 1 0 1 0 0 0)) (letrec ((lp (lambda (comp comps primes nexp) (cond ((< comp (quotient most-positive-fixnum nexp)) (let ((ncomp (* nexp comp))) (lp ncomp comps (cons nexp primes) (next-prime nexp (cons ncomp comps))))) ((< (quotient comp nexp) (* nexp nexp)) (set! prime:prime-sqr (* nexp nexp)) (set! prime:sieve (make-bytes nexp 0)) (for-each (lambda (prime) (byte-set! prime:sieve prime 1)) primes) (set! prime:products (reverse (cons comp comps)))) (else (lp nexp (cons comp comps) (cons nexp primes) (next-prime nexp (cons comp comps))))))) (next-prime (lambda (nexp comps) (set! comps (reverse comps)) (do ((nexp (+ 2 nexp) (+ 2 nexp))) ((not (primes-gcd? nexp comps)) nexp))))) (lp 3 '() '(2 3) 5)) (define (prime:prime? n) (set! n (abs n)) (cond ((< n (bytes-length prime:sieve)) (positive? (byte-ref prime:sieve n))) ((even? n) #f) ((primes-gcd? n prime:products) #f) ((< n prime:prime-sqr) #t) (else (Solovay-Strassen-prime? n)))) ;;@args n ;;Returns @code{#f} if @1 is composite; @code{#t} if @1 is prime. ;;There is a slight chance @code{(expt 2 (- prime:trials))} that a ;;composite will return @code{#t}. (define prime? prime:prime?) (define (prime:prime< start) (do ((nbr (+ -1 start) (+ -1 nbr))) ((or (negative? nbr) (prime:prime? nbr)) (if (negative? nbr) #f nbr)))) ;;@body ;;Returns a list of the first @2 prime numbers less than ;;@1. If there are fewer than @var{count} prime numbers ;;less than @var{start}, then the returned list will have fewer than ;;@var{start} elements. (define (primes< start count) (do ((cnt (+ -2 count) (+ -1 cnt)) (lst '() (cons prime lst)) (prime (prime:prime< start) (prime:prime< prime))) ((or (not prime) (negative? cnt)) (if prime (cons prime lst) lst)))) (define (prime:prime> start) (do ((nbr (+ 1 start) (+ 1 nbr))) ((prime:prime? nbr) nbr))) ;;@body ;;Returns a list of the first @2 prime numbers greater than @1. (define (primes> start count) (set! start (max 0 start)) (do ((cnt (+ -2 count) (+ -1 cnt)) (lst '() (cons prime lst)) (prime (prime:prime> start) (prime:prime> prime))) ((negative? cnt) (reverse (cons prime lst))))) ;;;;Lankinen's recursive factoring algorithm: ;From: ld231782@longs.LANCE.ColoState.EDU (L. Detweiler) ; | undefined if n<0, ; | (u,v) if n=0, ;Let f(u,v,b,n) := | [otherwise] ; | f(u+b,v,2b,(n-v)/2) or f(u,v+b,2b,(n-u)/2) if n odd ; | f(u,v,2b,n/2) or f(u+b,v+b,2b,(n-u-v-b)/2) if n even ;Thm: f(1,1,2,(m-1)/2) = (p,q) iff pq=m for odd m. ;It may be illuminating to consider the relation of the Lankinen function in ;a `computational hierarchy' of other factoring functions.* Assumptions are ;made herein on the basis of conventional digital (binary) computers. Also, ;complexity orders are given for the worst case scenarios (when the number to ;be factored is prime). However, all algorithms would probably perform to ;the same constant multiple of the given orders for complete composite ;factorizations. ;Thm: Eratosthenes' Sieve is very roughtly O(ln(n)/n) in time and ; O(n*log2(n)) in space. ;Pf: It works with all prime factors less than n (about ln(n)/n by the prime ; number thm), requiring an array of size proportional to n with log2(n) ; space for each entry. ;Thm: `Odd factors' is O((sqrt(n)/2)*log2(n)) in time and O(log2(n)) in ; space. ;Pf: It tests all odd factors less than the square root of n (about ; sqrt(n)/2), with log2(n) time for each division. It requires only ; log2(n) space for the number and divisors. ;Thm: Lankinen's algorithm is O(sqrt(n)/2) in time and O((sqrt(n)/2)*log2(n)) ; in space. ;Pf: The algorithm is easily modified to seach only for factors p start count Returns a list of the first @var{count} prime numbers greater than @var{start}. @end defun @defun factor k Returns a list of the prime factors of @var{k}. The order of the factors is unspecified. In order to obtain a sorted list do @code{(sort! (factor @var{k}) <)}. @end defun slib-3b1/FAQ0000644001705200017500000002045310750526413010531 0ustar tbtbFAQ (Frequently Asked Questions and answers) for SLIB Scheme Library (slib-3b1). Written by Aubrey Jaffer (http://swiss.csail.mit.edu/~jaffer). INTRODUCTION AND GENERAL INFORMATION [] What is SLIB? SLIB is a portable scheme library meant to provide compatibiliy and utility functions for all standard scheme implementations. [] What is Scheme? Scheme is a programming language in the Lisp family. [] Which implementations has SLIB been ported to? SLIB supports Bigloo, Chez, ELK 3.0, GAMBIT 3.0, Guile, JScheme, MacScheme, MITScheme, PLT Scheme (DrScheme and MzScheme), Pocket Scheme, RScheme, scheme->C, Scheme48, SCM, SCM Mac, scsh, Stk, T3.1, umb-scheme, and VSCM. [] How can I obtain SLIB? SLIB is available via http from: http://swiss.csail.mit.edu/~jaffer/SLIB.html SLIB is available via ftp from: swiss.csail.mit.edu:/pub/scm/ [] How do I install SLIB? Read the INSTALLATION INSTRUCTIONS in "slib/README". [] What are slib.texi and slib.info? "slib.texi" is the `texinfo' format documentation for SLIB. "slib.info" is produced from "slib.texi" by either Gnu Emacs or the program `makeinfo'. "slib.info" can be viewed using either Gnu Emacs or `info' or a text editor. Programs for printing and viewing TexInfo documentation (which SLIB has) come with GNU Emacs or can be obtained via ftp from: ftp.gnu.org:/pub/gnu/texinfo/texinfo-3.12.tar.gz [] How often is SLIB released? Several times a year. [] What is the latest version? The version as of this writing is slib-3b1. The latest documentation is available online at: http://swiss.csail.mit.edu/~jaffer/SLIB.html [] Which version am I using? The Version is in the first line of the files slib/FAQ, slib/ANNOUNCE, and slib/README. If you have Scheme and SLIB running, type (slib:report-version) SLIB INSTALLATION PROBLEMS [] When I load an SLIB initialization file for my Scheme implementation, I get ERROR: Couldn't find "require.scm" Did you remember to set either the environment variable SCHEME_LIBRARY_PATH or the library-vicinity in your initialization file to the correct location? If you set SCHEME_LIBRARY_PATH, make sure that the Scheme implementation supports getenv. [] When I load an SLIB initialization file for my Scheme implementation, I get ERROR: Couldn't find "/usr/local/lib/slibrequire.scm" Notice that it is looking for "slibrequire.scm" rather than "slib/require.scm". You need to put a trailing slash on either the environment variable SCHEME_LIBRARY_PATH or in the library-vicinity in your initialization file. [] SLIB used to work, but now I get ERROR: Couldn't find "slib/require.scm". What happened? You changed directories and now the relative pathname "slib/require.scm" no longer refers to the same directory. The environment variable SCHEME_LIBRARY_PATH and library-vicinity in your initialization file should be absolute pathnames. [] When I type (require 'macro) I get "ERROR: unbound variable: require". You need to arrange to have your Scheme implementation load the appropriate SLIB initialization file ("foo.init") before using SLIB. If your implementation loads an initialization file on startup, you can have it load the SLIB initialization file automatically. For example (load "/usr/local/lib/slib/foo.init"). [] Why do I get a string-ref (or other) error when I try to load or use SLIB. Check that the version of the Scheme implementation you are using matches the version for which the SLIB initialization file was written. There are some notes in the SLIB initialization files about earlier versions. You may need to get a more recent version of your Scheme implementation. USING SLIB PROCEDURES [] I installed SLIB. When I type (random 5) I get "ERROR: unbound variable: random". Doesn't SLIB have a `random' function? Before you can use most SLIB functions, the associated module needs to be loaded. You do this by typing the line that appears at the top of the page in slib.info (or slib.texi) where the function is documented. In the case of random, that line is (require 'random). [] Why doesn't SLIB just load all the functions so I don't have to type require statements? SLIB has more than 1 Megabyte of Scheme source code. Many scheme implementations take unacceptably long to load 1 Megabyte of source; some implementations cannot allocate enough storage. If you use a package often, you can put the require statement in your Scheme initialization file. Consult the manual for your Scheme implementation to find out the initialization file's name. `Autoloads' will work with many Scheme implementations. You could put the following in your initialization file: (define (random . args) (require 'random) (apply random args)) I find that I only type require statements at top level when debugging. I put require statements in my Scheme files so that the appropriate modules are loaded automatically. [] Why does SLIB have PRINTF when it already has the more powerful (CommonLisp) FORMAT? CommonLisp FORMAT does not support essential features which PRINTF does. For instance, how do you format a signed 0 extended number? (format t "~8,'0,X~%" -3) ==> 000000-3 But printf gets it right: (printf "%08x\n" -3) ==> -0000003 How can one trunctate a non-numeric field using FORMAT? This feature is essential for printing reports. The first 20 letters of a name is sufficient to identify it. But if that name doesn't get trucated to the desired length it can displace other fields off the page. Once again, printf gets it right: (printf "%.20s\n" "the quick brown fox jumped over the lazy dog") ==> the quick brown fox [] Why doesn't SLIB:ERROR call FORMAT? Format does not provide a method to truncate fields. When an error message contains non-terminating or large expressions, the essential information of the message may be lost in the ensuing deluge. MACROS [] Why are there so many macro implementations in SLIB? The R4RS committee specified only the high level pattern language in the Revised^4 Report on Scheme and left to the free marketplace of ideas the details of the low-level facility. Each macro package has a different low-level facility. The low-level facilities are sometimes needed because the high level pattern language is insufficiently powerful to accomplish tasks macros are often written to do. [] Why are there both R4RS macros and Common-Lisp style defmacros in SLIB? Most Scheme implementations predate the adoption of the R4RS macro specification. All of the implementations except scheme48 version 0.45 support defmacro natively. [] I did (LOAD "slib/yasos.scm"). The error I get is "variable define-syntax is undefined". The way to load the struct macro package is (REQUIRE 'YASOS). [] I did (REQUIRE 'YASOS). Now when I type (DEFINE-PREDICATE CELL?) The error I get is "variable define-predicate is undefined". If your Scheme does not natively support R4RS macros, you will need to install a macro-capable read-eval-print loop. This is done by: (require 'macro) ;already done if you did (require 'yasos) (require 'repl) (repl:top-level macro:eval) This would also be true for a Scheme implementation which didn't support DEFMACRO. The lines in this case would be: (require 'repl) (repl:top-level defmacro:eval) [] I always use R4RS macros with an implementation which doesn't natively support them. How can I avoid having to type require statements every time I start Scheme? As explained in the Repl entry in slib.info (or slib.texi): To have your top level loop always use macros, add any interrupt catching code and the following script to your Scheme init file: (require 'macro) (require 'repl) (repl:top-level macro:eval) SRFI [] What is SRFI? "Scheme Requests for Implementation" is a process and informal standard for defining extensions to Scheme. [] Which SRFIs does SLIB support? These can be REQUIREd by the listed (srfi) feature name: srfi-0: Feature-based conditional expansion construct srfi-1: List Library srfi-2: AND-LET*: an AND with local bindings, a guarded LET* special form srfi-8: receive: Binding to multiple values srfi-9: Defining Record Types srfi-11: Syntax for receiving multiple values srfi-23: Error reporting mechanism srfi-28: Basic Format Strings srfi-47: Array srfi-59: Vicinity srfi-60: Integers as Bits srfi-61: A more general cond clause srfi-63: Homogeneous and Heterogeneous Arrays srfi-94: Type-Restricted Numerical Functions srfi-95: Sorting and Merging slib-3b1/fdl.texi0000644001705200017500000005102710747424075011647 0ustar tbtb@c The GNU Free Documentation License. @center Version 1.2, November 2002 @c This file is intended to be included within another document, @c hence no sectioning command or @node. @display Copyright @copyright{} 2000,2001,2002 Free Software Foundation, Inc. 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. @end display @enumerate 0 @item PREAMBLE The purpose of this License is to make a manual, textbook, or other functional and useful document @dfn{free} in the sense of freedom: to assure everyone the effective freedom to copy and redistribute it, with or without modifying it, either commercially or noncommercially. Secondarily, this License preserves for the author and publisher a way to get credit for their work, while not being considered responsible for modifications made by others. This License is a kind of ``copyleft'', which means that derivative works of the document must themselves be free in the same sense. It complements the GNU General Public License, which is a copyleft license designed for free software. We have designed this License in order to use it for manuals for free software, because free software needs free documentation: a free program should come with manuals providing the same freedoms that the software does. But this License is not limited to software manuals; it can be used for any textual work, regardless of subject matter or whether it is published as a printed book. We recommend this License principally for works whose purpose is instruction or reference. @item APPLICABILITY AND DEFINITIONS This License applies to any manual or other work, in any medium, that contains a notice placed by the copyright holder saying it can be distributed under the terms of this License. Such a notice grants a world-wide, royalty-free license, unlimited in duration, to use that work under the conditions stated herein. The ``Document'', below, refers to any such manual or work. Any member of the public is a licensee, and is addressed as ``you''. You accept the license if you copy, modify or distribute the work in a way requiring permission under copyright law. A ``Modified Version'' of the Document means any work containing the Document or a portion of it, either copied verbatim, or with modifications and/or translated into another language. A ``Secondary Section'' is a named appendix or a front-matter section of the Document that deals exclusively with the relationship of the publishers or authors of the Document to the Document's overall subject (or to related matters) and contains nothing that could fall directly within that overall subject. (Thus, if the Document is in part a textbook of mathematics, a Secondary Section may not explain any mathematics.) The relationship could be a matter of historical connection with the subject or with related matters, or of legal, commercial, philosophical, ethical or political position regarding them. The ``Invariant Sections'' are certain Secondary Sections whose titles are designated, as being those of Invariant Sections, in the notice that says that the Document is released under this License. If a section does not fit the above definition of Secondary then it is not allowed to be designated as Invariant. The Document may contain zero Invariant Sections. If the Document does not identify any Invariant Sections then there are none. The ``Cover Texts'' are certain short passages of text that are listed, as Front-Cover Texts or Back-Cover Texts, in the notice that says that the Document is released under this License. A Front-Cover Text may be at most 5 words, and a Back-Cover Text may be at most 25 words. A ``Transparent'' copy of the Document means a machine-readable copy, represented in a format whose specification is available to the general public, that is suitable for revising the document straightforwardly with generic text editors or (for images composed of pixels) generic paint programs or (for drawings) some widely available drawing editor, and that is suitable for input to text formatters or for automatic translation to a variety of formats suitable for input to text formatters. A copy made in an otherwise Transparent file format whose markup, or absence of markup, has been arranged to thwart or discourage subsequent modification by readers is not Transparent. An image format is not Transparent if used for any substantial amount of text. A copy that is not ``Transparent'' is called ``Opaque''. Examples of suitable formats for Transparent copies include plain @sc{ascii} without markup, Texinfo input format, La@TeX{} input format, @acronym{SGML} or @acronym{XML} using a publicly available @acronym{DTD}, and standard-conforming simple @acronym{HTML}, PostScript or @acronym{PDF} designed for human modification. Examples of transparent image formats include @acronym{PNG}, @acronym{XCF} and @acronym{JPG}. Opaque formats include proprietary formats that can be read and edited only by proprietary word processors, @acronym{SGML} or @acronym{XML} for which the @acronym{DTD} and/or processing tools are not generally available, and the machine-generated @acronym{HTML}, PostScript or @acronym{PDF} produced by some word processors for output purposes only. The ``Title Page'' means, for a printed book, the title page itself, plus such following pages as are needed to hold, legibly, the material this License requires to appear in the title page. For works in formats which do not have any title page as such, ``Title Page'' means the text near the most prominent appearance of the work's title, preceding the beginning of the body of the text. A section ``Entitled XYZ'' means a named subunit of the Document whose title either is precisely XYZ or contains XYZ in parentheses following text that translates XYZ in another language. (Here XYZ stands for a specific section name mentioned below, such as ``Acknowledgements'', ``Dedications'', ``Endorsements'', or ``History''.) To ``Preserve the Title'' of such a section when you modify the Document means that it remains a section ``Entitled XYZ'' according to this definition. The Document may include Warranty Disclaimers next to the notice which states that this License applies to the Document. These Warranty Disclaimers are considered to be included by reference in this License, but only as regards disclaiming warranties: any other implication that these Warranty Disclaimers may have is void and has no effect on the meaning of this License. @item VERBATIM COPYING You may copy and distribute the Document in any medium, either commercially or noncommercially, provided that this License, the copyright notices, and the license notice saying this License applies to the Document are reproduced in all copies, and that you add no other conditions whatsoever to those of this License. You may not use technical measures to obstruct or control the reading or further copying of the copies you make or distribute. However, you may accept compensation in exchange for copies. If you distribute a large enough number of copies you must also follow the conditions in section 3. You may also lend copies, under the same conditions stated above, and you may publicly display copies. @item COPYING IN QUANTITY If you publish printed copies (or copies in media that commonly have printed covers) of the Document, numbering more than 100, and the Document's license notice requires Cover Texts, you must enclose the copies in covers that carry, clearly and legibly, all these Cover Texts: Front-Cover Texts on the front cover, and Back-Cover Texts on the back cover. Both covers must also clearly and legibly identify you as the publisher of these copies. The front cover must present the full title with all words of the title equally prominent and visible. You may add other material on the covers in addition. Copying with changes limited to the covers, as long as they preserve the title of the Document and satisfy these conditions, can be treated as verbatim copying in other respects. If the required texts for either cover are too voluminous to fit legibly, you should put the first ones listed (as many as fit reasonably) on the actual cover, and continue the rest onto adjacent pages. If you publish or distribute Opaque copies of the Document numbering more than 100, you must either include a machine-readable Transparent copy along with each Opaque copy, or state in or with each Opaque copy a computer-network location from which the general network-using public has access to download using public-standard network protocols a complete Transparent copy of the Document, free of added material. If you use the latter option, you must take reasonably prudent steps, when you begin distribution of Opaque copies in quantity, to ensure that this Transparent copy will remain thus accessible at the stated location until at least one year after the last time you distribute an Opaque copy (directly or through your agents or retailers) of that edition to the public. It is requested, but not required, that you contact the authors of the Document well before redistributing any large number of copies, to give them a chance to provide you with an updated version of the Document. @item MODIFICATIONS You may copy and distribute a Modified Version of the Document under the conditions of sections 2 and 3 above, provided that you release the Modified Version under precisely this License, with the Modified Version filling the role of the Document, thus licensing distribution and modification of the Modified Version to whoever possesses a copy of it. In addition, you must do these things in the Modified Version: @enumerate A @item Use in the Title Page (and on the covers, if any) a title distinct from that of the Document, and from those of previous versions (which should, if there were any, be listed in the History section of the Document). You may use the same title as a previous version if the original publisher of that version gives permission. @item List on the Title Page, as authors, one or more persons or entities responsible for authorship of the modifications in the Modified Version, together with at least five of the principal authors of the Document (all of its principal authors, if it has fewer than five), unless they release you from this requirement. @item State on the Title page the name of the publisher of the Modified Version, as the publisher. @item Preserve all the copyright notices of the Document. @item Add an appropriate copyright notice for your modifications adjacent to the other copyright notices. @item Include, immediately after the copyright notices, a license notice giving the public permission to use the Modified Version under the terms of this License, in the form shown in the Addendum below. @item Preserve in that license notice the full lists of Invariant Sections and required Cover Texts given in the Document's license notice. @item Include an unaltered copy of this License. @item Preserve the section Entitled ``History'', Preserve its Title, and add to it an item stating at least the title, year, new authors, and publisher of the Modified Version as given on the Title Page. If there is no section Entitled ``History'' in the Document, create one stating the title, year, authors, and publisher of the Document as given on its Title Page, then add an item describing the Modified Version as stated in the previous sentence. @item Preserve the network location, if any, given in the Document for public access to a Transparent copy of the Document, and likewise the network locations given in the Document for previous versions it was based on. These may be placed in the ``History'' section. You may omit a network location for a work that was published at least four years before the Document itself, or if the original publisher of the version it refers to gives permission. @item For any section Entitled ``Acknowledgements'' or ``Dedications'', Preserve the Title of the section, and preserve in the section all the substance and tone of each of the contributor acknowledgements and/or dedications given therein. @item Preserve all the Invariant Sections of the Document, unaltered in their text and in their titles. Section numbers or the equivalent are not considered part of the section titles. @item Delete any section Entitled ``Endorsements''. Such a section may not be included in the Modified Version. @item Do not retitle any existing section to be Entitled ``Endorsements'' or to conflict in title with any Invariant Section. @item Preserve any Warranty Disclaimers. @end enumerate If the Modified Version includes new front-matter sections or appendices that qualify as Secondary Sections and contain no material copied from the Document, you may at your option designate some or all of these sections as invariant. To do this, add their titles to the list of Invariant Sections in the Modified Version's license notice. These titles must be distinct from any other section titles. You may add a section Entitled ``Endorsements'', provided it contains nothing but endorsements of your Modified Version by various parties---for example, statements of peer review or that the text has been approved by an organization as the authoritative definition of a standard. You may add a passage of up to five words as a Front-Cover Text, and a passage of up to 25 words as a Back-Cover Text, to the end of the list of Cover Texts in the Modified Version. Only one passage of Front-Cover Text and one of Back-Cover Text may be added by (or through arrangements made by) any one entity. If the Document already includes a cover text for the same cover, previously added by you or by arrangement made by the same entity you are acting on behalf of, you may not add another; but you may replace the old one, on explicit permission from the previous publisher that added the old one. The author(s) and publisher(s) of the Document do not by this License give permission to use their names for publicity for or to assert or imply endorsement of any Modified Version. @item COMBINING DOCUMENTS You may combine the Document with other documents released under this License, under the terms defined in section 4 above for modified versions, provided that you include in the combination all of the Invariant Sections of all of the original documents, unmodified, and list them all as Invariant Sections of your combined work in its license notice, and that you preserve all their Warranty Disclaimers. The combined work need only contain one copy of this License, and multiple identical Invariant Sections may be replaced with a single copy. If there are multiple Invariant Sections with the same name but different contents, make the title of each such section unique by adding at the end of it, in parentheses, the name of the original author or publisher of that section if known, or else a unique number. Make the same adjustment to the section titles in the list of Invariant Sections in the license notice of the combined work. In the combination, you must combine any sections Entitled ``History'' in the various original documents, forming one section Entitled ``History''; likewise combine any sections Entitled ``Acknowledgements'', and any sections Entitled ``Dedications''. You must delete all sections Entitled ``Endorsements.'' @item COLLECTIONS OF DOCUMENTS You may make a collection consisting of the Document and other documents released under this License, and replace the individual copies of this License in the various documents with a single copy that is included in the collection, provided that you follow the rules of this License for verbatim copying of each of the documents in all other respects. You may extract a single document from such a collection, and distribute it individually under this License, provided you insert a copy of this License into the extracted document, and follow this License in all other respects regarding verbatim copying of that document. @item AGGREGATION WITH INDEPENDENT WORKS A compilation of the Document or its derivatives with other separate and independent documents or works, in or on a volume of a storage or distribution medium, is called an ``aggregate'' if the copyright resulting from the compilation is not used to limit the legal rights of the compilation's users beyond what the individual works permit. When the Document is included in an aggregate, this License does not apply to the other works in the aggregate which are not themselves derivative works of the Document. If the Cover Text requirement of section 3 is applicable to these copies of the Document, then if the Document is less than one half of the entire aggregate, the Document's Cover Texts may be placed on covers that bracket the Document within the aggregate, or the electronic equivalent of covers if the Document is in electronic form. Otherwise they must appear on printed covers that bracket the whole aggregate. @item TRANSLATION Translation is considered a kind of modification, so you may distribute translations of the Document under the terms of section 4. Replacing Invariant Sections with translations requires special permission from their copyright holders, but you may include translations of some or all Invariant Sections in addition to the original versions of these Invariant Sections. You may include a translation of this License, and all the license notices in the Document, and any Warranty Disclaimers, provided that you also include the original English version of this License and the original versions of those notices and disclaimers. In case of a disagreement between the translation and the original version of this License or a notice or disclaimer, the original version will prevail. If a section in the Document is Entitled ``Acknowledgements'', ``Dedications'', or ``History'', the requirement (section 4) to Preserve its Title (section 1) will typically require changing the actual title. @item TERMINATION You may not copy, modify, sublicense, or distribute the Document except as expressly provided for under this License. Any other attempt to copy, modify, sublicense or distribute the Document is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. @item FUTURE REVISIONS OF THIS LICENSE The Free Software Foundation may publish new, revised versions of the GNU Free Documentation License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. See @uref{http://www.gnu.org/copyleft/}. Each version of the License is given a distinguishing version number. If the Document specifies that a particular numbered version of this License ``or any later version'' applies to it, you have the option of following the terms and conditions either of that specified version or of any later version that has been published (not as a draft) by the Free Software Foundation. If the Document does not specify a version number of this License, you may choose any version ever published (not as a draft) by the Free Software Foundation. @end enumerate @page @heading ADDENDUM: How to use this License for your documents To use this License in a document you have written, include a copy of the License in the document and put the following copyright and license notices just after the title page: @smallexample @group Copyright (C) @var{year} @var{your name}. Permission is granted to copy, distribute and/or modify this document under the terms of the GNU Free Documentation License, Version 1.2 or any later version published by the Free Software Foundation; with no Invariant Sections, no Front-Cover Texts, and no Back-Cover Texts. A copy of the license is included in the section entitled ``GNU Free Documentation License''. @end group @end smallexample If you have Invariant Sections, Front-Cover Texts and Back-Cover Texts, replace the ``with@dots{}Texts.'' line with this: @smallexample @group with the Invariant Sections being @var{list their titles}, with the Front-Cover Texts being @var{list}, and with the Back-Cover Texts being @var{list}. @end group @end smallexample If you have Invariant Sections without Cover Texts, or some other combination of the three, merge those two alternatives to suit the situation. If your document contains nontrivial examples of program code, we recommend releasing these examples in parallel under your choice of free software license, such as the GNU General Public License, to permit their use in free software. @c Local Variables: @c ispell-local-pdict: "ispell-dict" @c End: slib-3b1/fluidlet.scm0000644001705200017500000000262210137476753012523 0ustar tbtb; "fluidlet.scm", FLUID-LET for Scheme ; Copyright (C) 1998 Aubrey Jaffer ; ;Permission to copy this software, to modify it, to redistribute it, ;to distribute modified versions, and to use it for any purpose is ;granted, subject to the following restrictions and understandings. ; ;1. Any copy made of this software must include this copyright notice ;in full. ; ;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; ;3. In conjunction with products arising from the use of this ;material, there shall be no use of my name in any advertising, ;promotional, or sales literature without prior written consent in ;each case. (require 'dynamic-wind) ;@ (defmacro fluid-let (clauses . body) (let ((ids (map car clauses)) (new-tmps (map (lambda (x) (gentemp)) clauses)) (old-tmps (map (lambda (x) (gentemp)) clauses))) `(let (,@(map list new-tmps (map cadr clauses)) ,@(map list old-tmps (map (lambda (x) #f) clauses))) (dynamic-wind (lambda () ,@(map (lambda (ot id) `(set! ,ot ,id)) old-tmps ids) ,@(map (lambda (id nt) `(set! ,id ,nt)) ids new-tmps)) (lambda () ,@body) (lambda () ,@(map (lambda (nt id) `(set! ,nt ,id)) new-tmps ids) ,@(map (lambda (id ot) `(set! ,id ,ot)) ids old-tmps)))))) slib-3b1/format.scm0000644001705200017500000015444210112000056012157 0ustar tbtb;;; "format.scm" Common LISP text output formatter for SLIB ; Written 1992-1994 by Dirk Lutzebaeck (lutzeb@cs.tu-berlin.de) ; 2004 Aubrey Jaffer: made reentrant; call slib:error for errors. ; ; This code is in the public domain. ; Authors of the original version (< 1.4) were Ken Dickey and Aubrey Jaffer. ; Please send error reports to the email address above. ; For documentation see slib.texi and format.doc. ; For testing load formatst.scm. ; ; Version 3.0 (require 'string-case) (require 'string-port) (require 'multiarg/and-) (require 'rev4-optional-procedures) (require-if 'compiling 'pretty-print) ;;; Configuration ------------------------------------------------------------ (define format:symbol-case-conv #f) ;; Symbols are converted by symbol->string so the case of the printed ;; symbols is implementation dependent. format:symbol-case-conv is a ;; one arg closure which is either #f (no conversion), string-upcase!, ;; string-downcase! or string-capitalize!. (define format:iobj-case-conv #f) ;; As format:symbol-case-conv but applies for the representation of ;; implementation internal objects. (define format:expch #\E) ;; The character prefixing the exponent value in ~e printing. (define format:iteration-bounded #t) ;; If #t, "~{...~}" iterates no more than format:max-iterations times; ;; if #f, there is no bound. (define format:max-iterations 100) ;; Compatible with previous versions. (define format:floats (provided? 'inexact)) ;; Detects if the scheme system implements flonums (see at eof). (define format:complex-numbers (provided? 'complex)) ;; Detects if the scheme system implements complex numbers. (define format:radix-pref (char=? #\# (string-ref (number->string 8 8) 0))) ;; Detects if number->string adds a radix prefix. (define format:ascii-non-printable-charnames '#("nul" "soh" "stx" "etx" "eot" "enq" "ack" "bel" "bs" "ht" "nl" "vt" "np" "cr" "so" "si" "dle" "dc1" "dc2" "dc3" "dc4" "nak" "syn" "etb" "can" "em" "sub" "esc" "fs" "gs" "rs" "us" "space")) (define format:fn-max 200) ; max. number of number digits (define format:en-max 10) ; max. number of exponent digits ;;; End of configuration ---------------------------------------------------- (define format:version "3.1") (define format:space-ch (char->integer #\space)) (define format:zero-ch (char->integer #\0)) (define format:parameter-characters '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\- #\+ #\v #\# #\')) ;; cardinals & ordinals (from dorai@cs.rice.edu) (define format:cardinal-thousand-block-list '("" " thousand" " million" " billion" " trillion" " quadrillion" " quintillion" " sextillion" " septillion" " octillion" " nonillion" " decillion" " undecillion" " duodecillion" " tredecillion" " quattuordecillion" " quindecillion" " sexdecillion" " septendecillion" " octodecillion" " novemdecillion" " vigintillion")) (define format:cardinal-ones-list '(#f "one" "two" "three" "four" "five" "six" "seven" "eight" "nine" "ten" "eleven" "twelve" "thirteen" "fourteen" "fifteen" "sixteen" "seventeen" "eighteen" "nineteen")) (define format:cardinal-tens-list '(#f #f "twenty" "thirty" "forty" "fifty" "sixty" "seventy" "eighty" "ninety")) (define format:ordinal-ones-list '(#f "first" "second" "third" "fourth" "fifth" "sixth" "seventh" "eighth" "ninth" "tenth" "eleventh" "twelfth" "thirteenth" "fourteenth" "fifteenth" "sixteenth" "seventeenth" "eighteenth" "nineteenth")) (define format:ordinal-tens-list '(#f #f "twentieth" "thirtieth" "fortieth" "fiftieth" "sixtieth" "seventieth" "eightieth" "ninetieth")) ;; roman numerals (from dorai@cs.rice.edu). (define format:roman-alist '((1000 #\M) (500 #\D) (100 #\C) (50 #\L) (10 #\X) (5 #\V) (1 #\I))) (define format:roman-boundary-values '(100 100 10 10 1 1 #f)) ;@ (define (format . args) (define format:port #f) ; curr. format output port (define format:output-col 0) ; curr. format output tty column (define format:flush-output #f) ; flush output at end of formatting (define format:case-conversion #f) (define format:pos 0) ; curr. format string parsing position ;; format string and char output routines on format:port (define (format:out-str str) (if format:case-conversion (display (format:case-conversion str) format:port) (display str format:port)) (set! format:output-col (+ format:output-col (string-length str)))) (define (format:out-char ch) (if format:case-conversion (display (format:case-conversion (string ch)) format:port) (write-char ch format:port)) (set! format:output-col (if (char=? ch #\newline) 0 (+ format:output-col 1)))) ;;(define (format:out-substr str i n) ; this allocates a new string ;; (display (substring str i n) format:port) ;; (set! format:output-col (+ format:output-col n))) (define (format:out-substr str i n) (do ((k i (+ k 1))) ((= k n)) (write-char (string-ref str k) format:port)) (set! format:output-col (+ format:output-col n))) ;;(define (format:out-fill n ch) ; this allocates a new string ;; (format:out-str (make-string n ch))) (define (format:out-fill n ch) (do ((i 0 (+ i 1))) ((= i n)) (write-char ch format:port)) (set! format:output-col (+ format:output-col n))) (define (format:out-obj-padded pad-left obj slashify pars format:read-proof) (if (null? pars) (format:out-str (format:obj->str obj slashify format:read-proof)) (let ((l (length pars))) (let ((mincol (format:par pars l 0 0 "mincol")) (colinc (format:par pars l 1 1 "colinc")) (minpad (format:par pars l 2 0 "minpad")) (padchar (integer->char (format:par pars l 3 format:space-ch #f))) (objstr (format:obj->str obj slashify format:read-proof))) (if (not pad-left) (format:out-str objstr)) (do ((objstr-len (string-length objstr)) (i minpad (+ i colinc))) ((>= (+ objstr-len i) mincol) (format:out-fill i padchar))) (if pad-left (format:out-str objstr)))))) (define (format:out-num-padded modifier number pars radix) (if (not (integer? number)) (slib:error 'format "argument not an integer" number)) (let ((numstr (number->string number radix))) (if (and format:radix-pref (not (= radix 10))) (set! numstr (substring numstr 2 (string-length numstr)))) (if (and (null? pars) (not modifier)) (format:out-str numstr) (let ((l (length pars)) (numstr-len (string-length numstr))) (let ((mincol (format:par pars l 0 #f "mincol")) (padchar (integer->char (format:par pars l 1 format:space-ch #f))) (commachar (integer->char (format:par pars l 2 (char->integer #\,) #f))) (commawidth (format:par pars l 3 3 "commawidth"))) (if mincol (let ((numlen numstr-len)) ; calc. the output len of number (if (and (memq modifier '(at colon-at)) (> number 0)) (set! numlen (+ numlen 1))) (if (memq modifier '(colon colon-at)) (set! numlen (+ (quotient (- numstr-len (if (< number 0) 2 1)) commawidth) numlen))) (if (> mincol numlen) (format:out-fill (- mincol numlen) padchar)))) (if (and (memq modifier '(at colon-at)) (> number 0)) (format:out-char #\+)) (if (memq modifier '(colon colon-at)) ; insert comma character (let ((start (remainder numstr-len commawidth)) (ns (if (< number 0) 1 0))) (format:out-substr numstr 0 start) (do ((i start (+ i commawidth))) ((>= i numstr-len)) (if (> i ns) (format:out-char commachar)) (format:out-substr numstr i (+ i commawidth)))) (format:out-str numstr))))))) (define (format:tabulate modifier pars) (let ((l (length pars))) (let ((colnum (format:par pars l 0 1 "colnum")) (colinc (format:par pars l 1 1 "colinc")) (padch (integer->char (format:par pars l 2 format:space-ch #f)))) (case modifier ((colon colon-at) (slib:error 'format "unsupported modifier for ~~t" modifier)) ((at) ; relative tabulation (format:out-fill (if (= colinc 0) colnum ; colnum = colrel (do ((c 0 (+ c colinc)) (col (+ format:output-col colnum))) ((>= c col) (- c format:output-col)))) padch)) (else ; absolute tabulation (format:out-fill (cond ((< format:output-col colnum) (- colnum format:output-col)) ((= colinc 0) 0) (else (do ((c colnum (+ c colinc))) ((>= c format:output-col) (- c format:output-col))))) padch)))))) (define format:num->old-roman (lambda (n) (if (and (integer? n) (>= n 1)) (let loop ((n n) (romans format:roman-alist) (s '())) (if (null? romans) (list->string (reverse s)) (let ((roman-val (caar romans)) (roman-dgt (cadar romans))) (do ((q (quotient n roman-val) (- q 1)) (s s (cons roman-dgt s))) ((= q 0) (loop (remainder n roman-val) (cdr romans) s)))))) (slib:error 'format "only positive integers can be romanized")))) (define format:num->roman (lambda (n) (if (and (integer? n) (> n 0)) (let loop ((n n) (romans format:roman-alist) (boundaries format:roman-boundary-values) (s '())) (if (null? romans) (list->string (reverse s)) (let ((roman-val (caar romans)) (roman-dgt (cadar romans)) (bdry (car boundaries))) (let loop2 ((q (quotient n roman-val)) (r (remainder n roman-val)) (s s)) (if (= q 0) (if (and bdry (>= r (- roman-val bdry))) (loop (remainder r bdry) (cdr romans) (cdr boundaries) (cons roman-dgt (append (cdr (assv bdry romans)) s))) (loop r (cdr romans) (cdr boundaries) s)) (loop2 (- q 1) r (cons roman-dgt s))))))) (slib:error 'format "only positive integers can be romanized")))) (define format:num->cardinal999 (lambda (n) ;;this procedure is inspired by the Bruno Haible's CLisp ;;function format-small-cardinal, which converts numbers ;;in the range 1 to 999, and is used for converting each ;;thousand-block in a larger number (let* ((hundreds (quotient n 100)) (tens+ones (remainder n 100)) (tens (quotient tens+ones 10)) (ones (remainder tens+ones 10))) (append (if (> hundreds 0) (append (string->list (list-ref format:cardinal-ones-list hundreds)) (string->list" hundred") (if (> tens+ones 0) '(#\space) '())) '()) (if (< tens+ones 20) (if (> tens+ones 0) (string->list (list-ref format:cardinal-ones-list tens+ones)) '()) (append (string->list (list-ref format:cardinal-tens-list tens)) (if (> ones 0) (cons #\- (string->list (list-ref format:cardinal-ones-list ones))) '()))))))) (define format:num->cardinal (lambda (n) (cond ((not (integer? n)) (slib:error 'format "only integers can be converted to English cardinals")) ((= n 0) "zero") ((< n 0) (string-append "minus " (format:num->cardinal (- n)))) (else (let ((power3-word-limit (length format:cardinal-thousand-block-list))) (let loop ((n n) (power3 0) (s '())) (if (= n 0) (list->string s) (let ((n-before-block (quotient n 1000)) (n-after-block (remainder n 1000))) (loop n-before-block (+ power3 1) (if (> n-after-block 0) (append (if (> n-before-block 0) (string->list ", ") '()) (format:num->cardinal999 n-after-block) (if (< power3 power3-word-limit) (string->list (list-ref format:cardinal-thousand-block-list power3)) (append (string->list " times ten to the ") (string->list (format:num->ordinal (* power3 3))) (string->list " power"))) s) s)))))))))) (define format:num->ordinal (lambda (n) (cond ((not (integer? n)) (slib:error 'format "only integers can be converted to English ordinals")) ((= n 0) "zeroth") ((< n 0) (string-append "minus " (format:num->ordinal (- n)))) (else (let ((hundreds (quotient n 100)) (tens+ones (remainder n 100))) (string-append (if (> hundreds 0) (string-append (format:num->cardinal (* hundreds 100)) (if (= tens+ones 0) "th" " ")) "") (if (= tens+ones 0) "" (if (< tens+ones 20) (list-ref format:ordinal-ones-list tens+ones) (let ((tens (quotient tens+ones 10)) (ones (remainder tens+ones 10))) (if (= ones 0) (list-ref format:ordinal-tens-list tens) (string-append (list-ref format:cardinal-tens-list tens) "-" (list-ref format:ordinal-ones-list ones)))) )))))))) ;; format fixed flonums (~F) (define (format:out-fixed modifier number pars) (if (not (or (number? number) (string? number))) (slib:error 'format "argument is not a number or a number string" number)) (let ((l (length pars))) (let ((width (format:par pars l 0 #f "width")) (digits (format:par pars l 1 #f "digits")) (scale (format:par pars l 2 0 #f)) (overch (format:par pars l 3 #f #f)) (padch (format:par pars l 4 format:space-ch #f))) (if digits (begin ; fixed precision (format:parse-float (if (string? number) number (number->string number)) #t scale) (if (<= (- format:fn-len format:fn-dot) digits) (format:fn-zfill #f (- digits (- format:fn-len format:fn-dot))) (format:fn-round digits)) (if width (let ((numlen (+ format:fn-len 1))) (if (or (not format:fn-pos?) (eq? modifier 'at)) (set! numlen (+ numlen 1))) (if (and (= format:fn-dot 0) (> width (+ digits 1))) (set! numlen (+ numlen 1))) (if (< numlen width) (format:out-fill (- width numlen) (integer->char padch))) (if (and overch (> numlen width)) (format:out-fill width (integer->char overch)) (format:fn-out modifier (> width (+ digits 1))))) (format:fn-out modifier #t))) (begin ; free precision (format:parse-float (if (string? number) number (number->string number)) #t scale) (format:fn-strip) (if width (let ((numlen (+ format:fn-len 1))) (if (or (not format:fn-pos?) (eq? modifier 'at)) (set! numlen (+ numlen 1))) (if (= format:fn-dot 0) (set! numlen (+ numlen 1))) (if (< numlen width) (format:out-fill (- width numlen) (integer->char padch))) (if (> numlen width) ; adjust precision if possible (let ((dot-index (- numlen (- format:fn-len format:fn-dot)))) (if (> dot-index width) (if overch ; numstr too big for required width (format:out-fill width (integer->char overch)) (format:fn-out modifier #t)) (begin (format:fn-round (- width dot-index)) (format:fn-out modifier #t)))) (format:fn-out modifier #t))) (format:fn-out modifier #t))))))) ;; format exponential flonums (~E) (define (format:out-expon modifier number pars) (if (not (or (number? number) (string? number))) (slib:error 'format "argument is not a number" number)) (let ((l (length pars))) (let ((width (format:par pars l 0 #f "width")) (digits (format:par pars l 1 #f "digits")) (edigits (format:par pars l 2 #f "exponent digits")) (scale (format:par pars l 3 1 #f)) (overch (format:par pars l 4 #f #f)) (padch (format:par pars l 5 format:space-ch #f)) (expch (format:par pars l 6 #f #f))) (if digits ; fixed precision (let ((digits (if (> scale 0) (if (< scale (+ digits 2)) (+ (- digits scale) 1) 0) digits))) (format:parse-float (if (string? number) number (number->string number)) #f scale) (if (<= (- format:fn-len format:fn-dot) digits) (format:fn-zfill #f (- digits (- format:fn-len format:fn-dot))) (format:fn-round digits)) (if width (if (and edigits overch (> format:en-len edigits)) (format:out-fill width (integer->char overch)) (let ((numlen (+ format:fn-len 3))) ; .E+ (if (or (not format:fn-pos?) (eq? modifier 'at)) (set! numlen (+ numlen 1))) (if (and (= format:fn-dot 0) (> width (+ digits 1))) (set! numlen (+ numlen 1))) (set! numlen (+ numlen (if (and edigits (>= edigits format:en-len)) edigits format:en-len))) (if (< numlen width) (format:out-fill (- width numlen) (integer->char padch))) (if (and overch (> numlen width)) (format:out-fill width (integer->char overch)) (begin (format:fn-out modifier (> width (- numlen 1))) (format:en-out edigits expch))))) (begin (format:fn-out modifier #t) (format:en-out edigits expch)))) (begin ; free precision (format:parse-float (if (string? number) number (number->string number)) #f scale) (format:fn-strip) (if width (if (and edigits overch (> format:en-len edigits)) (format:out-fill width (integer->char overch)) (let ((numlen (+ format:fn-len 3))) ; .E+ (if (or (not format:fn-pos?) (eq? modifier 'at)) (set! numlen (+ numlen 1))) (if (= format:fn-dot 0) (set! numlen (+ numlen 1))) (set! numlen (+ numlen (if (and edigits (>= edigits format:en-len)) edigits format:en-len))) (if (< numlen width) (format:out-fill (- width numlen) (integer->char padch))) (if (> numlen width) ; adjust precision if possible (let ((f (- format:fn-len format:fn-dot))) ; fract len (if (> (- numlen f) width) (if overch ; numstr too big for required width (format:out-fill width (integer->char overch)) (begin (format:fn-out modifier #t) (format:en-out edigits expch))) (begin (format:fn-round (+ (- f numlen) width)) (format:fn-out modifier #t) (format:en-out edigits expch)))) (begin (format:fn-out modifier #t) (format:en-out edigits expch))))) (begin (format:fn-out modifier #t) (format:en-out edigits expch)))))))) ;; format general flonums (~G) (define (format:out-general modifier number pars) (if (not (or (number? number) (string? number))) (slib:error 'format "argument is not a number or a number string" number)) (let ((l (length pars))) (let ((width (if (> l 0) (list-ref pars 0) #f)) (digits (if (> l 1) (list-ref pars 1) #f)) (edigits (if (> l 2) (list-ref pars 2) #f)) (overch (if (> l 4) (list-ref pars 4) #f)) (padch (if (> l 5) (list-ref pars 5) #f))) (format:parse-float (if (string? number) number (number->string number)) #t 0) (format:fn-strip) (let* ((ee (if edigits (+ edigits 2) 4)) ; for the following algorithm (ww (if width (- width ee) #f)) ; see Steele's CL book p.395 (n (if (= format:fn-dot 0) ; number less than (abs 1.0) ? (- (format:fn-zlead)) format:fn-dot)) (d (if digits digits (max format:fn-len (min n 7)))) ; q = format:fn-len (dd (- d n))) (if (<= 0 dd d) (begin (format:out-fixed modifier number (list ww dd #f overch padch)) (format:out-fill ee #\space)) ;~@T not implemented yet (format:out-expon modifier number pars)))))) ;; format dollar flonums (~$) (define (format:out-dollar modifier number pars) (if (not (or (number? number) (string? number))) (slib:error 'format "argument is not a number or a number string" number)) (let ((l (length pars))) (let ((digits (format:par pars l 0 2 "digits")) (mindig (format:par pars l 1 1 "mindig")) (width (format:par pars l 2 0 "width")) (padch (format:par pars l 3 format:space-ch #f))) (format:parse-float (if (string? number) number (number->string number)) #t 0) (if (<= (- format:fn-len format:fn-dot) digits) (format:fn-zfill #f (- digits (- format:fn-len format:fn-dot))) (format:fn-round digits)) (let ((numlen (+ format:fn-len 1))) (if (or (not format:fn-pos?) (memq modifier '(at colon-at))) (set! numlen (+ numlen 1))) (if (and mindig (> mindig format:fn-dot)) (set! numlen (+ numlen (- mindig format:fn-dot)))) (if (and (= format:fn-dot 0) (not mindig)) (set! numlen (+ numlen 1))) (if (< numlen width) (case modifier ((colon) (if (not format:fn-pos?) (format:out-char #\-)) (format:out-fill (- width numlen) (integer->char padch))) ((at) (format:out-fill (- width numlen) (integer->char padch)) (format:out-char (if format:fn-pos? #\+ #\-))) ((colon-at) (format:out-char (if format:fn-pos? #\+ #\-)) (format:out-fill (- width numlen) (integer->char padch))) (else (format:out-fill (- width numlen) (integer->char padch)) (if (not format:fn-pos?) (format:out-char #\-)))) (if format:fn-pos? (if (memq modifier '(at colon-at)) (format:out-char #\+)) (format:out-char #\-)))) (if (and mindig (> mindig format:fn-dot)) (format:out-fill (- mindig format:fn-dot) #\0)) (if (and (= format:fn-dot 0) (not mindig)) (format:out-char #\0)) (format:out-substr format:fn-str 0 format:fn-dot) (format:out-char #\.) (format:out-substr format:fn-str format:fn-dot format:fn-len)))) ; the flonum buffers (define format:fn-str (make-string format:fn-max)) ; number buffer (define format:fn-len 0) ; digit length of number (define format:fn-dot #f) ; dot position of number (define format:fn-pos? #t) ; number positive? (define format:en-str (make-string format:en-max)) ; exponent buffer (define format:en-len 0) ; digit length of exponent (define format:en-pos? #t) ; exponent positive? (define (format:parse-float num-str fixed? scale) (set! format:fn-pos? #t) (set! format:fn-len 0) (set! format:fn-dot #f) (set! format:en-pos? #t) (set! format:en-len 0) (do ((i 0 (+ i 1)) (left-zeros 0) (mantissa? #t) (all-zeros? #t) (num-len (string-length num-str)) (c #f)) ; current exam. character in num-str ((= i num-len) (if (not format:fn-dot) (set! format:fn-dot format:fn-len)) (if all-zeros? (begin (set! left-zeros 0) (set! format:fn-dot 0) (set! format:fn-len 1))) ;; now format the parsed values according to format's need (if fixed? (begin ; fixed format m.nnn or .nnn (if (and (> left-zeros 0) (> format:fn-dot 0)) (if (> format:fn-dot left-zeros) (begin ; norm 0{0}nn.mm to nn.mm (format:fn-shiftleft left-zeros) (set! left-zeros 0) (set! format:fn-dot (- format:fn-dot left-zeros))) (begin ; normalize 0{0}.nnn to .nnn (format:fn-shiftleft format:fn-dot) (set! left-zeros (- left-zeros format:fn-dot)) (set! format:fn-dot 0)))) (if (or (not (= scale 0)) (> format:en-len 0)) (let ((shift (+ scale (format:en-int)))) (cond (all-zeros? #t) ((> (+ format:fn-dot shift) format:fn-len) (format:fn-zfill #f (- shift (- format:fn-len format:fn-dot))) (set! format:fn-dot format:fn-len)) ((< (+ format:fn-dot shift) 0) (format:fn-zfill #t (- (- shift) format:fn-dot)) (set! format:fn-dot 0)) (else (if (> left-zeros 0) (if (<= left-zeros shift) ; shift always > 0 here (format:fn-shiftleft shift) ; shift out 0s (begin (format:fn-shiftleft left-zeros) (set! format:fn-dot (- shift left-zeros)))) (set! format:fn-dot (+ format:fn-dot shift)))))))) (let ((negexp ; expon format m.nnnEee (if (> left-zeros 0) (- left-zeros format:fn-dot -1) (if (= format:fn-dot 0) 1 0)))) (if (> left-zeros 0) (begin ; normalize 0{0}.nnn to n.nn (format:fn-shiftleft left-zeros) (set! format:fn-dot 1)) (if (= format:fn-dot 0) (set! format:fn-dot 1))) (format:en-set (- (+ (- format:fn-dot scale) (format:en-int)) negexp)) (cond (all-zeros? (format:en-set 0) (set! format:fn-dot 1)) ((< scale 0) ; leading zero (format:fn-zfill #t (- scale)) (set! format:fn-dot 0)) ((> scale format:fn-dot) (format:fn-zfill #f (- scale format:fn-dot)) (set! format:fn-dot scale)) (else (set! format:fn-dot scale))))) #t) ;; do body (set! c (string-ref num-str i)) ; parse the output of number->string (cond ; which can be any valid number ((char-numeric? c) ; representation of R4RS except (if mantissa? ; complex numbers (begin (if (char=? c #\0) (if all-zeros? (set! left-zeros (+ left-zeros 1))) (begin (set! all-zeros? #f))) (string-set! format:fn-str format:fn-len c) (set! format:fn-len (+ format:fn-len 1))) (begin (string-set! format:en-str format:en-len c) (set! format:en-len (+ format:en-len 1))))) ((or (char=? c #\-) (char=? c #\+)) (if mantissa? (set! format:fn-pos? (char=? c #\+)) (set! format:en-pos? (char=? c #\+)))) ((char=? c #\.) (set! format:fn-dot format:fn-len)) ((char=? c #\e) (set! mantissa? #f)) ((char=? c #\E) (set! mantissa? #f)) ((char-whitespace? c) #t) ((char=? c #\d) #t) ; decimal radix prefix ((char=? c #\#) #t) (else (slib:error 'format "illegal character in number->string" c))))) (define (format:en-int) ; convert exponent string to integer (if (= format:en-len 0) 0 (do ((i 0 (+ i 1)) (n 0)) ((= i format:en-len) (if format:en-pos? n (- n))) (set! n (+ (* n 10) (- (char->integer (string-ref format:en-str i)) format:zero-ch)))))) (define (format:en-set en) ; set exponent string number (set! format:en-len 0) (set! format:en-pos? (>= en 0)) (let ((en-str (number->string en))) (do ((i 0 (+ i 1)) (en-len (string-length en-str)) (c #f)) ((= i en-len)) (set! c (string-ref en-str i)) (if (char-numeric? c) (begin (string-set! format:en-str format:en-len c) (set! format:en-len (+ format:en-len 1))))))) (define (format:fn-zfill left? n) ; fill current number string with 0s (if (> (+ n format:fn-len) format:fn-max) ; from the left or right (slib:error 'format "number is too long to format (enlarge format:fn-max)")) (set! format:fn-len (+ format:fn-len n)) (if left? (do ((i format:fn-len (- i 1))) ; fill n 0s to left ((< i 0)) (string-set! format:fn-str i (if (< i n) #\0 (string-ref format:fn-str (- i n))))) (do ((i (- format:fn-len n) (+ i 1))) ; fill n 0s to the right ((= i format:fn-len)) (string-set! format:fn-str i #\0)))) (define (format:fn-shiftleft n) ; shift left current number n positions (if (> n format:fn-len) (slib:error 'format "internal error in format:fn-shiftleft" (list n format:fn-len))) (do ((i n (+ i 1))) ((= i format:fn-len) (set! format:fn-len (- format:fn-len n))) (string-set! format:fn-str (- i n) (string-ref format:fn-str i)))) (define (format:fn-round digits) ; round format:fn-str (set! digits (+ digits format:fn-dot)) (do ((i digits (- i 1)) ; "099",2 -> "10" (c 5)) ; "023",2 -> "02" ((or (= c 0) (< i 0)) ; "999",2 -> "100" (if (= c 1) ; "005",2 -> "01" (begin ; carry overflow (set! format:fn-len digits) (format:fn-zfill #t 1) ; add a 1 before fn-str (string-set! format:fn-str 0 #\1) (set! format:fn-dot (+ format:fn-dot 1))) (set! format:fn-len digits))) (set! c (+ (- (char->integer (string-ref format:fn-str i)) format:zero-ch) c)) (string-set! format:fn-str i (integer->char (if (< c 10) (+ c format:zero-ch) (+ (- c 10) format:zero-ch)))) (set! c (if (< c 10) 0 1)))) (define (format:fn-out modifier add-leading-zero?) (if format:fn-pos? (if (eq? modifier 'at) (format:out-char #\+)) (format:out-char #\-)) (if (= format:fn-dot 0) (if add-leading-zero? (format:out-char #\0)) (format:out-substr format:fn-str 0 format:fn-dot)) (format:out-char #\.) (format:out-substr format:fn-str format:fn-dot format:fn-len)) (define (format:en-out edigits expch) (format:out-char (if expch (integer->char expch) format:expch)) (format:out-char (if format:en-pos? #\+ #\-)) (if edigits (if (< format:en-len edigits) (format:out-fill (- edigits format:en-len) #\0))) (format:out-substr format:en-str 0 format:en-len)) (define (format:fn-strip) ; strip trailing zeros but one (string-set! format:fn-str format:fn-len #\0) (do ((i format:fn-len (- i 1))) ((or (not (char=? (string-ref format:fn-str i) #\0)) (<= i format:fn-dot)) (set! format:fn-len (+ i 1))))) (define (format:fn-zlead) ; count leading zeros (do ((i 0 (+ i 1))) ((or (= i format:fn-len) (not (char=? (string-ref format:fn-str i) #\0))) (if (= i format:fn-len) ; found a real zero 0 i)))) (define (format:format-work format-string arglist) ; does the formatting work (letrec ((format-string-len (string-length format-string)) (arg-pos 0) ; argument position in arglist (arg-len (length arglist)) ; number of arguments (modifier #f) ; 'colon | 'at | 'colon-at | #f (params '()) ; directive parameter list (param-value-found #f) ; a directive parameter value found (conditional-nest 0) ; conditional nesting level (clause-pos 0) ; last cond. clause beginning char pos (clause-default #f) ; conditional default clause string (clauses '()) ; conditional clause string list (conditional-type #f) ; reflects the contional modifiers (conditional-arg #f) ; argument to apply the conditional (iteration-nest 0) ; iteration nesting level (iteration-pos 0) ; iteration string beginning char pos (iteration-type #f) ; reflects the iteration modifiers (max-iterations #f) ; maximum number of iterations (recursive-pos-save format:pos) (next-char ; gets the next char from format-string (lambda () (let ((ch (peek-next-char))) (set! format:pos (+ 1 format:pos)) ch))) (peek-next-char (lambda () (if (>= format:pos format-string-len) (slib:error 'format "illegal format string") (string-ref format-string format:pos)))) (one-positive-integer? (lambda (params) (cond ((null? params) #f) ((and (integer? (car params)) (>= (car params) 0) (= (length params) 1)) #t) (else (slib:error 'format "one positive integer parameter expected"))))) (next-arg (lambda () (if (>= arg-pos arg-len) (begin (slib:error 'format "missing argument(s)"))) (add-arg-pos 1) (list-ref arglist (- arg-pos 1)))) (prev-arg (lambda () (add-arg-pos -1) (if (negative? arg-pos) (slib:error 'format "missing backward argument(s)")) (list-ref arglist arg-pos))) (rest-args (lambda () (let loop ((l arglist) (k arg-pos)) ; list-tail definition (if (= k 0) l (loop (cdr l) (- k 1)))))) (add-arg-pos (lambda (n) (set! arg-pos (+ n arg-pos)))) (anychar-dispatch ; dispatches the format-string (lambda () (if (>= format:pos format-string-len) arg-pos ; used for ~? continuance (let ((char (next-char))) (cond ((char=? char #\~) (set! modifier #f) (set! params '()) (set! param-value-found #f) (tilde-dispatch)) (else (if (and (zero? conditional-nest) (zero? iteration-nest)) (format:out-char char)) (anychar-dispatch))))))) (tilde-dispatch (lambda () (cond ((>= format:pos format-string-len) (format:out-str "~") ; tilde at end of string is just output arg-pos) ; used for ~? continuance ((and (or (zero? conditional-nest) (memv (peek-next-char) ; find conditional directives (append '(#\[ #\] #\; #\: #\@ #\^) format:parameter-characters))) (or (zero? iteration-nest) (memv (peek-next-char) ; find iteration directives (append '(#\{ #\} #\: #\@ #\^) format:parameter-characters)))) (case (char-upcase (next-char)) ;; format directives ((#\A) ; Any -- for humans (format:out-obj-padded (memq modifier '(at colon-at)) (next-arg) #f params (memq modifier '(colon colon-at))) (anychar-dispatch)) ((#\S) ; Slashified -- for parsers (format:out-obj-padded (memq modifier '(at colon-at)) (next-arg) #t params (memq modifier '(colon colon-at))) (anychar-dispatch)) ((#\D) ; Decimal (format:out-num-padded modifier (next-arg) params 10) (anychar-dispatch)) ((#\X) ; Hexadecimal (format:out-num-padded modifier (next-arg) params 16) (anychar-dispatch)) ((#\O) ; Octal (format:out-num-padded modifier (next-arg) params 8) (anychar-dispatch)) ((#\B) ; Binary (format:out-num-padded modifier (next-arg) params 2) (anychar-dispatch)) ((#\R) (if (null? params) (format:out-obj-padded ; Roman, cardinal, ordinal numerals #f ((case modifier ((at) format:num->roman) ((colon-at) format:num->old-roman) ((colon) format:num->ordinal) (else format:num->cardinal)) (next-arg)) #f params #f) ;was format:read-proof (format:out-num-padded ; any Radix modifier (next-arg) (cdr params) (car params))) (anychar-dispatch)) ((#\F) ; Fixed-format floating-point (if format:floats (format:out-fixed modifier (next-arg) params) (format:out-str (number->string (next-arg)))) (anychar-dispatch)) ((#\E) ; Exponential floating-point (if format:floats (format:out-expon modifier (next-arg) params) (format:out-str (number->string (next-arg)))) (anychar-dispatch)) ((#\G) ; General floating-point (if format:floats (format:out-general modifier (next-arg) params) (format:out-str (number->string (next-arg)))) (anychar-dispatch)) ((#\$) ; Dollars floating-point (if format:floats (format:out-dollar modifier (next-arg) params) (format:out-str (number->string (next-arg)))) (anychar-dispatch)) ((#\I) ; Complex numbers (if (not format:complex-numbers) (slib:error 'format "complex numbers not supported by this scheme system")) (let ((z (next-arg))) (if (not (complex? z)) (slib:error 'format "argument not a complex number")) (format:out-fixed modifier (real-part z) params) (format:out-fixed 'at (imag-part z) params) (format:out-char #\i)) (anychar-dispatch)) ((#\C) ; Character (let ((ch (if (one-positive-integer? params) (integer->char (car params)) (next-arg)))) (if (not (char? ch)) (slib:error 'format "~~c expects a character" ch)) (case modifier ((at) (format:out-str (format:char->str ch))) ((colon) (let ((c (char->integer ch))) (if (< c 0) (set! c (+ c 256))) ; compensate complement impl. (cond ((< c #x20) ; assumes that control chars are < #x20 (format:out-char #\^) (format:out-char (integer->char (+ c #x40)))) ((>= c #x7f) (format:out-str "#\\") (format:out-str (if format:radix-pref (let ((s (number->string c 8))) (substring s 2 (string-length s))) (number->string c 8)))) (else (format:out-char ch))))) (else (format:out-char ch)))) (anychar-dispatch)) ((#\P) ; Plural (if (memq modifier '(colon colon-at)) (prev-arg)) (let ((arg (next-arg))) (if (not (number? arg)) (slib:error 'format "~~p expects a number argument" arg)) (if (= arg 1) (if (memq modifier '(at colon-at)) (format:out-char #\y)) (if (memq modifier '(at colon-at)) (format:out-str "ies") (format:out-char #\s)))) (anychar-dispatch)) ((#\~) ; Tilde (if (one-positive-integer? params) (format:out-fill (car params) #\~) (format:out-char #\~)) (anychar-dispatch)) ((#\%) ; Newline (if (one-positive-integer? params) (format:out-fill (car params) #\newline) (format:out-char #\newline)) (set! format:output-col 0) (anychar-dispatch)) ((#\&) ; Fresh line (if (one-positive-integer? params) (begin (if (> (car params) 0) (format:out-fill (- (car params) (if (> format:output-col 0) 0 1)) #\newline)) (set! format:output-col 0)) (if (> format:output-col 0) (format:out-char #\newline))) (anychar-dispatch)) ((#\_) ; Space character (if (one-positive-integer? params) (format:out-fill (car params) #\space) (format:out-char #\space)) (anychar-dispatch)) ((#\/) ; Tabulator character (if (one-positive-integer? params) (format:out-fill (car params) slib:tab) (format:out-char slib:tab)) (anychar-dispatch)) ((#\|) ; Page seperator (if (one-positive-integer? params) (format:out-fill (car params) slib:form-feed) (format:out-char slib:form-feed)) (set! format:output-col 0) (anychar-dispatch)) ((#\T) ; Tabulate (format:tabulate modifier params) (anychar-dispatch)) ((#\Y) ; Pretty-print (require 'pretty-print) (pretty-print (next-arg) format:port) (set! format:output-col 0) (anychar-dispatch)) ((#\? #\K) ; Indirection (is "~K" in T-Scheme) (cond ((memq modifier '(colon colon-at)) (slib:error 'format "illegal modifier in ~~?" modifier)) ((eq? modifier 'at) (let* ((frmt (next-arg)) (args (rest-args))) (add-arg-pos (format:format-work frmt args)))) (else (let* ((frmt (next-arg)) (args (next-arg))) (format:format-work frmt args)))) (anychar-dispatch)) ((#\!) ; Flush output (set! format:flush-output #t) (anychar-dispatch)) ((#\newline) ; Continuation lines (if (eq? modifier 'at) (format:out-char #\newline)) (if (< format:pos format-string-len) (do ((ch (peek-next-char) (peek-next-char))) ((or (not (char-whitespace? ch)) (= format:pos (- format-string-len 1)))) (if (eq? modifier 'colon) (format:out-char (next-char)) (next-char)))) (anychar-dispatch)) ((#\*) ; Argument jumping (case modifier ((colon) ; jump backwards (if (one-positive-integer? params) (do ((i 0 (+ i 1))) ((= i (car params))) (prev-arg)) (prev-arg))) ((at) ; jump absolute (set! arg-pos (if (one-positive-integer? params) (car params) 0))) ((colon-at) (slib:error 'format "illegal modifier `:@' in ~~* directive")) (else ; jump forward (if (one-positive-integer? params) (do ((i 0 (+ i 1))) ((= i (car params))) (next-arg)) (next-arg)))) (anychar-dispatch)) ((#\() ; Case conversion begin (set! format:case-conversion (case modifier ((at) format:string-capitalize-first) ((colon) string-capitalize) ((colon-at) string-upcase) (else string-downcase))) (anychar-dispatch)) ((#\)) ; Case conversion end (if (not format:case-conversion) (slib:error 'format "missing ~~(")) (set! format:case-conversion #f) (anychar-dispatch)) ((#\[) ; Conditional begin (set! conditional-nest (+ conditional-nest 1)) (cond ((= conditional-nest 1) (set! clause-pos format:pos) (set! clause-default #f) (set! clauses '()) (set! conditional-type (case modifier ((at) 'if-then) ((colon) 'if-else-then) ((colon-at) (slib:error 'format "illegal modifier in ~~[")) (else 'num-case))) (set! conditional-arg (if (one-positive-integer? params) (car params) (next-arg))))) (anychar-dispatch)) ((#\;) ; Conditional separator (if (zero? conditional-nest) (slib:error 'format "~~; not in ~~[~~] conditional")) (if (not (null? params)) (slib:error 'format "no parameter allowed in ~~;")) (if (= conditional-nest 1) (let ((clause-str (cond ((eq? modifier 'colon) (set! clause-default #t) (substring format-string clause-pos (- format:pos 3))) ((memq modifier '(at colon-at)) (slib:error 'format "illegal modifier in ~~;")) (else (substring format-string clause-pos (- format:pos 2)))))) (set! clauses (append clauses (list clause-str))) (set! clause-pos format:pos))) (anychar-dispatch)) ((#\]) ; Conditional end (if (zero? conditional-nest) (slib:error 'format "missing ~~[")) (set! conditional-nest (- conditional-nest 1)) (if modifier (slib:error 'format "no modifier allowed in ~~]")) (if (not (null? params)) (slib:error 'format "no parameter allowed in ~~]")) (cond ((zero? conditional-nest) (let ((clause-str (substring format-string clause-pos (- format:pos 2)))) (if clause-default (set! clause-default clause-str) (set! clauses (append clauses (list clause-str))))) (case conditional-type ((if-then) (if conditional-arg (format:format-work (car clauses) (list conditional-arg)))) ((if-else-then) (add-arg-pos (format:format-work (if conditional-arg (cadr clauses) (car clauses)) (rest-args)))) ((num-case) (if (or (not (integer? conditional-arg)) (< conditional-arg 0)) (slib:error 'format "argument not a positive integer")) (if (not (and (>= conditional-arg (length clauses)) (not clause-default))) (add-arg-pos (format:format-work (if (>= conditional-arg (length clauses)) clause-default (list-ref clauses conditional-arg)) (rest-args)))))))) (anychar-dispatch)) ((#\{) ; Iteration begin (set! iteration-nest (+ iteration-nest 1)) (cond ((= iteration-nest 1) (set! iteration-pos format:pos) (set! iteration-type (case modifier ((at) 'rest-args) ((colon) 'sublists) ((colon-at) 'rest-sublists) (else 'list))) (set! max-iterations (if (one-positive-integer? params) (car params) #f)))) (anychar-dispatch)) ((#\}) ; Iteration end (if (zero? iteration-nest) (slib:error 'format "missing ~~{")) (set! iteration-nest (- iteration-nest 1)) (case modifier ((colon) (if (not max-iterations) (set! max-iterations 1))) ((colon-at at) (slib:error 'format "illegal modifier" modifier)) (else (if (not max-iterations) (set! max-iterations format:max-iterations)))) (if (not (null? params)) (slib:error 'format "no parameters allowed in ~~}" params)) (if (zero? iteration-nest) (let ((iteration-str (substring format-string iteration-pos (- format:pos (if modifier 3 2))))) (if (string=? iteration-str "") (set! iteration-str (next-arg))) (case iteration-type ((list) (let ((args (next-arg)) (args-len 0)) (if (not (list? args)) (slib:error 'format "expected a list argument" args)) (set! args-len (length args)) (do ((arg-pos 0 (+ arg-pos (format:format-work iteration-str (list-tail args arg-pos)))) (i 0 (+ i 1))) ((or (>= arg-pos args-len) (and format:iteration-bounded (>= i max-iterations))))))) ((sublists) (let ((args (next-arg)) (args-len 0)) (if (not (list? args)) (slib:error 'format "expected a list argument" args)) (set! args-len (length args)) (do ((arg-pos 0 (+ arg-pos 1))) ((or (>= arg-pos args-len) (and format:iteration-bounded (>= arg-pos max-iterations)))) (let ((sublist (list-ref args arg-pos))) (if (not (list? sublist)) (slib:error 'format "expected a list of lists argument" args)) (format:format-work iteration-str sublist))))) ((rest-args) (let* ((args (rest-args)) (args-len (length args)) (usedup-args (do ((arg-pos 0 (+ arg-pos (format:format-work iteration-str (list-tail args arg-pos)))) (i 0 (+ i 1))) ((or (>= arg-pos args-len) (and format:iteration-bounded (>= i max-iterations))) arg-pos)))) (add-arg-pos usedup-args))) ((rest-sublists) (let* ((args (rest-args)) (args-len (length args)) (usedup-args (do ((arg-pos 0 (+ arg-pos 1))) ((or (>= arg-pos args-len) (and format:iteration-bounded (>= arg-pos max-iterations))) arg-pos) (let ((sublist (list-ref args arg-pos))) (if (not (list? sublist)) (slib:error 'format "expected list arguments" args)) (format:format-work iteration-str sublist))))) (add-arg-pos usedup-args))) (else (slib:error 'format "internal error in ~~}"))))) (anychar-dispatch)) ((#\^) ; Up and out (let* ((continue (cond ((not (null? params)) (not (case (length params) ((1) (zero? (car params))) ((2) (= (list-ref params 0) (list-ref params 1))) ((3) (<= (list-ref params 0) (list-ref params 1) (list-ref params 2))) (else (slib:error 'format "too many parameters"))))) (format:case-conversion ; if conversion stop conversion (set! format:case-conversion string-copy) #t) ((= iteration-nest 1) #t) ((= conditional-nest 1) #t) ((>= arg-pos arg-len) (set! format:pos format-string-len) #f) (else #t)))) (if continue (anychar-dispatch)))) ;; format directive modifiers and parameters ((#\@) ; `@' modifier (if (memq modifier '(at colon-at)) (slib:error 'format "double `@' modifier")) (set! modifier (if (eq? modifier 'colon) 'colon-at 'at)) (tilde-dispatch)) ((#\:) ; `:' modifier (if (memq modifier '(colon colon-at)) (slib:error 'format "double `:' modifier")) (set! modifier (if (eq? modifier 'at) 'colon-at 'colon)) (tilde-dispatch)) ((#\') ; Character parameter (if modifier (slib:error 'format "misplaced modifier" modifier)) (set! params (append params (list (char->integer (next-char))))) (set! param-value-found #t) (tilde-dispatch)) ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\- #\+) ; num. paramtr (if modifier (slib:error 'format "misplaced modifier" modifier)) (let ((num-str-beg (- format:pos 1)) (num-str-end format:pos)) (do ((ch (peek-next-char) (peek-next-char))) ((not (char-numeric? ch))) (next-char) (set! num-str-end (+ 1 num-str-end))) (set! params (append params (list (string->number (substring format-string num-str-beg num-str-end)))))) (set! param-value-found #t) (tilde-dispatch)) ((#\V) ; Variable parameter from next argum. (if modifier (slib:error 'format "misplaced modifier" modifier)) (set! params (append params (list (next-arg)))) (set! param-value-found #t) (tilde-dispatch)) ((#\#) ; Parameter is number of remaining args (if modifier (slib:error 'format "misplaced modifier" modifier)) (set! params (append params (list (length (rest-args))))) (set! param-value-found #t) (tilde-dispatch)) ((#\,) ; Parameter separators (if modifier (slib:error 'format "misplaced modifier" modifier)) (if (not param-value-found) (set! params (append params '(#f)))) ; append empty paramtr (set! param-value-found #f) (tilde-dispatch)) ((#\Q) ; Inquiry messages (if (eq? modifier 'colon) (format:out-str format:version) (let ((nl (string #\newline))) (format:out-str (string-append "SLIB Common LISP format version " format:version nl " This code is in the public domain." nl " Please send bug reports to `lutzeb@cs.tu-berlin.de'" nl)))) (anychar-dispatch)) (else ; Unknown tilde directive (slib:error 'format "unknown control character" (string-ref format-string (- format:pos 1)))))) (else (anychar-dispatch)))))) ; in case of conditional (set! format:pos 0) (anychar-dispatch) ; start the formatting (set! format:pos recursive-pos-save) arg-pos)) (define (format:out fmt args) ; the output handler for a port ;;(set! format:case-conversion #f) ; modifier case conversion procedure ;;(set! format:flush-output #f) ; ~! reset (let ((arg-pos (format:format-work fmt args)) (arg-len (length args))) (cond ((< arg-pos arg-len) (set! format:pos (string-length fmt)) (slib:error 'format (- arg-len arg-pos) "superfluous arguments")) ((> arg-pos arg-len) (slib:error 'format (- arg-pos arg-len) "missing arguments"))))) ;;(set! format:pos 0) (if (< (length args) 1) (slib:error 'format "not enough arguments")) ;; If the first argument is a string, then that's the format string. ;; (Scheme->C) ;; In this case, put the argument list in canonical form. (let ((args (if (string? (car args)) (cons #f args) args))) (let ((destination (car args)) (arglist (cdr args))) (cond ((or (and (boolean? destination) ; port output destination) (output-port? destination) (number? destination)) (let ((port (cond ((boolean? destination) (current-output-port)) ((output-port? destination) destination) ((number? destination) (current-error-port))))) (set! format:port port) ; global port for output routines (set! format:output-col (format:get-port-column port)) (format:out (car arglist) (cdr arglist)) (format:set-port-column! port format:output-col) (if format:flush-output (force-output format:port)) #t)) ((and (boolean? destination) ; string output (not destination)) (call-with-output-string (lambda (port) (set! format:port port) (format:out (car arglist) (cdr arglist))))) (else (slib:error 'format "illegal destination" destination)))))) ;; format:obj->str returns a R4RS representation as a string of an ;; arbitrary scheme object. ;; First parameter is the object, second parameter is a boolean if ;; the representation should be slashified as `write' does. ;; It uses format:char->str which converts a character into a ;; slashified string as `write' does and which is implementation ;; dependent. ;; It uses format:iobj->str to print out internal objects as quoted ;; strings so that the output can always be processed by (read) ;; If format:read-proof is set to #t the resulting string is ;; additionally set into string quotes. (define (format:obj->str obj slashify format:read-proof) (cond ((string? obj) (if slashify (let ((obj-len (string-length obj))) (string-append "\"" (let loop ((i 0) (j 0)) ; taken from Marc Feeley's pp.scm (if (= j obj-len) (string-append (substring obj i j) "\"") (let ((c (string-ref obj j))) (if (or (char=? c #\\) (char=? c #\")) (string-append (substring obj i j) "\\" (loop j (+ j 1))) (loop i (+ j 1)))))))) obj)) ((boolean? obj) (if obj "#t" "#f")) ((number? obj) (number->string obj)) ((symbol? obj) (if format:symbol-case-conv (format:symbol-case-conv (symbol->string obj)) (symbol->string obj))) ((char? obj) (if slashify (format:char->str obj) (string obj))) ((null? obj) "()") ((input-port? obj) (format:iobj->str obj format:read-proof)) ((output-port? obj) (format:iobj->str obj format:read-proof)) ((list? obj) (string-append "(" (let loop ((obj-list obj)) (if (null? (cdr obj-list)) (format:obj->str (car obj-list) #t format:read-proof) (string-append (format:obj->str (car obj-list) #t format:read-proof) " " (loop (cdr obj-list))))) ")")) ((pair? obj) (string-append "(" (format:obj->str (car obj) #t format:read-proof) " . " (format:obj->str (cdr obj) #t format:read-proof) ")")) ((vector? obj) (string-append "#" (format:obj->str (vector->list obj) #t format:read-proof))) (else ; only objects with an #<...> (format:iobj->str obj format:read-proof)))) ; representation should fall in here ;; format:iobj->str reveals the implementation dependent ;; representation of #<...> objects with the use of display and ;; call-with-output-string. ;; If format:read-proof is set to #t the resulting string is ;; additionally set into string quotes. (define (format:iobj->str iobj format:read-proof) (if (or format:read-proof format:iobj-case-conv) (string-append (if format:read-proof "\"" "") (if format:iobj-case-conv (format:iobj-case-conv (call-with-output-string (lambda (p) (display iobj p)))) (call-with-output-string (lambda (p) (display iobj p)))) (if format:read-proof "\"" "")) (call-with-output-string (lambda (p) (display iobj p))))) (define (format:par pars length index default name) (if (> length index) (let ((par (list-ref pars index))) (if par (if name (if (< par 0) (slib:error name "parameter must be a positive integer") par) par) default)) default)) ;; format:char->str converts a character into a slashified string as ;; done by `write'. The procedure is dependent on the integer ;; representation of characters and assumes a character number ;; according to the ASCII character set. (define (format:char->str ch) (let ((int-rep (char->integer ch))) (if (< int-rep 0) ; if chars are [-128...+127] (set! int-rep (+ int-rep 256))) (string-append "#\\" (cond ((char=? ch #\newline) "newline") ((and (>= int-rep 0) (<= int-rep 32)) (vector-ref format:ascii-non-printable-charnames int-rep)) ((= int-rep 127) "del") ((>= int-rep 128) ; octal representation (if format:radix-pref (let ((s (number->string int-rep 8))) (substring s 2 (string-length s))) (number->string int-rep 8))) (else (string ch)))))) ;;; We should keep separate track of columns for each port, but ;;; keeping pointers to ports will foil GC. Instead, keep ;;; associations indexed by the DISPLAYed representation of the ports. (define *port-columns* '()) (define (format:get-port-column port) (define pair (assoc (call-with-output-string (lambda (sport) (display port sport))) *port-columns*)) (if pair (cdr pair) 0)) (define (format:set-port-column! port col) (define pname (call-with-output-string (lambda (sport) (display port sport)))) (let ((pair (assoc pname *port-columns*))) (if pair (set-cdr! pair col) (set! *port-columns* (cons (cons pname col) *port-columns*))))) ;;; some global functions not found in SLIB (define (format:string-capitalize-first str) ; "hello" -> "Hello" (let ((cap-str (string-copy str)) ; "hELLO" -> "Hello" (non-first-alpha #f) ; "*hello" -> "*Hello" (str-len (string-length str))) ; "hello you" -> "Hello you" (do ((i 0 (+ i 1))) ((= i str-len) cap-str) (let ((c (string-ref str i))) (if (char-alphabetic? c) (if non-first-alpha (string-set! cap-str i (char-downcase c)) (begin (set! non-first-alpha #t) (string-set! cap-str i (char-upcase c))))))))) slib-3b1/formatst.scm0000644001705200017500000005347710111772033012546 0ustar tbtb;; "formatst.scm" SLIB FORMAT Version 3.0 conformance test ; Written by Dirk Lutzebaeck (lutzeb@cs.tu-berlin.de) ; ; This code is in the public domain. ;; Test run: (slib:load "formatst") ; Failure reports for various scheme interpreters: ; ; SCM4d ; None. ; Elk 2.2: ; None. ; MIT C-Scheme 7.1: ; The empty list is always evaluated as a boolean and consequently ; represented as `#f'. ; Scheme->C 01nov91: ; None, if format:symbol-case-conv and format:iobj-case-conv are set ; to string-downcase. (require 'format) (if (not (string=? format:version "3.1")) (begin (display "You have format version ") (display format:version) (display ". This test is for format version 3.0!") (newline) (format:abort))) (define fails 0) (define total 0) (define test-verbose #f) ; shows each test performed (define (test format-args out-str) (set! total (+ total 1)) (if (not test-verbose) (if (zero? (modulo total 10)) (begin (display total) (display ",") (force-output (current-output-port))))) (let ((format-out (apply format `(#f ,@format-args)))) (if (string=? out-str format-out) (if test-verbose (begin (display "Verified ") (write format-args) (display " returns ") (write out-str) (newline))) (begin (set! fails (+ fails 1)) (if (not test-verbose) (newline)) (display "*Failed* ") (write format-args) (newline) (display " returns ") (write format-out) (newline) (display " expected ") (write out-str) (newline))))) ; ensure format default configuration ;;(set! format:symbol-case-conv #f) ;;(set! format:iobj-case-conv #f) ;;(set! format:iteration-bounded #t) ;;(set! format:max-iterations 100) (format #t "~q") (format #t "This implementation has~@[ no~] flonums ~ ~:[but no~;and~] complex numbers~%" (not format:floats) format:complex-numbers) ; any object test (test '("abc") "abc") (test '("~a" 10) "10") (test '("~a" -1.2) "-1.2") (test '("~a" a) "a") (test '("~a" #t) "#t") (test '("~a" #f) "#f") (test '("~a" "abc") "abc") (test '("~a" #(1 2 3)) "#(1 2 3)") (test '("~a" ()) "()") (test '("~a" (a)) "(a)") (test '("~a" (a b)) "(a b)") (test '("~a" (a (b c) d)) "(a (b c) d)") (test '("~a" (a . b)) "(a . b)") (test '("~a" (a (b c . d))) "(a (b . (c . d)))") ; this is ugly (test `("~a" ,display) (format:iobj->str display #f)) (test `("~a" ,(current-input-port)) (format:iobj->str (current-input-port) #f)) (test `("~a" ,(current-output-port)) (format:iobj->str (current-output-port) #f)) ; # argument test (test '("~a ~a" 10 20) "10 20") (test '("~a abc ~a def" 10 20) "10 abc 20 def") ; numerical test (test '("~d" 100) "100") (test '("~x" 100) "64") (test '("~o" 100) "144") (test '("~b" 100) "1100100") (test '("~@d" 100) "+100") (test '("~@d" -100) "-100") (test '("~@x" 100) "+64") (test '("~@o" 100) "+144") (test '("~@b" 100) "+1100100") (test '("~10d" 100) " 100") (test '("~:d" 123) "123") (test '("~:d" 1234) "1,234") (test '("~:d" 12345) "12,345") (test '("~:d" 123456) "123,456") (test '("~:d" 12345678) "12,345,678") (test '("~:d" -123) "-123") (test '("~:d" -1234) "-1,234") (test '("~:d" -12345) "-12,345") (test '("~:d" -123456) "-123,456") (test '("~:d" -12345678) "-12,345,678") (test '("~10:d" 1234) " 1,234") (test '("~10:d" -1234) " -1,234") (test '("~10,'*d" 100) "*******100") (test '("~10,,'|:d" 12345678) "12|345|678") (test '("~10,,,2:d" 12345678) "12,34,56,78") (test '("~14,'*,'|,4:@d" 12345678) "****+1234|5678") (test '("~10r" 100) "100") (test '("~2r" 100) "1100100") (test '("~8r" 100) "144") (test '("~16r" 100) "64") (test '("~16,10,'*r" 100) "********64") ; roman numeral test (test '("~@r" 4) "IV") (test '("~@r" 19) "XIX") (test '("~@r" 50) "L") (test '("~@r" 100) "C") (test '("~@r" 1000) "M") (test '("~@r" 99) "XCIX") (test '("~@r" 1994) "MCMXCIV") ; old roman numeral test (test '("~:@r" 4) "IIII") (test '("~:@r" 5) "V") (test '("~:@r" 10) "X") (test '("~:@r" 9) "VIIII") ; cardinal/ordinal English number test (test '("~r" 4) "four") (test '("~r" 10) "ten") (test '("~r" 19) "nineteen") (test '("~r" 1984) "one thousand, nine hundred eighty-four") (test '("~:r" -1984) "minus one thousand, nine hundred eighty-fourth") ; character test (test '("~c" #\a) "a") (test '("~@c" #\a) "#\\a") (test `("~@c" ,(integer->char 32)) "#\\space") (test `("~@c" ,(integer->char 0)) "#\\nul") (test `("~@c" ,(integer->char 27)) "#\\esc") (test `("~@c" ,(integer->char 127)) "#\\del") (test `("~@c" ,(integer->char 128)) "#\\200") (test `("~@c" ,(integer->char 255)) "#\\377") (test '("~65c") "A") (test '("~7@c") "#\\bel") (test '("~:c" #\a) "a") (test `("~:c" ,(integer->char 1)) "^A") (test `("~:c" ,(integer->char 27)) "^[") (test '("~7:c") "^G") (test `("~:c" ,(integer->char 128)) "#\\200") (test `("~:c" ,(integer->char 127)) "#\\177") (test `("~:c" ,(integer->char 255)) "#\\377") ; plural test (test '("test~p" 1) "test") (test '("test~p" 2) "tests") (test '("test~p" 0) "tests") (test '("tr~@p" 1) "try") (test '("tr~@p" 2) "tries") (test '("tr~@p" 0) "tries") (test '("~a test~:p" 10) "10 tests") (test '("~a test~:p" 1) "1 test") ; tilde test (test '("~~~~") "~~") (test '("~3~") "~~~") ; whitespace character test (test '("~%") " ") (test '("~3%") " ") (test '("~&") "") (test '("abc~&") "abc ") (test '("abc~&def") "abc def") (test '("~&") " ") (test '("~3&") " ") (test '("abc~3&") "abc ") (test '("~|") (string slib:form-feed)) (test '("~_~_~_") " ") (test '("~3_") " ") (test '("~/") (string slib:tab)) (test '("~3/") (make-string 3 slib:tab)) ; tabulate test (test '("~0&~3t") " ") (test '("~0&~10t") " ") (test '("~10t") "") (test '("~0&1234567890~,8tABC") "1234567890 ABC") (test '("~0&1234567890~0,8tABC") "1234567890 ABC") (test '("~0&1234567890~1,8tABC") "1234567890 ABC") (test '("~0&1234567890~2,8tABC") "1234567890ABC") (test '("~0&1234567890~3,8tABC") "1234567890 ABC") (test '("~0&1234567890~4,8tABC") "1234567890 ABC") (test '("~0&1234567890~5,8tABC") "1234567890 ABC") (test '("~0&1234567890~6,8tABC") "1234567890 ABC") (test '("~0&1234567890~7,8tABC") "1234567890 ABC") (test '("~0&1234567890~8,8tABC") "1234567890 ABC") (test '("~0&1234567890~9,8tABC") "1234567890 ABC") (test '("~0&1234567890~10,8tABC") "1234567890ABC") (test '("~0&1234567890~11,8tABC") "1234567890 ABC") (test '("~0&12345~,8tABCDE~,8tXYZ") "12345 ABCDE XYZ") (test '("~,8t+++~,8t===") " +++ ===") (test '("~0&ABC~,8,'.tDEF") "ABC......DEF") (test '("~0&~3,8@tABC") " ABC") (test '("~0&1234~3,8@tABC") "1234 ABC") (test '("~0&12~3,8@tABC~3,8@tDEF") "12 ABC DEF") ; indirection test (test '("~a ~? ~a" 10 "~a ~a" (20 30) 40) "10 20 30 40") (test '("~a ~@? ~a" 10 "~a ~a" 20 30 40) "10 20 30 40") ; field test (test '("~10a" "abc") "abc ") (test '("~10@a" "abc") " abc") (test '("~10a" "0123456789abc") "0123456789abc") (test '("~10@a" "0123456789abc") "0123456789abc") ; pad character test (test '("~10,,,'*a" "abc") "abc*******") (test '("~10,,,'Xa" "abc") "abcXXXXXXX") (test '("~10,,,42a" "abc") "abc*******") (test '("~10,,,'*@a" "abc") "*******abc") (test '("~10,,3,'*a" "abc") "abc*******") (test '("~10,,3,'*a" "0123456789abc") "0123456789abc***") ; min. padchar length (test '("~10,,3,'*@a" "0123456789abc") "***0123456789abc") ; colinc, minpad padding test (test '("~10,8,0,'*a" 123) "123********") (test '("~10,9,0,'*a" 123) "123*********") (test '("~10,10,0,'*a" 123) "123**********") (test '("~10,11,0,'*a" 123) "123***********") (test '("~8,1,0,'*a" 123) "123*****") (test '("~8,2,0,'*a" 123) "123******") (test '("~8,3,0,'*a" 123) "123******") (test '("~8,4,0,'*a" 123) "123********") (test '("~8,5,0,'*a" 123) "123*****") (test '("~8,1,3,'*a" 123) "123*****") (test '("~8,1,5,'*a" 123) "123*****") (test '("~8,1,6,'*a" 123) "123******") (test '("~8,1,9,'*a" 123) "123*********") ; slashify test (test '("~s" "abc") "\"abc\"") (test '("~s" "abc \\ abc") "\"abc \\\\ abc\"") (test '("~a" "abc \\ abc") "abc \\ abc") (test '("~s" "abc \" abc") "\"abc \\\" abc\"") (test '("~a" "abc \" abc") "abc \" abc") (test '("~s" #\space) "#\\space") (test '("~s" #\newline) "#\\newline") (test `("~s" ,slib:tab) "#\\ht") (test '("~s" #\a) "#\\a") (test '("~a" (a "b" c)) "(a \"b\" c)") ; symbol case force test (define format:old-scc format:symbol-case-conv) (set! format:symbol-case-conv string-upcase) (test '("~a" abc) "ABC") (set! format:symbol-case-conv string-downcase) (test '("~s" abc) "abc") (set! format:symbol-case-conv string-capitalize) (test '("~s" abc) "Abc") (set! format:symbol-case-conv format:old-scc) ; read proof test (test `("~:s" ,display) (format:iobj->str display #t)) (test `("~:a" ,display) (format:iobj->str display #t)) (test `("~:a" (1 2 ,display)) (string-append "(1 2 " (format:iobj->str display #t) ")")) (test '("~:a" "abc") "abc") ; internal object case type force test (set! format:iobj-case-conv string-upcase) (test `("~a" ,display) (string-upcase (format:iobj->str display #f))) (set! format:iobj-case-conv string-downcase) (test `("~s" ,display) (string-downcase (format:iobj->str display #f))) (set! format:iobj-case-conv string-capitalize) (test `("~s" ,display) (string-capitalize (format:iobj->str display #f))) (set! format:iobj-case-conv #f) ; continuation line test (test '("abc~ 123") "abc123") (test '("abc~ 123") "abc123") (test '("abc~ ") "abc") (test '("abc~: def") "abc def") (test '("abc~@ def") "abc def") ; flush output (can't test it here really) (test '("abc ~! xyz") "abc xyz") ; string case conversion (test '("~a ~(~a~) ~a" "abc" "HELLO WORLD" "xyz") "abc hello world xyz") (test '("~a ~:(~a~) ~a" "abc" "HELLO WORLD" "xyz") "abc Hello World xyz") (test '("~a ~@(~a~) ~a" "abc" "HELLO WORLD" "xyz") "abc Hello world xyz") (test '("~a ~:@(~a~) ~a" "abc" "hello world" "xyz") "abc HELLO WORLD xyz") (test '("~:@(~a~)" (a b c)) "(A B C)") (test '("~:@(~x~)" 255) "FF") (test '("~:@(~p~)" 2) "S") (test `("~:@(~a~)" ,display) (string-upcase (format:iobj->str display #f))) (test '("~:(~a ~a ~a~) ~a" "abc" "xyz" "123" "world") "Abc Xyz 123 world") ; variable parameter (test '("~va" 10 "abc") "abc ") (test '("~v,,,va" 10 42 "abc") "abc*******") ; number of remaining arguments as parameter (test '("~#,,,'*@a ~a ~a ~a" 1 1 1 1) "***1 1 1 1") ; argument jumping (test '("~a ~* ~a" 10 20 30) "10 30") (test '("~a ~2* ~a" 10 20 30 40) "10 40") (test '("~a ~:* ~a" 10) "10 10") (test '("~a ~a ~2:* ~a ~a" 10 20) "10 20 10 20") (test '("~a ~a ~@* ~a ~a" 10 20) "10 20 10 20") (test '("~a ~a ~4@* ~a ~a" 10 20 30 40 50 60) "10 20 50 60") ; conditionals (test '("~[abc~;xyz~]" 0) "abc") (test '("~[abc~;xyz~]" 1) "xyz") (test '("~[abc~;xyz~:;456~]" 99) "456") (test '("~0[abc~;xyz~:;456~]") "abc") (test '("~1[abc~;xyz~:;456~] ~a" 100) "xyz 100") (test '("~#[no arg~;~a~;~a and ~a~;~a, ~a and ~a~]") "no arg") (test '("~#[no arg~;~a~;~a and ~a~;~a, ~a and ~a~]" 10) "10") (test '("~#[no arg~;~a~;~a and ~a~;~a, ~a and ~a~]" 10 20) "10 and 20") (test '("~#[no arg~;~a~;~a and ~a~;~a, ~a and ~a~]" 10 20 30) "10, 20 and 30") (test '("~:[hello~;world~] ~a" #t 10) "world 10") (test '("~:[hello~;world~] ~a" #f 10) "hello 10") (test '("~@[~a tests~]" #f) "") (test '("~@[~a tests~]" 10) "10 tests") (test '("~@[~a test~:p~] ~a" 10 done) "10 tests done") (test '("~@[~a test~:p~] ~a" 1 done) "1 test done") (test '("~@[~a test~:p~] ~a" 0 done) "0 tests done") (test '("~@[~a test~:p~] ~a" #f done) " done") (test '("~@[ level = ~d~]~@[ length = ~d~]" #f 5) " length = 5") (test '("~[abc~;~[4~;5~;6~]~;xyz~]" 0) "abc") ; nested conditionals (irrghh) (test '("~[abc~;~[4~;5~;6~]~;xyz~]" 2) "xyz") (test '("~[abc~;~[4~;5~;6~]~;xyz~]" 1 2) "6") ; iteration (test '("~{ ~a ~}" (a b c)) " a b c ") (test '("~{ ~a ~}" ()) "") (test '("~{ ~a ~5,,,'*a~}" (a b c d)) " a b**** c d****") (test '("~{ ~a,~a ~}" (a 1 b 2 c 3)) " a,1 b,2 c,3 ") (test '("~2{ ~a,~a ~}" (a 1 b 2 c 3)) " a,1 b,2 ") (test '("~3{~a ~} ~a" (a b c d e) 100) "a b c 100") (test '("~0{~a ~} ~a" (a b c d e) 100) " 100") (test '("~:{ ~a,~a ~}" ((a b) (c d e f) (g h))) " a,b c,d g,h ") (test '("~2:{ ~a,~a ~}" ((a b) (c d e f) (g h))) " a,b c,d ") (test '("~@{ ~a,~a ~}" a 1 b 2 c 3) " a,1 b,2 c,3 ") (test '("~2@{ ~a,~a ~} <~a|~a>" a 1 b 2 c 3) " a,1 b,2 ") (test '("~:@{ ~a,~a ~}" (a 1) (b 2) (c 3)) " a,1 b,2 c,3 ") (test '("~2:@{ ~a,~a ~} ~a" (a 1) (b 2) (c 3)) " a,1 b,2 (c 3)") (test '("~{~}" "<~a,~a>" (a 1 b 2 c 3)) "") (test '("~{ ~a ~{<~a>~}~} ~a" (a (1 2) b (3 4)) 10) " a <1><2> b <3><4> 10") (let ((nums (let iter ((ns '()) (l 0)) (if (> l 105) (reverse ns) (iter (cons l ns) (+ l 1)))))) ;; Test default, only 100 items formatted out: (test `("~D~{, ~D~}" ,(car nums) ,(cdr nums)) "0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90, 91, 92, 93, 94, 95, 96, 97, 98, 99, 100") ;; Test control of number of items formatted out: (set! format:max-iterations 90) (test `("~D~{, ~D~}" ,(car nums) ,(cdr nums)) "0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90") ;; Test control of imposing bound on number of items formatted out: (set! format:iteration-bounded #f) (test `("~D~{, ~D~}" ,(car nums) ,(cdr nums)) "0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90, 91, 92, 93, 94, 95, 96, 97, 98, 99, 100, 101, 102, 103, 104, 105") ;; Restore defaults: (set! format:iteration-bounded #t) (set! format:max-iterations 100) ) ; up and out (test '("abc ~^ xyz") "abc ") (test '("~@(abc ~^ xyz~) ~a" 10) "ABC xyz 10") (test '("done. ~^ ~d warning~:p. ~^ ~d error~:p.") "done. ") (test '("done. ~^ ~d warning~:p. ~^ ~d error~:p." 10) "done. 10 warnings. ") (test '("done. ~^ ~d warning~:p. ~^ ~d error~:p." 10 1) "done. 10 warnings. 1 error.") (test '("~{ ~a ~^<~a>~} ~a" (a b c d e f) 10) " a c e 10") (test '("~{ ~a ~^<~a>~} ~a" (a b c d e) 10) " a c e 10") (test '("abc~0^ xyz") "abc") (test '("abc~9^ xyz") "abc xyz") (test '("abc~7,4^ xyz") "abc xyz") (test '("abc~7,7^ xyz") "abc") (test '("abc~3,7,9^ xyz") "abc") (test '("abc~8,7,9^ xyz") "abc xyz") (test '("abc~3,7,5^ xyz") "abc xyz") ; complexity tests (oh my god, I hardly understand them myself (see CL std)) (define fmt "Items:~#[ none~; ~a~; ~a and ~a~:;~@{~#[~; and~] ~a~^,~}~].") (test `(,fmt ) "Items: none.") (test `(,fmt foo) "Items: foo.") (test `(,fmt foo bar) "Items: foo and bar.") (test `(,fmt foo bar baz) "Items: foo, bar, and baz.") (test `(,fmt foo bar baz zok) "Items: foo, bar, baz, and zok.") ; fixed floating points (cond (format:floats (test '("~6,2f" 3.14159) " 3.14") (test '("~6,1f" 3.14159) " 3.1") (test '("~6,0f" 3.14159) " 3.") (test '("~5,1f" 0) " 0.0") (test '("~10,7f" 3.14159) " 3.1415900") (test '("~10,7f" -3.14159) "-3.1415900") (test '("~10,7@f" 3.14159) "+3.1415900") (test '("~6,3f" 0.0) " 0.000") (test '("~6,4f" 0.007) "0.0070") (test '("~6,3f" 0.007) " 0.007") (test '("~6,2f" 0.007) " 0.01") (test '("~3,2f" 0.007) ".01") (test '("~3,2f" -0.007) "-.01") (test '("~6,2,,,'*f" 3.14159) "**3.14") (test '("~6,3,,'?f" 12345.56789) "??????") (test '("~6,3f" 12345.6789) "12345.679") (test '("~,3f" 12345.6789) "12345.679") (test '("~,3f" 9.9999) "10.000") (test '("~6f" 23.4) " 23.4") (test '("~6f" 1234.5) "1234.5") (test '("~6f" 12345678) "12345678.0") (test '("~6,,,'?f" 12345678) "??????") (test '("~6f" 123.56789) "123.57") (test '("~6f" 123.0) " 123.0") (test '("~6f" -123.0) "-123.0") (test '("~6f" 0.0) " 0.0") (test '("~3f" 3.141) "3.1") (test '("~2f" 3.141) "3.") (test '("~1f" 3.141) "3.141") (test '("~f" 123.56789) "123.56789") (test '("~f" -314.0) "-314.0") (test '("~f" 1e4) "10000.0") (test '("~f" -1.23e10) "-12300000000.0") (test '("~f" 1e-4) "0.0001") (test '("~f" -1.23e-10) "-0.000000000123") (test '("~@f" 314.0) "+314.0") (test '("~,,3f" 0.123456) "123.456") (test '("~,,-3f" -123.456) "-0.123456") (test '("~5,,3f" 0.123456) "123.5") )) ; exponent floating points (cond (format:floats (test '("~e" 3.14159) "3.14159E+0") (test '("~e" 0.00001234) "1.234E-5") (test '("~,,,0e" 0.00001234) "0.1234E-4") (test '("~,3e" 3.14159) "3.142E+0") (test '("~,3@e" 3.14159) "+3.142E+0") (test '("~,3@e" 0.0) "+0.000E+0") (test '("~,0e" 3.141) "3.E+0") (test '("~,3,,0e" 3.14159) "0.314E+1") (test '("~,5,3,-2e" 3.14159) "0.00314E+003") (test '("~,5,3,-5e" -3.14159) "-0.00000E+006") (test '("~,5,2,2e" 3.14159) "31.4159E-01") (test '("~,5,2,,,,'ee" 0.0) "0.00000e+00") (test '("~12,3e" -3.141) " -3.141E+0") (test '("~12,3,,,,'#e" -3.141) "###-3.141E+0") (test '("~10,2e" -1.236e-4) " -1.24E-4") (test '("~5,3e" -3.141) "-3.141E+0") (test '("~5,3,,,'*e" -3.141) "*****") (test '("~3e" 3.14159) "3.14159E+0") (test '("~4e" 3.14159) "3.14159E+0") (test '("~5e" 3.14159) "3.E+0") (test '("~5,,,,'*e" 3.14159) "3.E+0") (test '("~6e" 3.14159) "3.1E+0") (test '("~7e" 3.14159) "3.14E+0") (test '("~7e" -3.14159) "-3.1E+0") (test '("~8e" 3.14159) "3.142E+0") (test '("~9e" 3.14159) "3.1416E+0") (test '("~9,,,,,,'ee" 3.14159) "3.1416e+0") (test '("~10e" 3.14159) "3.14159E+0") (test '("~11e" 3.14159) " 3.14159E+0") (test '("~12e" 3.14159) " 3.14159E+0") (test '("~13,6,2,-5e" 3.14159) " 0.000003E+06") (test '("~13,6,2,-4e" 3.14159) " 0.000031E+05") (test '("~13,6,2,-3e" 3.14159) " 0.000314E+04") (test '("~13,6,2,-2e" 3.14159) " 0.003142E+03") (test '("~13,6,2,-1e" 3.14159) " 0.031416E+02") (test '("~13,6,2,0e" 3.14159) " 0.314159E+01") (test '("~13,6,2,1e" 3.14159) " 3.141590E+00") (test '("~13,6,2,2e" 3.14159) " 31.41590E-01") (test '("~13,6,2,3e" 3.14159) " 314.1590E-02") (test '("~13,6,2,4e" 3.14159) " 3141.590E-03") (test '("~13,6,2,5e" 3.14159) " 31415.90E-04") (test '("~13,6,2,6e" 3.14159) " 314159.0E-05") (test '("~13,6,2,7e" 3.14159) " 3141590.E-06") (test '("~13,6,2,8e" 3.14159) "31415900.E-07") (test '("~7,3,,-2e" 0.001) ".001E+0") (test '("~8,3,,-2@e" 0.001) "+.001E+0") (test '("~8,3,,-2@e" -0.001) "-.001E+0") (test '("~8,3,,-2e" 0.001) "0.001E+0") (test '("~7,,,-2e" 0.001) "0.00E+0") (test '("~12,3,1e" 3.14159e12) " 3.142E+12") (test '("~12,3,1,,'*e" 3.14159e12) "************") (test '("~5,3,1e" 3.14159e12) "3.142E+12") )) ; general floating point (this test is from Steele's CL book) (cond (format:floats (test '("~9,2,1,,'*g|~9,3,2,3,'?,,'$g|~9,3,2,0,'%g|~9,2g" 0.0314159 0.0314159 0.0314159 0.0314159) " 3.14E-2|314.2$-04|0.314E-01| 3.14E-2") (test '("~9,2,1,,'*g|~9,3,2,3,'?,,'$g|~9,3,2,0,'%g|~9,2g" 0.314159 0.314159 0.314159 0.314159) " 0.31 |0.314 |0.314 | 0.31 ") (test '("~9,2,1,,'*g|~9,3,2,3,'?,,'$g|~9,3,2,0,'%g|~9,2g" 3.14159 3.14159 3.14159 3.14159) " 3.1 | 3.14 | 3.14 | 3.1 ") (test '("~9,2,1,,'*g|~9,3,2,3,'?,,'$g|~9,3,2,0,'%g|~9,2g" 31.4159 31.4159 31.4159 31.4159) " 31. | 31.4 | 31.4 | 31. ") (test '("~9,2,1,,'*g|~9,3,2,3,'?,,'$g|~9,3,2,0,'%g|~9,2g" 314.159 314.159 314.159 314.159) " 3.14E+2| 314. | 314. | 3.14E+2") (test '("~9,2,1,,'*g|~9,3,2,3,'?,,'$g|~9,3,2,0,'%g|~9,2g" 3141.59 3141.59 3141.59 3141.59) " 3.14E+3|314.2$+01|0.314E+04| 3.14E+3") (test '("~9,2,1,,'*g|~9,3,2,3,'?,,'$g|~9,3,2,0,'%g|~9,2g" 3.14E12 3.14E12 3.14E12 3.14E12) "*********|314.0$+10|0.314E+13| 3.14E+12") (test '("~9,2,1,,'*g|~9,3,2,3,'?,,'$g|~9,3,2,0,'%g|~9,2g" 3.14E120 3.14E120 3.14E120 3.14E120) "*********|?????????|%%%%%%%%%|3.14E+120") (test '("~g" 0.0) "0.0 ") ; further ~g tests (test '("~g" 0.1) "0.1 ") (test '("~g" 0.01) "1.0E-2") (test '("~g" 123.456) "123.456 ") (test '("~g" 123456.7) "123456.7 ") (test '("~g" 123456.78) "123456.78 ") (test '("~g" 0.9282) "0.9282 ") (test '("~g" 0.09282) "9.282E-2") (test '("~g" 1) "1.0 ") (test '("~g" 12) "12.0 ") )) ; dollar floating point (cond (format:floats (test '("~$" 1.23) "1.23") (test '("~$" 1.2) "1.20") (test '("~$" 0.0) "0.00") (test '("~$" 9.999) "10.00") (test '("~3$" 9.9999) "10.000") (test '("~,4$" 3.2) "0003.20") (test '("~,4$" 10000.2) "10000.20") (test '("~,4,10$" 3.2) " 0003.20") (test '("~,4,10@$" 3.2) " +0003.20") (test '("~,4,10:@$" 3.2) "+ 0003.20") (test '("~,4,10:$" -3.2) "- 0003.20") (test '("~,4,10$" -3.2) " -0003.20") (test '("~,,10@$" 3.2) " +3.20") (test '("~,,10:@$" 3.2) "+ 3.20") (test '("~,,10:@$" -3.2) "- 3.20") (test '("~,,10,'_@$" 3.2) "_____+3.20") (test '("~,,4$" 1234.4) "1234.40") )) ; complex numbers (cond (format:complex-numbers (test '("~i" 3.0) "3.0+0.0i") (test '("~,3i" 3.0) "3.000+0.000i") (test `("~7,2i" ,(string->number "3.0+5.0i")) " 3.00 +5.00i") (test `("~7,2,1i" ,(string->number "3.0+5.0i")) " 30.00 +50.00i") (test `("~7,2@i" ,(string->number "3.0+5.0i")) " +3.00 +5.00i") (test `("~7,2,,,'*@i" ,(string->number "3.0+5.0i")) "**+3.00**+5.00i") )) ; note: some parsers choke syntactically on reading a complex ; number though format:complex is #f; this is why we put them in ; strings ; inquiry test (test '("~:q") format:version) (if (not test-verbose) (display "done.")) (format #t "~%~a Test~:p completed. (~a failure~:p)~2%" total fails) slib-3b1/format.texi0000644001705200017500000003424010111666655012365 0ustar tbtb @menu * Format Interface:: * Format Specification:: @end menu @node Format Interface, Format Specification, Format, Format @subsection Format Interface @defun format destination format-string . arguments An almost complete implementation of Common LISP format description according to the CL reference book @cite{Common LISP} from Guy L. Steele, Digital Press. Backward compatible to most of the available Scheme format implementations. Returns @code{#t}, @code{#f} or a string; has side effect of printing according to @var{format-string}. If @var{destination} is @code{#t}, the output is to the current output port and @code{#t} is returned. If @var{destination} is @code{#f}, a formatted string is returned as the result of the call. NEW: If @var{destination} is a string, @var{destination} is regarded as the format string; @var{format-string} is then the first argument and the output is returned as a string. If @var{destination} is a number, the output is to the current error port if available by the implementation. Otherwise @var{destination} must be an output port and @code{#t} is returned.@refill @var{format-string} must be a string. In case of a formatting error format returns @code{#f} and prints a message on the current output or error port. Characters are output as if the string were output by the @code{display} function with the exception of those prefixed by a tilde (~). For a detailed description of the @var{format-string} syntax please consult a Common LISP format reference manual. For a test suite to verify this format implementation load @file{formatst.scm}. Please send bug reports to @code{lutzeb@@cs.tu-berlin.de}. Note: @code{format} is not reentrant, i.e. only one @code{format}-call may be executed at a time. @end defun @node Format Specification, , Format Interface, Format @subsection Format Specification (Format version 3.1) Please consult a Common LISP format reference manual for a detailed description of the format string syntax. For a demonstration of the implemented directives see @file{formatst.scm}.@refill This implementation supports directive parameters and modifiers (@code{:} and @code{@@} characters). Multiple parameters must be separated by a comma (@code{,}). Parameters can be numerical parameters (positive or negative), character parameters (prefixed by a quote character (@code{'}), variable parameters (@code{v}), number of rest arguments parameter (@code{#}), empty and default parameters. Directive characters are case independent. The general form of a directive is:@refill @noindent @var{directive} ::= ~@{@var{directive-parameter},@}[:][@@]@var{directive-character} @noindent @var{directive-parameter} ::= [ [-|+]@{0-9@}+ | '@var{character} | v | # ] @subsubsection Implemented CL Format Control Directives Documentation syntax: Uppercase characters represent the corresponding control directive characters. Lowercase characters represent control directive parameter descriptions. @table @asis @item @code{~A} Any (print as @code{display} does). @table @asis @item @code{~@@A} left pad. @item @code{~@var{mincol},@var{colinc},@var{minpad},@var{padchar}A} full padding. @end table @item @code{~S} S-expression (print as @code{write} does). @table @asis @item @code{~@@S} left pad. @item @code{~@var{mincol},@var{colinc},@var{minpad},@var{padchar}S} full padding. @end table @item @code{~D} Decimal. @table @asis @item @code{~@@D} print number sign always. @item @code{~:D} print comma separated. @item @code{~@var{mincol},@var{padchar},@var{commachar}D} padding. @end table @item @code{~X} Hexadecimal. @table @asis @item @code{~@@X} print number sign always. @item @code{~:X} print comma separated. @item @code{~@var{mincol},@var{padchar},@var{commachar}X} padding. @end table @item @code{~O} Octal. @table @asis @item @code{~@@O} print number sign always. @item @code{~:O} print comma separated. @item @code{~@var{mincol},@var{padchar},@var{commachar}O} padding. @end table @item @code{~B} Binary. @table @asis @item @code{~@@B} print number sign always. @item @code{~:B} print comma separated. @item @code{~@var{mincol},@var{padchar},@var{commachar}B} padding. @end table @item @code{~@var{n}R} Radix @var{n}. @table @asis @item @code{~@var{n},@var{mincol},@var{padchar},@var{commachar}R} padding. @end table @item @code{~@@R} print a number as a Roman numeral. @item @code{~:@@R} print a number as an ``old fashioned'' Roman numeral. @item @code{~:R} print a number as an ordinal English number. @item @code{~R} print a number as a cardinal English number. @item @code{~P} Plural. @table @asis @item @code{~@@P} prints @code{y} and @code{ies}. @item @code{~:P} as @code{~P but jumps 1 argument backward.} @item @code{~:@@P} as @code{~@@P but jumps 1 argument backward.} @end table @item @code{~C} Character. @table @asis @item @code{~@@C} prints a character as the reader can understand it (i.e. @code{#\} prefixing). @item @code{~:C} prints a character as emacs does (eg. @code{^C} for ASCII 03). @end table @item @code{~F} Fixed-format floating-point (prints a flonum like @var{mmm.nnn}). @table @asis @item @code{~@var{width},@var{digits},@var{scale},@var{overflowchar},@var{padchar}F} @item @code{~@@F} If the number is positive a plus sign is printed. @end table @item @code{~E} Exponential floating-point (prints a flonum like @var{mmm.nnn}@code{E}@var{ee}). @table @asis @item @code{~@var{width},@var{digits},@var{exponentdigits},@var{scale},@var{overflowchar},@var{padchar},@var{exponentchar}E} @item @code{~@@E} If the number is positive a plus sign is printed. @end table @item @code{~G} General floating-point (prints a flonum either fixed or exponential). @table @asis @item @code{~@var{width},@var{digits},@var{exponentdigits},@var{scale},@var{overflowchar},@var{padchar},@var{exponentchar}G} @item @code{~@@G} If the number is positive a plus sign is printed. @end table @item @code{~$} Dollars floating-point (prints a flonum in fixed with signs separated). @table @asis @item @code{~@var{digits},@var{scale},@var{width},@var{padchar}$} @item @code{~@@$} If the number is positive a plus sign is printed. @item @code{~:@@$} A sign is always printed and appears before the padding. @item @code{~:$} The sign appears before the padding. @end table @item @code{~%} Newline. @table @asis @item @code{~@var{n}%} print @var{n} newlines. @end table @item @code{~&} print newline if not at the beginning of the output line. @table @asis @item @code{~@var{n}&} prints @code{~&} and then @var{n-1} newlines. @end table @item @code{~|} Page Separator. @table @asis @item @code{~@var{n}|} print @var{n} page separators. @end table @item @code{~~} Tilde. @table @asis @item @code{~@var{n}~} print @var{n} tildes. @end table @item @code{~} Continuation Line. @table @asis @item @code{~:} newline is ignored, white space left. @item @code{~@@} newline is left, white space ignored. @end table @item @code{~T} Tabulation. @table @asis @item @code{~@@T} relative tabulation. @item @code{~@var{colnum,colinc}T} full tabulation. @end table @item @code{~?} Indirection (expects indirect arguments as a list). @table @asis @item @code{~@@?} extracts indirect arguments from format arguments. @end table @item @code{~(@var{str}~)} Case conversion (converts by @code{string-downcase}). @table @asis @item @code{~:(@var{str}~)} converts by @code{string-capitalize}. @item @code{~@@(@var{str}~)} converts by @code{string-capitalize-first}. @item @code{~:@@(@var{str}~)} converts by @code{string-upcase}. @end table @item @code{~*} Argument Jumping (jumps 1 argument forward). @table @asis @item @code{~@var{n}*} jumps @var{n} arguments forward. @item @code{~:*} jumps 1 argument backward. @item @code{~@var{n}:*} jumps @var{n} arguments backward. @item @code{~@@*} jumps to the 0th argument. @item @code{~@var{n}@@*} jumps to the @var{n}th argument (beginning from 0) @end table @item @code{~[@var{str0}~;@var{str1}~;...~;@var{strn}~]} Conditional Expression (numerical clause conditional). @table @asis @item @code{~@var{n}[} take argument from @var{n}. @item @code{~@@[} true test conditional. @item @code{~:[} if-else-then conditional. @item @code{~;} clause separator. @item @code{~:;} default clause follows. @end table @item @code{~@{@var{str}~@}} Iteration (args come from the next argument (a list)). Iteration bounding is controlled by configuration variables @var{format:iteration-bounded} and @var{format:max-iterations}. With both variables default, a maximum of 100 iterations will be performed. @table @asis @item @code{~@var{n}@{} at most @var{n} iterations. @item @code{~:@{} args from next arg (a list of lists). @item @code{~@@@{} args from the rest of arguments. @item @code{~:@@@{} args from the rest args (lists). @end table @item @code{~^} Up and out. @table @asis @item @code{~@var{n}^} aborts if @var{n} = 0 @item @code{~@var{n},@var{m}^} aborts if @var{n} = @var{m} @item @code{~@var{n},@var{m},@var{k}^} aborts if @var{n} <= @var{m} <= @var{k} @end table @end table @subsubsection Not Implemented CL Format Control Directives @table @asis @item @code{~:A} print @code{#f} as an empty list (see below). @item @code{~:S} print @code{#f} as an empty list (see below). @item @code{~<~>} Justification. @item @code{~:^} (sorry I don't understand its semantics completely) @end table @subsubsection Extended, Replaced and Additional Control Directives @table @asis @item @code{~@var{mincol},@var{padchar},@var{commachar},@var{commawidth}D} @item @code{~@var{mincol},@var{padchar},@var{commachar},@var{commawidth}X} @item @code{~@var{mincol},@var{padchar},@var{commachar},@var{commawidth}O} @item @code{~@var{mincol},@var{padchar},@var{commachar},@var{commawidth}B} @item @code{~@var{n},@var{mincol},@var{padchar},@var{commachar},@var{commawidth}R} @var{commawidth} is the number of characters between two comma characters. @end table @table @asis @item @code{~I} print a R4RS complex number as @code{~F~@@Fi} with passed parameters for @code{~F}. @item @code{~Y} Pretty print formatting of an argument for scheme code lists. @item @code{~K} Same as @code{~?.} @item @code{~!} Flushes the output if format @var{destination} is a port. @item @code{~_} Print a @code{#\space} character @table @asis @item @code{~@var{n}_} print @var{n} @code{#\space} characters. @end table @item @code{~/} Print a @code{#\tab} character @table @asis @item @code{~@var{n}/} print @var{n} @code{#\tab} characters. @end table @item @code{~@var{n}C} Takes @var{n} as an integer representation for a character. No arguments are consumed. @var{n} is converted to a character by @code{integer->char}. @var{n} must be a positive decimal number.@refill @item @code{~:S} Print out readproof. Prints out internal objects represented as @code{#<...>} as strings @code{"#<...>"} so that the format output can always be processed by @code{read}. @refill @item @code{~:A} Print out readproof. Prints out internal objects represented as @code{#<...>} as strings @code{"#<...>"} so that the format output can always be processed by @code{read}. @item @code{~Q} Prints information and a copyright notice on the format implementation. @table @asis @item @code{~:Q} prints format version. @end table @refill @item @code{~F, ~E, ~G, ~$} may also print number strings, i.e. passing a number as a string and format it accordingly. @end table @subsubsection Configuration Variables Format has some configuration variables at the beginning of @file{format.scm} to suit the systems and users needs. There should be no modification necessary for the configuration that comes with SLIB. If modification is desired the variable should be set after the format code is loaded. Format detects automatically if the running scheme system implements floating point numbers and complex numbers. @table @asis @item @var{format:symbol-case-conv} Symbols are converted by @code{symbol->string} so the case type of the printed symbols is implementation dependent. @code{format:symbol-case-conv} is a one arg closure which is either @code{#f} (no conversion), @code{string-upcase}, @code{string-downcase} or @code{string-capitalize}. (default @code{#f}) @item @var{format:iobj-case-conv} As @var{format:symbol-case-conv} but applies for the representation of implementation internal objects. (default @code{#f}) @item @var{format:expch} The character prefixing the exponent value in @code{~E} printing. (default @code{#\E}) @item @var{format:iteration-bounded} When @code{#t}, a @code{~@{...~@}} control will iterate no more than the number of times specified by @var{format:max-iterations} regardless of the number of iterations implied by modifiers and arguments. When @code{#f}, a @code{~@{...~@}} control will iterate the number of times implied by modifiers and arguments, unless termination is forced by language or system limitations. (default @code{#t}) @item @var{format:max-iterations} The maximum number of iterations performed by a @code{~@{...~@}} control. Has effect only when @var{format:iteration-bounded} is @code{#t}. (default 100) @end table @subsubsection Compatibility With Other Format Implementations @table @asis @item SLIB format 2.x: See @file{format.doc}. @item SLIB format 1.4: Downward compatible except for padding support and @code{~A}, @code{~S}, @code{~P}, @code{~X} uppercase printing. SLIB format 1.4 uses C-style @code{printf} padding support which is completely replaced by the CL @code{format} padding style. @item MIT C-Scheme 7.1: Downward compatible except for @code{~}, which is not documented (ignores all characters inside the format string up to a newline character). (7.1 implements @code{~a}, @code{~s}, ~@var{newline}, @code{~~}, @code{~%}, numerical and variable parameters and @code{:/@@} modifiers in the CL sense).@refill @item Elk 1.5/2.0: Downward compatible except for @code{~A} and @code{~S} which print in uppercase. (Elk implements @code{~a}, @code{~s}, @code{~~}, and @code{~%} (no directive parameters or modifiers)).@refill @item Scheme->C 01nov91: Downward compatible except for an optional destination parameter: S2C accepts a format call without a destination which returns a formatted string. This is equivalent to a #f destination in S2C. (S2C implements @code{~a}, @code{~s}, @code{~c}, @code{~%}, and @code{~~} (no directive parameters or modifiers)).@refill @end table This implementation of format is solely useful in the SLIB context because it requires other components provided by SLIB.@refill slib-3b1/gambit.init0000644001705200017500000003421510733633204012326 0ustar tbtb;;;"gambit.init" Initialization for SLIB for Gambit -*-scheme-*- ;;; Author: Aubrey Jaffer ;;; ;;; This code is in the public domain. ;;; Updated 1992 February 1 for Gambit v1.71 -- by Ken Dickey ;;; Date: Wed, 12 Jan 1994 15:03:12 -0500 ;;; From: barnett@armadillo.urich.edu (Lewis Barnett) ;;; Relative pathnames for Slib in MacGambit ;;; Hacked yet again for Gambit v2.4, Jan 1997, by Mike Pope ;;; Updated for Gambit v3.0, 2001-01 AGJ. ;;; gsi should be invoked with -:s option to Ignore case when reading ;;; symbols (per R5RS). (define (software-type) 'macos) ; for MacGambit. (define (software-type) 'unix) ; for Unix platforms. (define (scheme-implementation-type) 'gambit) ;;; (scheme-implementation-home-page) should return a (string) URI ;;; (Uniform Resource Identifier) for this scheme implementation's home ;;; page; or false if there isn't one. (define (scheme-implementation-home-page) "http://www.iro.umontreal.ca/~gambit/index.html") (define (scheme-implementation-version) (system-version-string)) (define getenv (let ((ge getenv)) (lambda (str) (ge str #f)))) ;;; (implementation-vicinity) should be defined to be the pathname of ;;; the directory where any auxillary files to your Scheme ;;; implementation reside. (define implementation-vicinity (let ((impl-path (or (getenv "GAMBIT_IMPLEMENTATION_PATH") (case (software-type) ((unix) "/usr/local/share/gambc/") ((vms) "scheme$src:") ((ms-dos) "C:\\scheme\\") ((windows) "c:/scheme/") ((macos) (let ((arg0 (list-ref (argv) 0))) (let loop ((i (- (string-length arg0) 1))) (cond ((negative? i) "") ((char=? #\: (string-ref arg0 i)) (substring arg0 0 (+ i 1))) (else (loop (- i 1))))))) (else ""))))) (lambda () impl-path))) ;;; (library-vicinity) should be defined to be the pathname of the ;;; directory where files of Scheme library functions reside. ;;; ;;; This assumes that the slib files are in a folder ;;; called slib in the same directory as the MacGambit Interpreter. (define library-vicinity (let ((library-path (or ;; Use this getenv if your implementation supports it. (getenv "SCHEME_LIBRARY_PATH") ;; Use this path if your scheme does not support GETENV ;; or if SCHEME_LIBRARY_PATH is not set. (case (software-type) ((unix) "/usr/local/lib/slib/") ((macos) (string-append (implementation-vicinity) "slib:")) ((amiga) "dh0:scm/Library/") ((vms) "lib$scheme:") ((windows ms-dos) "C:\\SLIB\\") (else ""))))) (lambda () library-path))) ;;; (home-vicinity) should return the vicinity of the user's HOME ;;; directory, the directory which typically contains files which ;;; customize a computer environment for a user. (define (home-vicinity) (let ((home (getenv "HOME"))) (if home (case (software-type) ((unix coherent ms-dos) ;V7 unix has a / on HOME (if (eqv? #\/ (string-ref home (+ -1 (string-length home)))) home (string-append home "/"))) (else home)) (case (software-type) ((vms) "~:") ((windows) "~/") ((macos) "~:") (else #f))))) ;@ (define in-vicinity string-append) ;@ (define (user-vicinity) (case (software-type) ((vms) "[.]") (else ""))) (define *load-pathname* #f) ;@ (define vicinity:suffix? (let ((suffi (case (software-type) ((amiga) '(#\: #\/)) ((macos thinkc) '(#\:)) ((ms-dos windows atarist os/2) '(#\\ #\/)) ((nosve) '(#\: #\.)) ((unix coherent plan9) '(#\/)) ((vms) '(#\: #\])) (else (slib:warn "require.scm" 'unknown 'software-type (software-type)) "/")))) (lambda (chr) (and (memv chr suffi) #t)))) ;@ (define (pathname->vicinity pathname) (let loop ((i (- (string-length pathname) 1))) (cond ((negative? i) "") ((vicinity:suffix? (string-ref pathname i)) (substring pathname 0 (+ i 1))) (else (loop (- i 1)))))) (define (program-vicinity) (if *load-pathname* (pathname->vicinity *load-pathname*) (slib:error 'program-vicinity " called; use slib:load to load"))) ;@ (define sub-vicinity (case (software-type) ((vms) (lambda (vic name) (let ((l (string-length vic))) (if (or (zero? (string-length vic)) (not (char=? #\] (string-ref vic (- l 1))))) (string-append vic "[" name "]") (string-append (substring vic 0 (- l 1)) "." name "]"))))) (else (let ((*vicinity-suffix* (case (software-type) ((nosve) ".") ((macos thinkc) ":") ((ms-dos windows atarist os/2) "\\") ((unix coherent plan9 amiga) "/")))) (lambda (vic name) (string-append vic name *vicinity-suffix*)))))) ;@ (define (make-vicinity ) ) ;@ (define with-load-pathname (let ((exchange (lambda (new) (let ((old *load-pathname*)) (set! *load-pathname* new) old)))) (lambda (path thunk) (let ((old #f)) (dynamic-wind (lambda () (set! old (exchange path))) thunk (lambda () (exchange old))))))) ;;@ SLIB:FEATURES is a list of symbols naming the (SLIB) features ;;; initially supported by this implementation. (define slib:features '( source ;can load scheme source files ;(SLIB:LOAD-SOURCE "filename") compiled ;can load compiled files ;(SLIB:LOAD-COMPILED "filename") vicinity srfi-59 srfi-96 ;; Scheme report features ;; R5RS-compliant implementations should provide all 9 features. ;;; r5rs ;conforms to ;;; eval ;R5RS two-argument eval values ;R5RS multiple values dynamic-wind ;R5RS dynamic-wind ;;; macro ;R5RS high level macros delay ;has DELAY and FORCE multiarg-apply ;APPLY can take more than 2 args. char-ready? rev4-optional-procedures ;LIST-TAIL, STRING-COPY, ;STRING-FILL!, and VECTOR-FILL! ;; These four features are optional in both R4RS and R5RS multiarg/and- ;/ and - can take more than 2 args. rationalize transcript ;TRANSCRIPT-ON and TRANSCRIPT-OFF with-file ;has WITH-INPUT-FROM-FILE and ;WITH-OUTPUT-TO-FILE r4rs ;conforms to ieee-p1178 ;conforms to ;;; r3rs ;conforms to ;;; rev2-procedures ;SUBSTRING-MOVE-LEFT!, ;SUBSTRING-MOVE-RIGHT!, ;SUBSTRING-FILL!, ;STRING-NULL?, APPEND!, 1+, ;-1+, ?, >=? ;;; object-hash ;has OBJECT-HASH full-continuation ;can return multiple times ieee-floating-point ;conforms to IEEE Standard 754-1985 ;IEEE Standard for Binary ;Floating-Point Arithmetic. ;; Other common features srfi-0 ;srfi-0, COND-EXPAND finds all srfi-* sicp ;runs code from Structure and ;Interpretation of Computer ;Programs by Abelson and Sussman. defmacro ;has Common Lisp DEFMACRO ;;; record ;has user defined data structures structure ;DEFINE-STRUCTURE macro string-port ;has CALL-WITH-INPUT-STRING and ;CALL-WITH-OUTPUT-STRING ;;; sort pretty-print object->string ;;; format trace ;has macros: TRACE and UNTRACE ;;; compiler ;has (COMPILER) ;;; ed ;(ED) is editor system ;posix (system ) getenv ;posix (getenv ) ;;; program-arguments ;returns list of strings (argv) current-time ;returns time in seconds since 1/1/1970 ;; Implementation Specific features break )) (define object->limited-string object->string) (define (difftime caltime1 caltime0) (- (time->seconds caltime1) (if (number? caltime0) caltime0 (time->seconds caltime0)))) (define (offset-time caltime offset) (seconds->time (+ (time->seconds caltime) offset))) ;; procedure: input-port-byte-position port [position [whence]] ;; procedure: output-port-byte-position port [position [whence]] ;; ;; When called with a single argument these procedures return the ;; byte position where the next I/O operation would take place in the ;; file attached to the given port (relative to the beginning of the ;; file). When called with two or three arguments, the byte position ;; for subsequent I/O operations on the given port is changed to ;; position, which must be an exact integer. When whence is omitted ;; or is 0, the position is relative to the beginning of the file. ;; When whence is 1, the position is relative to the current byte ;; position of the file. When whence is 2, the position is relative ;; to the end of the file. The return value is the new byte position. ;; On most operating systems the byte position for reading and writing ;; of a given bidirectional port are the same. ;; ;; When input-port-byte-position is called to change the byte ;; position of an input-port, all input buffers will be flushed so ;; that the next byte read will be the one at the given position. ;; ;; When output-port-byte-position is called to change the byte ;; position of an output-port, there is an implicit call to ;; force-output before the position is changed. ;;@ (FILE-POSITION . ) (define (file-position port . k) (apply (if (output-port? port) output-port-byte-position input-port-byte-position) port k)) ;;; (OUTPUT-PORT-WIDTH ) ;; (define (output-port-width . arg) 79) ;;; (OUTPUT-PORT-HEIGHT ) (define (output-port-height . arg) 24) ;;; (CURRENT-ERROR-PORT) (define current-error-port (let ((port (current-output-port))) (lambda () port))) ;;; (TMPNAM) makes a temporary file name. (define tmpnam (let ((cntr 100)) (lambda () (set! cntr (+ 1 cntr)) (string-append "slib_" (number->string cntr))))) ;;; Gambit supports SYSTEM as an "Unstable Addition"; Watch for changes. (define system ##shell-command) ;;; CALL-WITH-INPUT-STRING is good as is. Gambit's ;;; CALL-WITH-OUTPUT-STRING lengthens the string first argument. (define call-with-output-string (let ((cwos call-with-output-string)) (lambda (proc) (cwos "" proc)))) (define (make-exchanger obj) (lambda (rep) (let ((old obj)) (set! obj rep) old))) (define open-file (let ((open-both open-file)) (lambda (filename modes) (case modes ((r rb) (open-input-file filename)) ((w wb) (open-output-file filename)) ((rw rwb) (open-both filename)) (else (slib:error 'open-file 'mode? modes)))))) (define (call-with-open-ports . ports) (define proc (car ports)) (cond ((procedure? proc) (set! ports (cdr ports))) (else (set! ports (reverse ports)) (set! proc (car ports)) (set! ports (reverse (cdr ports))))) (let ((ans (apply proc ports))) (for-each close-port ports) ans)) (define (browse-url url) (define (try cmd) (eqv? 0 (system (sprintf #f cmd url)))) (or (try "netscape-remote -remote 'openURL(%s)'") (try "netscape -remote 'openURL(%s)'") (try "netscape '%s'&") (try "netscape '%s'"))) ;;; "rationalize" adjunct procedures. (define (find-ratio x e) (let ((rat (rationalize x e))) (list (numerator rat) (denominator rat)))) (define (find-ratio-between x y) (find-ratio (/ (+ x y) 2) (/ (- x y) 2))) ;;; CHAR-CODE-LIMIT is one greater than the largest integer which can ;;; be returned by CHAR->INTEGER. (define char-code-limit 256) ;; MOST-POSITIVE-FIXNUM is used in modular.scm (define most-positive-fixnum #x1FFFFFFF) ; 3-bit tag for 68K ;;; Return argument (define (identity x) x) ;;; SLIB:EVAL is single argument eval using the top-level (user) environment. (define slib:eval eval) (define *defmacros* (list (cons 'defmacro (lambda (name parms . body) `(set! *defmacros* (cons (cons ',name (lambda ,parms ,@body)) *defmacros*)))))) (define (defmacro? m) (and (assq m *defmacros*) #t)) (define (macroexpand-1 e) (if (pair? e) (let ((a (car e))) (cond ((symbol? a) (set! a (assq a *defmacros*)) (if a (apply (cdr a) (cdr e)) e)) (else e))) e)) (define (macroexpand e) (if (pair? e) (let ((a (car e))) (cond ((symbol? a) (set! a (assq a *defmacros*)) (if a (macroexpand (apply (cdr a) (cdr e))) e)) (else e))) e)) (define gentemp (let ((*gensym-counter* -1)) (lambda () (set! *gensym-counter* (+ *gensym-counter* 1)) (string->symbol (string-append "slib:G" (number->string *gensym-counter*)))))) (define base:eval slib:eval) (define defmacro:eval base:eval) (define (defmacro:load ) (slib:eval-load defmacro:eval)) (define print-call-stack identity) ;noop (define slib:warn (lambda args (let ((cep (current-error-port))) (if (provided? 'trace) (print-call-stack cep)) (display "Warn: " cep) (for-each (lambda (x) (display #\space cep) (write x cep)) args)))) ;; define an error procedure for the library (define slib:error (let ((error error)) (lambda args (if (provided? 'trace) (print-call-stack (current-error-port))) (apply error args)))) ;; define these as appropriate for your system. (define slib:tab (integer->char 9)) (define slib:form-feed (integer->char 12)) ;;; Support for older versions of Scheme. Not enough code for its own file. (define (last-pair l) (if (pair? (cdr l)) (last-pair (cdr l)) l)) (define t #t) (define nil #f) ;;; Define these if your implementation's syntax can support it and if ;;; they are not already defined. (define (1+ n) (+ n 1)) (define (-1+ n) (- n 1)) (define 1- -1+) ;;; Define SLIB:EXIT to be the implementation procedure to exit or ;;; return if exiting not supported. (define slib:exit (lambda args (exit))) ;;; Here for backward compatability (define scheme-file-suffix (let ((suffix (case (software-type) ((nosve) "_scm") (else ".scm")))) (lambda () suffix))) ;;; (SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever ;;; suffix all the module files in SLIB have. See feature 'SOURCE. (define slib:load-source load) ;;; (SLIB:LOAD-COMPILED "foo") should load the file that was produced ;;; by compiling "foo.scm" if this implementation can compile files. ;;; See feature 'COMPILED. (define slib:load-compiled load) ;;; At this point SLIB:LOAD must be able to load SLIB files. (define slib:load slib:load-source) ;;; If your implementation provides R4RS macros: ;;(define macro:eval slib:eval) ;;(define macro:load slib:load-source) ;;; If your implementation provides syntax-case macros: ;;(define syncase:eval slib:eval) ;;(define syncase:load slib:load-source) (slib:eval '(define-macro (defmacro name parms . body) (set! *defmacros* (cons `(cons ',name (lambda ,parms ,@body)) *defmacros*)) `(define-macro (,name ,@parms) ,@body))) (slib:load (in-vicinity (library-vicinity) "require")) slib-3b1/genwrite.scm0000644001705200017500000002245007776076457012554 0ustar tbtb;;"genwrite.scm" generic write used by pretty-print and truncated-print. ;; Copyright (c) 1991, Marc Feeley ;; Author: Marc Feeley (feeley@iro.umontreal.ca) ;; Distribution restrictions: none (define genwrite:newline-str (make-string 1 #\newline)) ;@ (define (generic-write obj display? width output) (define (read-macro? l) (define (length1? l) (and (pair? l) (null? (cdr l)))) (let ((head (car l)) (tail (cdr l))) (case head ((quote quasiquote unquote unquote-splicing) (length1? tail)) (else #f)))) (define (read-macro-body l) (cadr l)) (define (read-macro-prefix l) (let ((head (car l)) (tail (cdr l))) (case head ((quote) "'") ((quasiquote) "`") ((unquote) ",") ((unquote-splicing) ",@")))) (define (out str col) (and col (output str) (+ col (string-length str)))) (define (wr obj col) (define (wr-expr expr col) (if (read-macro? expr) (wr (read-macro-body expr) (out (read-macro-prefix expr) col)) (wr-lst expr col))) (define (wr-lst l col) (if (pair? l) (let loop ((l (cdr l)) (col (and col (wr (car l) (out "(" col))))) (cond ((not col) col) ((pair? l) (loop (cdr l) (wr (car l) (out " " col)))) ((null? l) (out ")" col)) (else (out ")" (wr l (out " . " col)))))) (out "()" col))) (cond ((pair? obj) (wr-expr obj col)) ((null? obj) (wr-lst obj col)) ((vector? obj) (wr-lst (vector->list obj) (out "#" col))) ((boolean? obj) (out (if obj "#t" "#f") col)) ((number? obj) (out (number->string obj) col)) ((symbol? obj) (out (symbol->string obj) col)) ((procedure? obj) (out "#[procedure]" col)) ((string? obj) (if display? (out obj col) (let loop ((i 0) (j 0) (col (out "\"" col))) (if (and col (< j (string-length obj))) (let ((c (string-ref obj j))) (if (or (char=? c #\\) (char=? c #\")) (loop j (+ j 1) (out "\\" (out (substring obj i j) col))) (loop i (+ j 1) col))) (out "\"" (out (substring obj i j) col)))))) ((char? obj) (if display? (out (make-string 1 obj) col) (out (case obj ((#\space) "space") ((#\newline) "newline") (else (make-string 1 obj))) (out "#\\" col)))) ((input-port? obj) (out "#[input-port]" col)) ((output-port? obj) (out "#[output-port]" col)) ((eof-object? obj) (out "#[eof-object]" col)) (else (out "#[unknown]" col)))) (define (pp obj col) (define (spaces n col) (if (> n 0) (if (> n 7) (spaces (- n 8) (out " " col)) (out (substring " " 0 n) col)) col)) (define (indent to col) (and col (if (< to col) (and (out genwrite:newline-str col) (spaces to 0)) (spaces (- to col) col)))) (define (pr obj col extra pp-pair) (if (or (pair? obj) (vector? obj)) ; may have to split on multiple lines (let ((result '()) (left (min (+ (- (- width col) extra) 1) max-expr-width))) (generic-write obj display? #f (lambda (str) (set! result (cons str result)) (set! left (- left (string-length str))) (> left 0))) (if (> left 0) ; all can be printed on one line (out (reverse-string-append result) col) (if (pair? obj) (pp-pair obj col extra) (pp-list (vector->list obj) (out "#" col) extra pp-expr)))) (wr obj col))) (define (pp-expr expr col extra) (if (read-macro? expr) (pr (read-macro-body expr) (out (read-macro-prefix expr) col) extra pp-expr) (let ((head (car expr))) (if (symbol? head) (let ((proc (style head))) (if proc (proc expr col extra) (if (> (string-length (symbol->string head)) max-call-head-width) (pp-general expr col extra #f #f #f pp-expr) (pp-call expr col extra pp-expr)))) (pp-list expr col extra pp-expr))))) ; (head item1 ; item2 ; item3) (define (pp-call expr col extra pp-item) (let ((col* (wr (car expr) (out "(" col)))) (and col (pp-down (cdr expr) col* (+ col* 1) extra pp-item)))) ; (item1 ; item2 ; item3) (define (pp-list l col extra pp-item) (let ((col (out "(" col))) (pp-down l col col extra pp-item))) (define (pp-down l col1 col2 extra pp-item) (let loop ((l l) (col col1)) (and col (cond ((pair? l) (let ((rest (cdr l))) (let ((extra (if (null? rest) (+ extra 1) 0))) (loop rest (pr (car l) (indent col2 col) extra pp-item))))) ((null? l) (out ")" col)) (else (out ")" (pr l (indent col2 (out "." (indent col2 col))) (+ extra 1) pp-item))))))) (define (pp-general expr col extra named? pp-1 pp-2 pp-3) (define (tail1 rest col1 col2 col3) (if (and pp-1 (pair? rest)) (let* ((val1 (car rest)) (rest (cdr rest)) (extra (if (null? rest) (+ extra 1) 0))) (tail2 rest col1 (pr val1 (indent col3 col2) extra pp-1) col3)) (tail2 rest col1 col2 col3))) (define (tail2 rest col1 col2 col3) (if (and pp-2 (pair? rest)) (let* ((val1 (car rest)) (rest (cdr rest)) (extra (if (null? rest) (+ extra 1) 0))) (tail3 rest col1 (pr val1 (indent col3 col2) extra pp-2))) (tail3 rest col1 col2))) (define (tail3 rest col1 col2) (pp-down rest col2 col1 extra pp-3)) (let* ((head (car expr)) (rest (cdr expr)) (col* (wr head (out "(" col)))) (if (and named? (pair? rest)) (let* ((name (car rest)) (rest (cdr rest)) (col** (wr name (out " " col*)))) (tail1 rest (+ col indent-general) col** (+ col** 1))) (tail1 rest (+ col indent-general) col* (+ col* 1))))) (define (pp-expr-list l col extra) (pp-list l col extra pp-expr)) (define (pp-LAMBDA expr col extra) (pp-general expr col extra #f pp-expr-list #f pp-expr)) (define (pp-IF expr col extra) (pp-general expr col extra #f pp-expr #f pp-expr)) (define (pp-COND expr col extra) (pp-call expr col extra pp-expr-list)) (define (pp-CASE expr col extra) (pp-general expr col extra #f pp-expr #f pp-expr-list)) (define (pp-AND expr col extra) (pp-call expr col extra pp-expr)) (define (pp-LET expr col extra) (let* ((rest (cdr expr)) (named? (and (pair? rest) (symbol? (car rest))))) (pp-general expr col extra named? pp-expr-list #f pp-expr))) (define (pp-BEGIN expr col extra) (pp-general expr col extra #f #f #f pp-expr)) (define (pp-DO expr col extra) (pp-general expr col extra #f pp-expr-list pp-expr-list pp-expr)) ; define formatting style (change these to suit your style) (define indent-general 2) (define max-call-head-width 5) (define max-expr-width 50) (define (style head) (case head ((lambda let* letrec define) pp-LAMBDA) ((if set!) pp-IF) ((cond) pp-COND) ((case) pp-CASE) ((and or) pp-AND) ((let) pp-LET) ((begin) pp-BEGIN) ((do) pp-DO) (else #f))) (pr obj col 0 pp-expr)) (if width (out genwrite:newline-str (pp obj 0)) (wr obj 0))) ; (reverse-string-append l) = (apply string-append (reverse l)) ;@ (define (reverse-string-append l) (define (rev-string-append l i) (if (pair? l) (let* ((str (car l)) (len (string-length str)) (result (rev-string-append (cdr l) (+ i len)))) (let loop ((j 0) (k (- (- (string-length result) i) len))) (if (< j len) (begin (string-set! result k (string-ref str j)) (loop (+ j 1) (+ k 1))) result))) (make-string i))) (rev-string-append l 0)) slib-3b1/getopt.scm0000644001705200017500000000530010436733523012202 0ustar tbtb;;; "getopt.scm" POSIX command argument processing ;Copyright (C) 1993, 1994, 2002 Aubrey Jaffer ; ;Permission to copy this software, to modify it, to redistribute it, ;to distribute modified versions, and to use it for any purpose is ;granted, subject to the following restrictions and understandings. ; ;1. Any copy made of this software must include this copyright notice ;in full. ; ;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; ;3. In conjunction with products arising from the use of this ;material, there shall be no use of my name in any advertising, ;promotional, or sales literature without prior written consent in ;each case. (define getopt:scan #f) (define getopt:char #\-) ;@ (define getopt:opt #f) ;;(define *argv* *argv*) (define *optind* 1) (define *optarg* 0) ;@ (define (getopt optstring) (let ((opts (string->list optstring)) (place #f) (arg #f) (argref (lambda () ((if (vector? *argv*) vector-ref list-ref) *argv* *optind*)))) (and (cond ((and getopt:scan (not (string=? "" getopt:scan))) #t) ((>= *optind* (length *argv*)) #f) (else (set! arg (argref)) (cond ((or (<= (string-length arg) 1) (not (char=? (string-ref arg 0) getopt:char))) #f) ((and (= (string-length arg) 2) (char=? (string-ref arg 1) getopt:char)) (set! *optind* (+ *optind* 1)) #f) (else (set! getopt:scan (substring arg 1 (string-length arg))) #t)))) (begin (set! getopt:opt (string-ref getopt:scan 0)) (set! getopt:scan (substring getopt:scan 1 (string-length getopt:scan))) (if (string=? "" getopt:scan) (set! *optind* (+ *optind* 1))) (set! place (member getopt:opt opts)) (cond ((not place) #\?) ((or (null? (cdr place)) (not (char=? #\: (cadr place)))) getopt:opt) ((not (string=? "" getopt:scan)) (set! *optarg* getopt:scan) (set! *optind* (+ *optind* 1)) (set! getopt:scan #f) getopt:opt) ((< *optind* (length *argv*)) (set! *optarg* (argref)) (set! *optind* (+ *optind* 1)) getopt:opt) ((and (not (null? opts)) (char=? #\: (car opts))) #\:) (else #\?)))))) ;@ (define (getopt-- optstring) (let* ((opt (getopt (string-append optstring "-:"))) (optarg *optarg*)) (cond ((eqv? #\- opt) ;long option (do ((l (string-length *optarg*)) (i 0 (+ 1 i))) ((or (>= i l) (char=? #\= (string-ref optarg i))) (cond ((>= i l) (set! *optarg* #f) optarg) (else (set! *optarg* (substring optarg (+ 1 i) l)) (substring optarg 0 i)))))) (else opt)))) slib-3b1/getparam.scm0000644001705200017500000002606210446076751012514 0ustar tbtb;;; "getparam.scm" convert getopt to passing parameters by name. ; Copyright 1995, 1996, 1997, 2001 Aubrey Jaffer ; ;Permission to copy this software, to modify it, to redistribute it, ;to distribute modified versions, and to use it for any purpose is ;granted, subject to the following restrictions and understandings. ; ;1. Any copy made of this software must include this copyright notice ;in full. ; ;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; ;3. In conjunction with products arising from the use of this ;material, there shall be no use of my name in any advertising, ;promotional, or sales literature without prior written consent in ;each case. (require 'getopt) (require 'coerce) (require 'parameters) (require 'rev4-optional-procedures) ; string-copy (require-if 'compiling 'printf) (require-if 'compiling 'common-list-functions) ;;@code{(require 'getopt-parameters)} ;;@ftindex getopt-parameters ;;@args optnames arities types aliases desc @dots{} ;;Returns @var{*argv*} converted to a parameter-list. @var{optnames} are ;;the parameter-names. @var{arities} and @var{types} are lists of symbols ;;corresponding to @var{optnames}. ;; ;;@var{aliases} is a list of lists of strings or integers paired with ;;elements of @var{optnames}. Each one-character string will be treated ;;as a single @samp{-} option by @code{getopt}. Longer strings will be ;;treated as long-named options (@pxref{Getopt, getopt--}). ;; ;;If the @var{aliases} association list has only strings as its ;;@code{car}s, then all the option-arguments after an option (and before ;;the next option) are adjoined to that option. ;; ;;If the @var{aliases} association list has integers, then each (string) ;;option will take at most one option-argument. Unoptioned arguments are ;;collected in a list. A @samp{-1} alias will take the last argument in ;;this list; @samp{+1} will take the first argument in the list. The ;;aliases -2 then +2; -3 then +3; @dots{} are tried so long as a positive ;;or negative consecutive alias is found and arguments remain in the list. ;;Finally a @samp{0} alias, if found, absorbs any remaining arguments. ;; ;;In all cases, if unclaimed arguments remain after processing, a warning ;;is signaled and #f is returned. (define (getopt->parameter-list optnames arities types aliases . description) (define (can-take-arg? opt) (not (eq? 'boolean (list-ref arities (position opt optnames))))) (let ((progname (list-ref *argv* (+ -1 *optind*))) (optlist '()) (long-opt-list '()) (optstring #f) (pos-args '()) (parameter-list (make-parameter-list optnames)) (curopt '*unclaimed-argument*) (positional? (assv 0 aliases)) (unclaimeds '())) (define (adjoin-val val curopt) (define ntyp (list-ref types (position curopt optnames))) (adjoin-parameters! parameter-list (list curopt (case ntyp ((expression) val) (else (coerce val ntyp)))))) (define (finish) (cond (positional? (set! unclaimeds (reverse unclaimeds)) (do ((idx 2 (+ 1 idx)) (alias+ (assv 1 aliases) (assv idx aliases)) (alias- (assv -1 aliases) (assv (- idx) aliases))) ((or (not (or alias+ alias-)) (null? unclaimeds))) (set! unclaimeds (reverse unclaimeds)) (cond (alias- (set! curopt (cadr alias-)) (adjoin-val (car unclaimeds) curopt) (set! unclaimeds (cdr unclaimeds)))) (set! unclaimeds (reverse unclaimeds)) (cond ((and alias+ (not (null? unclaimeds))) (set! curopt (cadr alias+)) (adjoin-val (car unclaimeds) curopt) (set! unclaimeds (cdr unclaimeds))))) (let ((alias (assv '0 aliases))) (cond (alias (set! curopt (cadr alias)) (for-each (lambda (unc) (adjoin-val unc curopt)) unclaimeds) (set! unclaimeds '())))))) (cond ((not (null? unclaimeds)) (getopt-barf "%s: Unclaimed argument '%s'" progname (car unclaimeds)) (apply parameter-list->getopt-usage progname optnames arities types aliases description)) (else parameter-list))) (set! aliases (map (lambda (alias) (cond ((string? (car alias)) (let ((str (string-copy (car alias)))) (do ((i (+ -1 (string-length str)) (+ -1 i))) ((negative? i) (cons str (cdr alias))) (cond ((char=? #\space (string-ref str i)) (string-set! str i #\-)))))) ((number? (car alias)) (set! positional? (car alias)) alias) (else alias))) aliases)) (for-each (lambda (alias) (define opt (car alias)) (cond ((number? opt) (set! pos-args (cons opt pos-args))) ((not (string? opt))) ((< 1 (string-length opt)) (set! long-opt-list (cons opt long-opt-list))) ((not (= 1 (string-length opt)))) ((can-take-arg? (cadr alias)) (set! optlist (cons (string-ref opt 0) (cons #\: optlist)))) (else (set! optlist (cons (string-ref opt 0) optlist))))) aliases) (set! optstring (list->string (cons #\: optlist))) (let loop () (let ((opt (getopt-- optstring))) (case opt ((#\: #\?) (getopt-barf (case opt ((#\:) "%s: argument missing after '-%c'") ((#\?) "%s: unrecognized option '-%c'")) progname getopt:opt) (apply parameter-list->getopt-usage progname optnames arities types aliases description)) ((#f) (cond ((and (< *optind* (length *argv*)) (string=? "-" (list-ref *argv* *optind*))) (set! *optind* (+ 1 *optind*)) (finish)) ((< *optind* (length *argv*)) (let ((topt (assoc curopt aliases))) (if topt (set! curopt (cadr topt))) (cond ((and positional? (not topt)) (set! unclaimeds (cons (list-ref *argv* *optind*) unclaimeds)) (set! *optind* (+ 1 *optind*)) (loop)) ((and (member curopt optnames) (adjoin-val (list-ref *argv* *optind*) curopt)) (set! *optind* (+ 1 *optind*)) (loop)) (else (slib:error 'getopt->parameter-list curopt (list-ref *argv* *optind*) 'not 'supported))))) (else (finish)))) (else (cond ((char? opt) (set! opt (string opt)))) (let ((topt (assoc opt aliases))) (if topt (set! topt (cadr topt))) (cond ((not topt) (getopt-barf "%s: '--%s' option not recognized" progname opt) (apply parameter-list->getopt-usage progname optnames arities types aliases description)) ((not (can-take-arg? topt)) (adjoin-parameters! parameter-list (list topt #t)) (loop)) (*optarg* (set! curopt topt) (adjoin-val *optarg* curopt) (loop)) (else ;;(getopt-barf "%s: '--%s' option expects '='" progname opt) ;;(apply parameter-list->getopt-usage progname optnames arities types aliases description) (set! curopt topt) (loop)))))))))) (define (getopt-barf . args) (require 'printf) (apply fprintf (current-error-port) args) (newline (current-error-port))) (define (parameter-list->getopt-usage comname optnames arities types aliases . description) (require 'printf) (require 'common-list-functions) (let ((aliast (map list optnames)) (strlen=1? (lambda (s) (= 1 (string-length s)))) (cep (current-error-port))) (for-each (lambda (alias) (let ((apr (assq (cadr alias) aliast))) (set-cdr! apr (cons (car alias) (cdr apr))))) aliases) (fprintf cep "Usage: %s [OPTION ARGUMENT ...] ..." comname) (do ((pos+ '()) (pos- '()) (idx 2 (+ 1 idx)) (alias+ (assv 1 aliases) (assv idx aliases)) (alias- (assv -1 aliases) (assv (- idx) aliases))) ((not (or alias+ alias-)) (for-each (lambda (alias) (fprintf cep " <%s>" (cadr alias))) (reverse pos+)) (let ((alias (assv 0 aliases))) (if alias (fprintf cep " <%s> ..." (cadr alias)))) (for-each (lambda (alias) (fprintf cep " <%s>" (cadr alias))) pos-)) (cond (alias- (set! pos- (cons alias- pos-)))) (cond (alias+ (set! pos+ (cons alias+ pos+))))) (fprintf cep "\\n\\n") (for-each (lambda (optname arity aliat) (let loop ((initials (remove-if-not strlen=1? (remove-if number? (cdr aliat)))) (longname (remove-if strlen=1? (remove-if number? (cdr aliat))))) (cond ((and (null? initials) (null? longname))) (else (fprintf cep (case arity ((boolean) " %3s %s\\n") (else " %3s %s<%s> %s\\n")) (if (null? initials) "" (string-append "-" (car initials) (if (null? longname) " " ","))) (if (null? longname) " " (string-append "--" (car longname) (case arity ((boolean) " ") (else "=")))) (case arity ((boolean) "") (else optname)) (case arity ((nary nary1) "...") (else ""))) (loop (if (null? initials) '() (cdr initials)) (if (null? longname) '() (cdr longname))))))) optnames arities aliast) (for-each (lambda (desc) (fprintf cep " %s\\n" desc)) description)) #f) ;;@args optnames positions arities types defaulters checks aliases desc @dots{} ;;Like @code{getopt->parameter-list}, but converts @var{*argv*} to an ;;argument-list as specified by @var{optnames}, @var{positions}, ;;@var{arities}, @var{types}, @var{defaulters}, @var{checks}, and ;;@var{aliases}. If the options supplied violate the @var{arities} or ;;@var{checks} constraints, then a warning is signaled and #f is returned. (define (getopt->arglist optnames positions arities types defaulters checks aliases . description) (define progname (list-ref *argv* (+ -1 *optind*))) (let* ((params (apply getopt->parameter-list optnames arities types aliases description)) (fparams (and params (fill-empty-parameters defaulters params)))) (cond ((and (list? params) (check-parameters checks fparams) (parameter-list->arglist positions arities fparams))) (params (apply parameter-list->getopt-usage progname optnames arities types aliases description)) (else #f)))) ;;@noindent ;;These @code{getopt} functions can be used with SLIB relational ;;databases. For an example, @xref{Using Databases, make-command-server}. ;; ;;@noindent ;;If errors are encountered while processing options, directions for using ;;the options (and argument strings @var{desc} @dots{}) are printed to ;;@code{current-error-port}. ;; ;;@example ;;(begin ;; (set! *optind* 1) ;; (set! *argv* '("cmd" "-?") ;; (getopt->parameter-list ;; '(flag number symbols symbols string flag2 flag3 num2 num3) ;; '(boolean optional nary1 nary single boolean boolean nary nary) ;; '(boolean integer symbol symbol string boolean boolean integer integer) ;; '(("flag" flag) ;; ("f" flag) ;; ("Flag" flag2) ;; ("B" flag3) ;; ("optional" number) ;; ("o" number) ;; ("nary1" symbols) ;; ("N" symbols) ;; ("nary" symbols) ;; ("n" symbols) ;; ("single" string) ;; ("s" string) ;; ("a" num2) ;; ("Abs" num3)))) ;;@print{} ;;Usage: cmd [OPTION ARGUMENT ...] ... ;; ;; -f, --flag ;; -o, --optional= ;; -n, --nary= ... ;; -N, --nary1= ... ;; -s, --single= ;; --Flag ;; -B ;; -a ... ;; --Abs= ... ;; ;;ERROR: getopt->parameter-list "unrecognized option" "-?" ;;@end example slib-3b1/getparam.txi0000644001705200017500000000572110747237372012537 0ustar tbtb@code{(require 'getopt-parameters)} @ftindex getopt-parameters @defun getopt->parameter-list optnames arities types aliases desc @dots{} Returns @var{*argv*} converted to a parameter-list. @var{optnames} are the parameter-names. @var{arities} and @var{types} are lists of symbols corresponding to @var{optnames}. @var{aliases} is a list of lists of strings or integers paired with elements of @var{optnames}. Each one-character string will be treated as a single @samp{-} option by @code{getopt}. Longer strings will be treated as long-named options (@pxref{Getopt, getopt--}). If the @var{aliases} association list has only strings as its @code{car}s, then all the option-arguments after an option (and before the next option) are adjoined to that option. If the @var{aliases} association list has integers, then each (string) option will take at most one option-argument. Unoptioned arguments are collected in a list. A @samp{-1} alias will take the last argument in this list; @samp{+1} will take the first argument in the list. The aliases -2 then +2; -3 then +3; @dots{} are tried so long as a positive or negative consecutive alias is found and arguments remain in the list. Finally a @samp{0} alias, if found, absorbs any remaining arguments. In all cases, if unclaimed arguments remain after processing, a warning is signaled and #f is returned. @end defun @defun getopt->arglist optnames positions arities types defaulters checks aliases desc @dots{} Like @code{getopt->parameter-list}, but converts @var{*argv*} to an argument-list as specified by @var{optnames}, @var{positions}, @var{arities}, @var{types}, @var{defaulters}, @var{checks}, and @var{aliases}. If the options supplied violate the @var{arities} or @var{checks} constraints, then a warning is signaled and #f is returned. @end defun @noindent These @code{getopt} functions can be used with SLIB relational databases. For an example, @xref{Using Databases, make-command-server}. @noindent If errors are encountered while processing options, directions for using the options (and argument strings @var{desc} @dots{}) are printed to @code{current-error-port}. @example (begin (set! *optind* 1) (set! *argv* '("cmd" "-?") (getopt->parameter-list '(flag number symbols symbols string flag2 flag3 num2 num3) '(boolean optional nary1 nary single boolean boolean nary nary) '(boolean integer symbol symbol string boolean boolean integer integer) '(("flag" flag) ("f" flag) ("Flag" flag2) ("B" flag3) ("optional" number) ("o" number) ("nary1" symbols) ("N" symbols) ("nary" symbols) ("n" symbols) ("single" string) ("s" string) ("a" num2) ("Abs" num3)))) @print{} Usage: cmd [OPTION ARGUMENT ...] ... -f, --flag -o, --optional= -n, --nary= ... -N, --nary1= ... -s, --single= --Flag -B -a ... --Abs= ... ERROR: getopt->parameter-list "unrecognized option" "-?" @end example slib-3b1/glob.scm0000644001705200017500000002640610733635503011634 0ustar tbtb;;; "glob.scm" String matching for filenames (a la BASH). ;;; Copyright (C) 1998 Radey Shouman. ; ;Permission to copy this software, to modify it, to redistribute it, ;to distribute modified versions, and to use it for any purpose is ;granted, subject to the following restrictions and understandings. ; ;1. Any copy made of this software must include this copyright notice ;in full. ; ;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; ;3. In conjunction with products arising from the use of this ;material, there shall be no use of my name in any advertising, ;promotional, or sales literature without prior written consent in ;each case. ;;@code{(require 'filename)} ;;@ftindex filename ;;@ftindex glob (define (glob:pattern->tokens pat) (cond ((string? pat) (let loop ((i 0) (toks '())) (if (>= i (string-length pat)) (reverse toks) (let ((pch (string-ref pat i))) (case pch ((#\? #\*) (loop (+ i 1) (cons (substring pat i (+ i 1)) toks))) ((#\[) (let ((j (let search ((j (+ i 2))) (cond ((>= j (string-length pat)) (slib:error 'glob:make-matcher "unmatched [" pat)) ((char=? #\] (string-ref pat j)) (if (and (< (+ j 1) (string-length pat)) (char=? #\] (string-ref pat (+ j 1)))) (+ j 1) j)) (else (search (+ j 1))))))) (loop (+ j 1) (cons (substring pat i (+ j 1)) toks)))) (else (let search ((j (+ i 1))) (cond ((= j (string-length pat)) (loop j (cons (substring pat i j) toks))) ((memv (string-ref pat j) '(#\? #\* #\[)) (loop j (cons (substring pat i j) toks))) (else (search (+ j 1))))))))))) ((pair? pat) (for-each (lambda (elt) (or (string? elt) (slib:error 'glob:pattern->tokens "bad pattern" pat))) pat) pat) (else (slib:error 'glob:pattern->tokens "bad pattern" pat)))) (define (glob:make-matcher pat ch=? ch<=?) (define (match-end str k kmatch) (and (= k (string-length str)) (reverse (cons k kmatch)))) (define (match-str pstr nxt) (let ((plen (string-length pstr))) (lambda (str k kmatch) (and (<= (+ k plen) (string-length str)) (let loop ((i 0)) (cond ((= i plen) (nxt str (+ k plen) (cons k kmatch))) ((ch=? (string-ref pstr i) (string-ref str (+ k i))) (loop (+ i 1))) (else #f))))))) (define (match-? nxt) (lambda (str k kmatch) (and (< k (string-length str)) (nxt str (+ k 1) (cons k kmatch))))) (define (match-set1 chrs) (let recur ((i 0)) (cond ((= i (string-length chrs)) (lambda (ch) #f)) ((and (< (+ i 2) (string-length chrs)) (char=? #\- (string-ref chrs (+ i 1)))) (let ((nxt (recur (+ i 3)))) (lambda (ch) (or (and (ch<=? ch (string-ref chrs (+ i 2))) (ch<=? (string-ref chrs i) ch)) (nxt ch))))) (else (let ((nxt (recur (+ i 1))) (chrsi (string-ref chrs i))) (lambda (ch) (or (ch=? chrsi ch) (nxt ch)))))))) (define (match-set tok nxt) (let ((chrs (substring tok 1 (- (string-length tok) 1)))) (if (and (positive? (string-length chrs)) (memv (string-ref chrs 0) '(#\^ #\!))) (let ((pred (match-set1 (substring chrs 1 (string-length chrs))))) (lambda (str k kmatch) (and (< k (string-length str)) (not (pred (string-ref str k))) (nxt str (+ k 1) (cons k kmatch))))) (let ((pred (match-set1 chrs))) (lambda (str k kmatch) (and (< k (string-length str)) (pred (string-ref str k)) (nxt str (+ k 1) (cons k kmatch)))))))) (define (match-* nxt) (lambda (str k kmatch) (let ((kmatch (cons k kmatch))) (let loop ((kk (string-length str))) (and (>= kk k) (or (nxt str kk kmatch) (loop (- kk 1)))))))) (let ((matcher (let recur ((toks (glob:pattern->tokens pat))) (if (null? toks) match-end (let ((pch (or (string=? (car toks) "") (string-ref (car toks) 0)))) (case pch ((#\?) (match-? (recur (cdr toks)))) ((#\*) (match-* (recur (cdr toks)))) ((#\[) (match-set (car toks) (recur (cdr toks)))) (else (match-str (car toks) (recur (cdr toks)))))))))) (lambda (str) (matcher str 0 '())))) (define (glob:caller-with-matches pat proc ch=? ch<=?) (define (glob:wildcard? pat) (cond ((string=? pat "") #f) ((memv (string-ref pat 0) '(#\* #\? #\[)) #t) (else #f))) (let* ((toks (glob:pattern->tokens pat)) (wild? (map glob:wildcard? toks)) (matcher (glob:make-matcher toks ch=? ch<=?))) (lambda (str) (let loop ((inds (matcher str)) (wild? wild?) (res '())) (cond ((not inds) #f) ((null? wild?) (apply proc (reverse res))) ((car wild?) (loop (cdr inds) (cdr wild?) (cons (substring str (car inds) (cadr inds)) res))) (else (loop (cdr inds) (cdr wild?) res))))))) (define (glob:make-substituter pattern template ch=? ch<=?) (define (wildcard? pat) (cond ((string=? pat "") #f) ((memv (string-ref pat 0) '(#\* #\? #\[)) #t) (else #f))) (define (countq val lst) (do ((lst lst (cdr lst)) (c 0 (if (eq? val (car lst)) (+ c 1) c))) ((null? lst) c))) (let ((tmpl-literals (map (lambda (tok) (if (wildcard? tok) #f tok)) (glob:pattern->tokens template))) (pat-wild? (map wildcard? (glob:pattern->tokens pattern))) (matcher (glob:make-matcher pattern ch=? ch<=?))) (or (= (countq #t pat-wild?) (countq #f tmpl-literals)) (slib:error 'glob:make-substituter "number of wildcards doesn't match" pattern template)) (lambda (str) (let ((indices (matcher str))) (and indices (let loop ((inds indices) (wild? pat-wild?) (lits tmpl-literals) (res '())) (cond ((null? lits) (apply string-append (reverse res))) ((car lits) (loop inds wild? (cdr lits) (cons (car lits) res))) ((null? wild?) ;this should never happen. (loop '() '() lits res)) ((car wild?) (loop (cdr inds) (cdr wild?) (cdr lits) (cons (substring str (car inds) (cadr inds)) res))) (else (loop (cdr inds) (cdr wild?) lits res))))))))) ;;@body ;;Returns a predicate which returns a non-false value if its string argument ;;matches (the string) @var{pattern}, false otherwise. Filename matching ;;is like ;;@cindex glob ;;@dfn{glob} expansion described the bash manpage, except that names ;;beginning with @samp{.} are matched and @samp{/} characters are not ;;treated specially. ;; ;;These functions interpret the following characters specially in ;;@var{pattern} strings: ;;@table @samp ;;@item * ;;Matches any string, including the null string. ;;@item ? ;;Matches any single character. ;;@item [@dots{}] ;;Matches any one of the enclosed characters. A pair of characters ;;separated by a minus sign (-) denotes a range; any character lexically ;;between those two characters, inclusive, is matched. If the first ;;character following the @samp{[} is a @samp{!} or a @samp{^} then any ;;character not enclosed is matched. A @samp{-} or @samp{]} may be ;;matched by including it as the first or last character in the set. ;;@end table (define (filename:match?? pattern) (glob:make-matcher pattern char=? char<=?)) (define (filename:match-ci?? pattern) (glob:make-matcher pattern char-ci=? char-ci<=?)) ;;@args pattern template ;;Returns a function transforming a single string argument according to ;;glob patterns @var{pattern} and @var{template}. @var{pattern} and ;;@var{template} must have the same number of wildcard specifications, ;;which need not be identical. @var{pattern} and @var{template} may have ;;a different number of literal sections. If an argument to the function ;;matches @var{pattern} in the sense of @code{filename:match??} then it ;;returns a copy of @var{template} in which each wildcard specification is ;;replaced by the part of the argument matched by the corresponding ;;wildcard specification in @var{pattern}. A @code{*} wildcard matches ;;the longest leftmost string possible. If the argument does not match ;;@var{pattern} then false is returned. ;; ;;@var{template} may be a function accepting the same number of string ;;arguments as there are wildcard specifications in @var{pattern}. In ;;the case of a match the result of applying @var{template} to a list ;;of the substrings matched by wildcard specifications will be returned, ;;otherwise @var{template} will not be called and @code{#f} will be returned. (define (filename:substitute?? pattern template) (cond ((procedure? template) (glob:caller-with-matches pattern template char=? char<=?)) ((string? template) (glob:make-substituter pattern template char=? char<=?)) (else (slib:error 'filename:substitute?? "bad second argument" template)))) (define (filename:substitute-ci?? pattern template) (cond ((procedure? template) (glob:caller-with-matches pattern template char-ci=? char-ci<=?)) ((string? template) (glob:make-substituter pattern template char-ci=? char-ci<=?)) (else (slib:error 'filename:substitute-ci?? "bad second argument" template)))) ;;@example ;;((filename:substitute?? "scm_[0-9]*.html" "scm5c4_??.htm") ;; "scm_10.html") ;;@result{} "scm5c4_10.htm" ;;((filename:substitute?? "??" "beg?mid?end") "AZ") ;;@result{} "begAmidZend" ;;((filename:substitute?? "*na*" "?NA?") "banana") ;;@result{} "banaNA" ;;((filename:substitute?? "?*?" (lambda (s1 s2 s3) (string-append s3 s1))) ;; "ABZ") ;;@result{} "ZA" ;;@end example ;;@body ;;@var{str} can be a string or a list of strings. Returns a new string ;;(or strings) similar to @code{str} but with the suffix string @var{old} ;;removed and the suffix string @var{new} appended. If the end of ;;@var{str} does not match @var{old}, an error is signaled. (define (replace-suffix str old new) (let* ((f (glob:make-substituter (list "*" old) (list "*" new) char=? char<=?)) (g (lambda (st) (or (f st) (slib:error 'replace-suffix "suffix doesn't match:" old st))))) (if (pair? str) (map g str) (g str)))) ;;@example ;;(replace-suffix "/usr/local/lib/slib/batch.scm" ".scm" ".c") ;;@result{} "/usr/local/lib/slib/batch.c" ;;@end example ;;@args proc k ;;@args proc ;;Calls @1 with @2 arguments, strings returned by successive calls to ;;@code{tmpnam}. ;;If @1 returns, then any files named by the arguments to @1 are ;;deleted automatically and the value(s) yielded by the @1 is(are) ;;returned. @2 may be ommited, in which case it defaults to @code{1}. ;; ;;@args proc suffix1 ... ;;Calls @1 with strings returned by successive calls to @code{tmpnam}, ;;each with the corresponding @var{suffix} string appended. ;;If @1 returns, then any files named by the arguments to @1 are ;;deleted automatically and the value(s) yielded by the @1 is(are) ;;returned. (define (call-with-tmpnam proc . suffi) (define (do-call paths) (let ((ans (apply proc paths))) (for-each (lambda (path) (if (file-exists? path) (delete-file path))) paths) ans)) (cond ((null? suffi) (do-call (list (tmpnam)))) ((and (= 1 (length suffi)) (number? (car suffi))) (do ((cnt (if (null? suffi) 0 (+ -1 (car suffi))) (+ -1 cnt)) (paths '() (cons (tmpnam) paths))) ((negative? cnt) (do-call paths)))) (else (do-call (map (lambda (suffix) (string-append (tmpnam) suffix)) suffi))))) slib-3b1/glob.txi0000644001705200017500000000740710747237372011665 0ustar tbtb@code{(require 'filename)} @ftindex filename @ftindex glob @defun filename:match?? pattern @defunx filename:match-ci?? pattern Returns a predicate which returns a non-false value if its string argument matches (the string) @var{pattern}, false otherwise. Filename matching is like @cindex glob @dfn{glob} expansion described the bash manpage, except that names @cindex glob beginning with @samp{.} are matched and @samp{/} characters are not treated specially. These functions interpret the following characters specially in @var{pattern} strings: @table @samp @item * Matches any string, including the null string. @item ? Matches any single character. @item [@dots{}] Matches any one of the enclosed characters. A pair of characters separated by a minus sign (-) denotes a range; any character lexically between those two characters, inclusive, is matched. If the first character following the @samp{[} is a @samp{!} or a @samp{^} then any character not enclosed is matched. A @samp{-} or @samp{]} may be matched by including it as the first or last character in the set. @end table @end defun @defun filename:substitute?? pattern template @defunx filename:substitute-ci?? pattern template Returns a function transforming a single string argument according to glob patterns @var{pattern} and @var{template}. @var{pattern} and @var{template} must have the same number of wildcard specifications, which need not be identical. @var{pattern} and @var{template} may have a different number of literal sections. If an argument to the function matches @var{pattern} in the sense of @code{filename:match??} then it returns a copy of @var{template} in which each wildcard specification is replaced by the part of the argument matched by the corresponding wildcard specification in @var{pattern}. A @code{*} wildcard matches the longest leftmost string possible. If the argument does not match @var{pattern} then false is returned. @var{template} may be a function accepting the same number of string arguments as there are wildcard specifications in @var{pattern}. In the case of a match the result of applying @var{template} to a list of the substrings matched by wildcard specifications will be returned, otherwise @var{template} will not be called and @code{#f} will be returned. @end defun @example ((filename:substitute?? "scm_[0-9]*.html" "scm5c4_??.htm") "scm_10.html") @result{} "scm5c4_10.htm" ((filename:substitute?? "??" "beg?mid?end") "AZ") @result{} "begAmidZend" ((filename:substitute?? "*na*" "?NA?") "banana") @result{} "banaNA" ((filename:substitute?? "?*?" (lambda (s1 s2 s3) (string-append s3 s1))) "ABZ") @result{} "ZA" @end example @defun replace-suffix str old new @var{str} can be a string or a list of strings. Returns a new string (or strings) similar to @code{str} but with the suffix string @var{old} removed and the suffix string @var{new} appended. If the end of @var{str} does not match @var{old}, an error is signaled. @end defun @example (replace-suffix "/usr/local/lib/slib/batch.scm" ".scm" ".c") @result{} "/usr/local/lib/slib/batch.c" @end example @defun call-with-tmpnam proc k @defunx call-with-tmpnam proc Calls @var{proc} with @var{k} arguments, strings returned by successive calls to @code{tmpnam}. If @var{proc} returns, then any files named by the arguments to @var{proc} are deleted automatically and the value(s) yielded by the @var{proc} is(are) returned. @var{k} may be ommited, in which case it defaults to @code{1}. @defunx call-with-tmpnam proc suffix1 @dots{} Calls @var{proc} with strings returned by successive calls to @code{tmpnam}, each with the corresponding @var{suffix} string appended. If @var{proc} returns, then any files named by the arguments to @var{proc} are deleted automatically and the value(s) yielded by the @var{proc} is(are) returned. @end defun slib-3b1/grapheps.ps0000644001705200017500000002730210521176346012356 0ustar tbtb/plotdict 100 dict def plotdict begin % Get dimensions the preamble left on the stack. 4 array astore /whole-page exch def % Definitions so that internal assignments are bound before setting. /DATA 0 def /DEN 0 def /DIAG 0 def /DIAG2 0 def /DLTA 0 def /EXPSN 0 def /GPROCS 0 def /GD 6 def /GR 3 def /IDX 0 def /ISIZ 0 def /MAX 0 def /MIN 0 def /NUM 0 def /PLOT-bmargin 0 def /PLOT-lmargin 0 def /PLOT-rmargin 0 def /PLOT-tmargin 0 def /PROC 0 def /ROW 0 def /TXT 0 def /WPAGE 0 def /X-COORD 0 def /XDX 0 def /XOFF 0 def /XPARTS 0 def /XRNG 0 def /XSCL 0 def /XSTEP 0 def /XSTEPH 0 def /XTSCL 0 def /XWID 0 def /Y-COORD 0 def /YDX 0 def /YHIT 0 def /YOFF 0 def /YPARTS 0 def /YRNG 0 def /YSCL 0 def /YSTEP 0 def /YSTEPH 0 def /YTSCL 0 def /STP3 0 def /STP2 0 def /SCL 0 def /graphrect 0 def /plotrect 0 def % Here are the procedure-arrays for passing as the third argument to % plot-column. Plot-column moves to the first coordinate before % calls to the first procedure. Thus both line and scatter graphs are % supported. Many additional glyph types can be produced as % combinations of these types. This is best accomplished by calling % plot-column with each component. % GD and GR are the graphic-glyph diameter and radius. % DIAG and DIAG2, used in /cross are diagonal and twice diagonal. % gtrans maps x, y coordinates on the stack to 72dpi page coordinates. % Render line connecting points /line [{} {lineto} {}] bind def /mountain [{currentpoint 2 copy pop bottomedge moveto lineto} {lineto} {currentpoint pop bottomedge lineto closepath fill}] bind def /cloud [{currentpoint 2 copy pop topedge moveto lineto} {lineto} {currentpoint pop topedge lineto closepath fill}] bind def % Render lines from x-axis to points /impulse [{} {moveto XRNG 0 get 0 gtrans exch pop currentpoint pop exch lineto} {}] bind def /bargraph [{} {exch GR sub exch dup XRNG 0 get 0 gtrans exch pop % y=0 exch sub GD exch rectstroke} {}] bind def % Solid round dot. /disc [{GD setlinewidth 1 setlinecap} {moveto 0 0 rlineto} {}] bind def % Minimal point -- invisible if linewidth is 0. /point [{1 setlinecap} {moveto 0 0 rlineto} {}] bind def % Square box. /square [{} {GR sub exch GR sub exch GD dup rectstroke} {}] bind def % Square box at 45.o /diamond [{} {2 copy GR add moveto GR neg GR neg rlineto GR GR neg rlineto GR GR rlineto GR neg GR rlineto closepath} {}] bind def % Plus Sign /plus [{} { GR sub moveto 0 GD rlineto GR neg GR neg rmoveto GD 0 rlineto} {}] bind def % X Sign /cross [{/DIAG GR .707 mul def /DIAG2 DIAG 2 mul def} {exch DIAG sub exch DIAG add moveto DIAG2 dup neg rlineto DIAG2 neg 0 rmoveto DIAG2 dup rlineto} {}] bind def % Triangle pointing upward /triup [{} {GR 1.12 mul add moveto GR neg GR -1.62 mul rlineto GR 2 mul 0 rlineto GR neg GR 1.62 mul rlineto closepath} {}] bind def % Triangle pointing downward /tridown [{} {GR 1.12 mul sub moveto GR neg GR 1.62 mul rlineto GR 2 mul 0 rlineto GR neg GR -1.62 mul rlineto closepath} {}] bind def /pentagon [{} {gsave translate 0 GR moveto 4 {72 rotate 0 GR lineto} repeat closepath stroke grestore} {}] bind def /circle [{stroke} {GR 0 360 arc stroke} {}] bind def % ( TITLE ) ( SUBTITLE ) /title-top { dup stringwidth pop -2 div plotrect 0 get plotrect 2 get 2 div add add plotrect 1 get plotrect 3 get add pointsize .4 mul add moveto show dup stringwidth pop -2 div plotrect 0 get plotrect 2 get 2 div add add plotrect 1 get plotrect 3 get add pointsize 1.4 mul add moveto show } bind def % ( TITLE ) ( SUBTITLE ) /title-bottom { dup stringwidth pop -2 div plotrect 0 get plotrect 2 get 2 div add add plotrect 1 get pointsize -2 mul add moveto show dup stringwidth pop -2 div plotrect 0 get plotrect 2 get 2 div add add plotrect 1 get pointsize -1 mul add moveto show } bind def % Plots column K against column J of given two-dimensional ARRAY. % The arguments are: % [ ARRAY J K ] J and K are column-indexes into ARRAY % [ PREAMBLE RENDER POSTAMBLE ] Plotting procedures: % PREAMBLE - Executed once before plotting row % RENDER - Called with each pair of coordinates to plot % POSTAMBLE - Called once after plotting row (often does stroke) /plot-column { /GPROCS exch def aload pop /YDX exch def /XDX exch def /DATA exch def /GD glyphsize def /GR GD .5 mul def gsave /ROW DATA 0 get def ROW XDX get ROW YDX get gtrans moveto GPROCS 0 get exec % preamble /PROC GPROCS 1 get def DATA {dup XDX get exch YDX get gtrans PROC} forall GPROCS 2 get exec stroke % postamble grestore } bind def /partition-page { /YPARTS exch def /XPARTS exch def /WPAGE exch def /XWID WPAGE 2 get XPARTS div def /YHIT WPAGE 3 get YPARTS div def /Y-COORD WPAGE 1 get def YPARTS { /X-COORD WPAGE 0 get WPAGE 2 get add XWID sub def XPARTS {[X-COORD Y-COORD XWID YHIT] /X-COORD X-COORD XWID sub def} repeat /Y-COORD Y-COORD YHIT add def } repeat } bind def /fudge3 % SCL STP3 STP2 { /STP2 exch def /STP3 exch def /SCL exch def SCL 3 mod 0 eq {STP3} {STP2} ifelse %% leads to range error in CVS. % SCL abs 3000 gt {STP2} {SCL 3 mod 0 eq {STP3} {STP2} ifelse} ifelse } bind def % The arguments are: % [ MIN-X MIN-Y DELTA-X DELTA-Y ] whole graph rectangle % [ MIN-COLJ MAX-COLJ ] Numerical range of plot data % [ MIN-COLK MAX-COLK ] Numerical range of plot data % and the implicit current clippath /setup-plot { /YRNG exch def /XRNG exch def /graphrect exch def /PLOT-bmargin pointsize 2.4 mul def /PLOT-tmargin pointsize 2.4 mul def /PLOT-lmargin lmargin-template stringwidth pop pointsize 1.2 mul add def /PLOT-rmargin rmargin-template stringwidth pop pointsize 1.2 mul add def /plotrect [ graphrect 0 get PLOT-lmargin add graphrect 1 get PLOT-bmargin add graphrect 2 get PLOT-lmargin sub PLOT-rmargin sub graphrect 3 get PLOT-bmargin sub PLOT-tmargin sub ] def /XOFF XRNG 0 get def /YOFF YRNG 0 get def /XSCL plotrect 2 get XRNG aload pop exch sub div def /YSCL plotrect 3 get YRNG aload pop exch sub div def /XOFF XOFF plotrect 0 get XSCL div sub def /YOFF YOFF plotrect 1 get YSCL div sub def /YTSCL plotrect 3 get YRNG aload pop exch sub abs find-tick-scale def /YSTEP YTSCL 0 get 6 8 fudge3 5 mul yuntrans YSCL sign mul def /XTSCL plotrect 2 get XRNG aload pop exch sub abs find-tick-scale def /XSTEP XTSCL 0 get 12 10 fudge3 5 mul xuntrans XSCL sign mul def /YSTEPH YSTEP 2 div def /XSTEPH XSTEP 2 div def } bind def % gtrans is the utility routine mapping data coordinates to view space. % plot-column sets up XOFF, XSCL, and YSCL and uses it. /gtrans {exch XOFF sub XSCL mul exch YOFF sub YSCL mul} bind def %/guntrans {exch XSCL div XOFF add exch YSCL div YOFF add} bind def % /ytrans {YTSCL aload pop div mul} bind def % /xtrans {XTSCL aload pop div mul} bind def /yuntrans {YTSCL aload pop exch div mul} bind def /xuntrans {XTSCL aload pop exch div mul} bind def /sign {dup 0 lt {pop -1} {0 gt {1} {0} ifelse} ifelse} bind def /zero-in-range? {dup 0 get 0 le exch 1 get 0 ge and} bind def /y-axis { XRNG zero-in-range? { 0 YRNG 0 get gtrans moveto 0 YRNG 1 get gtrans lineto stroke} if } bind def /x-axis { YRNG zero-in-range? {XRNG 0 get 0 gtrans moveto XRNG 1 get 0 gtrans lineto stroke} if } bind def % Find data range in column K of two-dimensional ARRAY. % ARRAY % K is the column-index into ARRAY /column-range { /IDX exch def dup /MIN exch 0 get IDX get def /MAX MIN def {IDX get dup dup MIN lt {/MIN exch def} {pop} ifelse dup MAX gt {/MAX exch def} {pop} ifelse} forall [MIN MAX] } bind def /min {2 copy lt {pop} {exch pop} ifelse} bind def /max {2 copy gt {pop} {exch pop} ifelse} bind def /combine-ranges { aload pop 3 2 roll aload pop exch 4 3 roll min 3 1 roll max 2 array astore} bind def /pad-range { exch aload pop /MAX exch def /MIN exch def /EXPSN exch 100 div MAX MIN sub mul def [ MIN EXPSN sub MAX EXPSN add ] } bind def /snap-range {dup aload pop exch sub 1 exch find-tick-scale aload pop /DEN exch def /NUM exch def 1 NUM div DEN mul /DLTA exch def aload pop /MAX exch def /MIN exch def [ DLTA MAX MIN sub sub 2 div dup MIN exch sub exch MAX add ] } bind def % Given the width (or height) and the data-span, returns an array of % numerator and denominator [NUM DEN] % % NUM will be 1, 2, 3, 4, 5, 6, or 8 times a power of ten. % DEN will be a power of ten. % % NUM ISIZ % === < ==== % DEN DLTA /find-tick-scale {/DLTA exch def /ISIZ exch def /DEN 1 def {DLTA abs ISIZ le {exit} if /DEN DEN 10 mul def /ISIZ ISIZ 10 mul def} loop /NUM 1 def {DLTA abs 10 mul ISIZ ge {exit} if /NUM NUM 10 mul def /DLTA DLTA 10 mul def} loop [[8 6 5 4 3 2 1] {/MAX exch def MAX DLTA mul ISIZ le {MAX exit} if} forall NUM mul DEN] } bind def /rule-vertical { /XWID exch def /TXT exch def /X-COORD exch def X-COORD type [] type eq {/X-COORD X-COORD 0 get def} if gsave X-COORD plotrect 1 get plotrect 3 get 2 div add translate TXT stringwidth pop -2 div XWID 0 gt { 90 rotate PLOT-lmargin} {-90 rotate PLOT-rmargin} ifelse pointsize 1.2 mul sub moveto TXT show grestore YRNG 0 get YSTEP div ceiling YSTEP mul YSTEP YRNG 1 get { /YDX exch def 0 YDX gtrans /Y-COORD exch def pop X-COORD Y-COORD moveto XWID 0 rlineto stroke /TXT YDX 20 string cvs def X-COORD XWID 0 gt {TXT stringwidth pop sub ( ) stringwidth pop sub Y-COORD pointsize .3 mul sub moveto} {Y-COORD pointsize .3 mul sub moveto ( ) show} ifelse TXT show} for YRNG 0 get YSTEPH div ceiling YSTEPH mul YSTEPH YRNG 1 get { /YDX exch def 0 YDX gtrans /Y-COORD exch def pop X-COORD Y-COORD moveto XWID 2 div 0 rlineto stroke} for } bind def /rule-horizontal { /YHIT exch def /TXT exch def /Y-COORD exch def Y-COORD type [] type eq {/Y-COORD Y-COORD 1 get def} if plotrect 0 get plotrect 2 get 2 div add TXT stringwidth pop -2 div add Y-COORD YHIT 0 gt {pointsize -2 mul} {pointsize 1.4 mul} ifelse add moveto TXT show XRNG 0 get XSTEP div ceiling XSTEP mul XSTEP XRNG 1 get { dup 0 gtrans pop /X-COORD exch def X-COORD Y-COORD moveto 0 YHIT rlineto stroke /TXT exch 10 string cvs def X-COORD TXT stringwidth pop 2.0 div sub Y-COORD YHIT 0 gt {pointsize sub} {pointsize .3 mul add} ifelse moveto TXT show } for XRNG 0 get XSTEPH div ceiling XSTEPH mul XSTEPH XRNG 1 get { 0 gtrans pop Y-COORD moveto 0 YHIT 2 div rlineto stroke} for } bind def /grid-verticals { XRNG 0 get XSTEPH div ceiling XSTEPH mul XSTEPH XRNG 1 get { 0 gtrans pop /X-COORD exch def X-COORD plotrect 1 get moveto 0 plotrect 3 get rlineto} for stroke } bind def /grid-horizontals { YRNG 0 get YSTEPH div ceiling YSTEPH mul YSTEPH YRNG 1 get { 0 exch gtrans /Y-COORD exch def pop plotrect 0 get Y-COORD moveto plotrect 2 get 0 rlineto} for stroke } bind def /leftedge {plotrect 0 get} bind def /rightedge {plotrect dup 0 get exch 2 get add} bind def /topedge {plotrect dup 1 get exch 3 get add} bind def /bottomedge {plotrect 1 get} bind def /outline-rect {aload pop rectstroke} bind def /fill-rect {aload pop rectfill} bind def /clip-to-rect {aload pop rectclip} bind def /gstack [] def /gpush {gsave /gstack [ gstack pointsize glyphsize ] def} bind def /gpop {/gstack gstack aload pop /glyphsize exch def /pointsize exch def def grestore} bind def % Default parameters % The legend-templates are strings used to reserve horizontal space /lmargin-template (-.0123456789) def /rmargin-template (-.0123456789) def % glyphsize is the graphic-glyph size; GR, graphic radius, is % glyphsize/2. Line width, set by "setlinewidth", must be much less % than glyphsize for readable glyphs. /glyphsize 6 def % pointsize is the height of text characters in "points", 1/72 inch; 0.353.mm /pointsize 12 def % Set default font /Helvetica pointsize selectfont gsave slib-3b1/grapheps.scm0000644001705200017500000005423410516553352012522 0ustar tbtb;;;; "grapheps.scm", Create PostScript Graphs ;;; Copyright (C) 2003 Aubrey Jaffer ; ;Permission to copy this software, to modify it, to redistribute it, ;to distribute modified versions, and to use it for any purpose is ;granted, subject to the following restrictions and understandings. ; ;1. Any copy made of this software must include this copyright notice ;in full. ; ;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; ;3. In conjunction with products arising from the use of this ;material, there shall be no use of my name in any advertising, ;promotional, or sales literature without prior written consent in ;each case. (require 'array) (require 'array-for-each) (require 'line-i/o) (require 'color) (require 'resene) (require 'saturate) (require 'filename) ;;@code{(require 'eps-graph)} ;; ;;@noindent ;;This is a graphing package creating encapsulated-PostScript files. ;;Its motivations and design choice are described in ;;@url{http://swiss.csail.mit.edu/~jaffer/Docupage/grapheps} ;; ;;@noindent ;;A dataset to be plotted is taken from a 2-dimensional array. ;;Corresponding coordinates are in rows. Coordinates from any ;;pair of columns can be plotted. ;;; String append which accepts numbers, symbols, vectors, and lists. (define (scheme->ps . args) (apply string-append (map (lambda (arg) (cond ((number? arg) (number->string arg)) ((symbol? arg) (symbol->string arg)) ((or (vector? arg) (list? arg)) (string-append "[ " (apply string-append (map (lambda (x) (scheme->ps x " ")) (if (vector? arg) (vector->list arg) arg))) "]")) (else arg))) args))) ;;; Capture for %%Title (define *plot-title* #f) ;; Remember arrays so each is output only once. (define *plot-arrays* '()) ;;@args filename.eps size elt1 ... ;;@1 should be a string naming an output file to be created. @2 ;;should be an exact integer, a list of two exact integers, or #f. ;;@3, ... are values returned by graphing primitives described here. ;; ;;@0 creates an @dfn{Encapsulated-PostScript} file named @1 containing ;;graphs as directed by the @3, ... arguments. ;; ;;The size of the graph is determined by the @2 argument. If a list ;;of two integers, they specify the width and height. If one integer, ;;then that integer is the width and the height is 3/4 of the width. ;;If #f, the graph will be 800 by 600. (define (create-postscript-graph filename size . args) (define xsize (cond ((pair? size) (car size)) ((number? size) size) (else 800))) (let ((ysize (if (and (pair? size) (pair? (cdr size))) (cadr size) (quotient (* 3 xsize) 4)))) (cond ((provided? 'inexact) (set! xsize (inexact->exact (round xsize))) (set! ysize (inexact->exact (round ysize))))) (call-with-output-file filename (lambda (oprt) (define (write-lines lines) (for-each (lambda (line) (if (list? line) (write-lines line) (write-line line oprt))) lines)) (write-line "%!PS-Adobe-3.0 EPSF-3.0" oprt) (write-line (scheme->ps "%%BoundingBox: 0 0 " xsize " " ysize) oprt) (write-line (scheme->ps "%%Title: " (or *plot-title* filename)) oprt) (write-line (scheme->ps "%%EndComments: ") oprt) (write-line (scheme->ps "0 0 " xsize " " ysize) oprt) (call-with-input-file (in-vicinity (library-vicinity) "grapheps.ps") (lambda (iprt) (do ((line (read-line iprt) (read-line iprt))) ((eof-object? line)) (write-line line oprt)))) (for-each (lambda (pair) (write-array-def (cdr pair) (car pair) oprt)) *plot-arrays*) (write-lines args) (newline oprt) (write-line "grestore" oprt) (write-line "end" oprt) (write-line "showpage" oprt))) (set! *plot-title* #f) (set! *plot-arrays* '()))) (define (write-array-def name array oprt) (define row-length (cadr (array-dimensions array))) (define idx 0) (set! idx row-length) (write-line (scheme->ps "/" name) oprt) (write-line "[" oprt) (display " [" oprt) (array-for-each (lambda (elt) (cond ((zero? idx) (write-line "]" oprt) (display " [" oprt))) (display (scheme->ps " " elt) oprt) (set! idx (modulo (+ 1 idx) row-length))) array) (write-line "]" oprt) (write-line "] def" oprt)) ;;; Arrays are named and cached in *plot-arrays*. (define (import-array array) (cond ((assq array *plot-arrays*) => cdr) (else (let ((name (gentemp))) (set! *plot-arrays* (cons (cons array name) *plot-arrays*)) name)))) ;;@noindent ;;These graphing procedures should be called as arguments to ;;@code{create-postscript-graph}. The order of these arguments is ;;significant; PostScript graphics state is affected serially from the ;;first @var{elt} argument to the last. ;;@body ;;Pushes a rectangle for the whole encapsulated page onto the ;;PostScript stack. This pushed rectangle is an implicit argument to ;;@code{partition-page} or @code{setup-plot}. (define (whole-page) 'whole-page) ;;@menu ;;* Column Ranges:: ;;* Drawing the Graph:: ;;* Graphics Context:: ;;* Rectangles:: ;;* Legending:: ;;* Legacy Plotting:: ;;* Example Graph:: ;;@end menu ;; ;;@node Column Ranges, Drawing the Graph, PostScript Graphing, PostScript Graphing ;;@subsubsection Column Ranges ;;@noindent ;;A @dfn{range} is a list of two numbers, the minimum and the maximum. ;;@cindex range ;;Ranges can be given explicity or computed in PostScript by ;;@code{column-range}. ;;@body ;;Returns the range of values in 2-dimensional @1 column @2. (define (column-range array k) (set! array (import-array array)) (scheme->ps array " " k " column-range")) ;;@body ;;Expands @1 by @2/100 on each end. (define (pad-range range p) (scheme->ps range " " p " pad-range")) ;;@body ;;Expands @1 to round number of ticks. (define (snap-range range) (scheme->ps range " snap-range")) ;;@args range1 range2 ... ;;Returns the minimal range covering all @1, @2, ... (define (combine-ranges rng1 . rngs) (define (loop rngs) (cond ((null? rngs) "") (else (scheme->ps " " (car rngs) (loop (cdr rngs)) " combine-ranges")))) (scheme->ps rng1 (loop rngs))) ;;@args x-range y-range pagerect ;;@args x-range y-range ;;@1 and @2 should each be a list of two numbers or the value returned ;;by @code{pad-range}, @code{snap-range}, or @code{combine-range}. ;;@3 is the rectangle bounding the graph to be drawn; if missing, the ;;rectangle from the top of the PostScript stack is popped and used. ;; ;;Based on the given ranges, @0 sets up scaling and margins for making ;;a graph. The margins are sized proportional to the @var{fontheight} ;;value at the time of the call to setup-plot. @0 sets two variables: ;; ;;@table @var ;;@item plotrect ;;The region where data points will be plotted. ;;@item graphrect ;;The @3 argument to @0. Includes plotrect, legends, etc. ;;@end table (define (setup-plot xrange yrange . pagerect) (if (null? pagerect) (scheme->ps xrange " " yrange " setup-plot") (scheme->ps (car pagerect) " " xrange " " yrange " setup-plot"))) ;;@node Drawing the Graph, Graphics Context, Column Ranges, PostScript Graphing ;;@subsubsection Drawing the Graph ;;@body ;;Plots points with x coordinate in @2 of @1 and y coordinate @3 of ;;@1. The symbol @4 specifies the type of glyph or drawing style for ;;presenting these coordinates. (define (plot-column array x-column y-column proc3s) (set! array (import-array array)) (scheme->ps "[ " array " " x-column " " y-column " ] " proc3s " plot-column")) ;;@noindent ;;The glyphs and drawing styles available are: ;; ;;@table @code ;;@item line ;;Draws line connecting points in order. ;;@item mountain ;;Fill area below line connecting points. ;;@item cloud ;;Fill area above line connecting points. ;;@item impulse ;;Draw line from x-axis to each point. ;;@item bargraph ;;Draw rectangle from x-axis to each point. ;;@item disc ;;Solid round dot. ;;@item point ;;Minimal point -- invisible if linewidth is 0. ;;@item square ;;Square box. ;;@item diamond ;;Square box at 45.o ;;@item plus ;;Plus sign. ;;@item cross ;;X sign. ;;@item triup ;;Triangle pointing upward ;;@item tridown ;;Triangle pointing downward ;;@item pentagon ;;Five sided polygon ;;@item circle ;;Hollow circle ;;@end table ;;@node Graphics Context, Rectangles, Drawing the Graph, PostScript Graphing ;;@subsubsection Graphics Context ;;@body ;;Saves the current graphics state, executes @1, then restores ;;to saved graphics state. (define (in-graphic-context . args) (append '("gpush") args '("gpop"))) ;;@args color ;;@1 should be a string naming a Resene color, a saturate color, or a ;;number between 0 and 100. ;; ;;@0 sets the PostScript color to the color of the given string, or a ;;grey value between black (0) and white (100). (define (set-color clrn) (define clr (cond ((color? clrn) clrn) ((number? clrn) (* 255/100 clrn)) ((or (eq? 'black clrn) (and (string? clrn) (string-ci=? "black" clrn))) 0) ((or (eq? 'white clrn) (and (string? clrn) (string-ci=? "white" clrn))) 255) (else (or (saturate clrn) (resene clrn) (string->color (if (symbol? clrn) (symbol->string clrn) clrn)))))) (define (num->str x) (define num (inexact->exact (round (+ 1000 (* x 999/255))))) (scheme->ps "." (substring (number->string num) 1 4) " ")) (cond ((number? clr) (string-append (num->str clr) " setgray")) (clr (apply scheme->ps (append (map num->str (color->sRGB clr)) '(setrgbcolor)))) (else ""))) ;;@body ;;@1 should be a (case-sensitive) string naming a PostScript font. ;;@2 should be a positive real number. ;; ;;@0 Changes the current PostScript font to @1 with height equal to ;;@2. The default font is Helvetica (12pt). (define (set-font name fontheight) (scheme->ps "/fontsize " fontheight " def /" name " fontsize selectfont")) ;;@noindent ;;The base set of PostScript fonts is: ;; ;;@multitable @columnfractions .20 .25 .25 .30 ;;@item Times @tab Times-Italic @tab Times-Bold @tab Times-BoldItalic ;;@item Helvetica @tab Helvetica-Oblique @tab Helvetica-Bold @tab Helvetica-BoldOblique ;;@item Courier @tab Courier-Oblique @tab Courier-Bold @tab Courier-BoldOblique ;;@item Symbol ;;@end multitable ;;@noindent ;;Line parameters do no affect fonts; they do effect glyphs. ;;@body ;;The default linewidth is 1. Setting it to 0 makes the lines drawn ;;as skinny as possible. Linewidth must be much smaller than ;;glyphsize for readable glyphs. (define (set-linewidth w) (scheme->ps w " setlinewidth")) ;;@args j k ;;Lines are drawn @1-on @2-off. ;;@args j ;;Lines are drawn @1-on @1-off. ;;@args ;;Turns off dashing. (define (set-linedash . args) (scheme->ps args " 0 setdash")) ;;@body ;;Sets the (PostScript) variable glyphsize to @1. The default ;;glyphsize is 6. (define (set-glyphsize w) (scheme->ps "/glyphsize " w " def")) ;;@noindent ;;The effects of @code{clip-to-rect} are also part of the graphic ;;context. ;;@node Rectangles, Legending, Graphics Context, PostScript Graphing ;;@subsubsection Rectangles ;;@noindent ;;A @dfn{rectangle} is a list of 4 numbers; the first two elements are ;;the x and y coordinates of lower left corner of the rectangle. The ;;other two elements are the width and height of the rectangle. ;;@body ;;Pushes a rectangle for the whole encapsulated page onto the ;;PostScript stack. This pushed rectangle is an implicit argument to ;;@code{partition-page} or @code{setup-plot}. (define (whole-page) 'whole-page) ;;@body ;;Pops the rectangle currently on top of the stack and pushes @1 * @2 ;;sub-rectangles onto the stack in decreasing y and increasing x order. ;;If you are drawing just one graph, then you don't need @0. (define (partition-page xparts yparts) (scheme->ps xparts " " yparts " partition-page")) ;;@body ;;The rectangle where data points should be plotted. @0 is set by ;;@code{setup-plot}. (define plotrect 'plotrect) ;;@body ;;The @var{pagerect} argument of the most recent call to ;;@code{setup-plot}. Includes plotrect, legends, etc. (define graphrect 'graphrect) ;;@body ;;fills @1 with the current color. (define (fill-rect rect) (scheme->ps rect " fill-rect")) ;;@body ;;Draws the perimiter of @1 in the current color. (define (outline-rect rect) (scheme->ps rect " outline-rect")) ;;@body ;;Modifies the current graphics-state so that nothing will be drawn ;;outside of the rectangle @1. Use @code{in-graphic-context} to limit ;;the extent of @0. (define (clip-to-rect rect) (scheme->ps rect " clip-to-rect")) ;;@node Legending, Legacy Plotting, Rectangles, PostScript Graphing ;;@subsubsection Legending ;;@args title subtitle ;;@args title ;;Puts a @1 line and an optional @2 line above the @code{graphrect}. (define (title-top title . subtitle) (set! *plot-title* title) (scheme->ps "(" title ") (" (if (null? subtitle) "" (car subtitle)) ") title-top")) ;;@args title subtitle ;;@args title ;;Puts a @1 line and an optional @2 line below the @code{graphrect}. (define (title-bottom title . subtitle) (set! *plot-title* title) (scheme->ps "(" title ") (" (if (null? subtitle) "" (car subtitle)) ") title-bottom")) ;;@body ;;These edge coordinates of @code{graphrect} are suitable for passing ;;as the first argument to @code{rule-horizontal}. (define topedge 'topedge) (define bottomedge 'bottomedge) ;;@body ;;These edge coordinates of @code{graphrect} are suitable for passing ;;as the first argument to @code{rule-vertical}. (define leftedge 'leftedge) (define rightedge 'rightedge) ;;@body ;;The margin-templates are strings whose displayed width is used to ;;reserve space for the left and right side numerical legends. ;;The default values are "-.0123456789". (define (set-margin-templates left right) (scheme->ps "/lmargin-template (" left ") def " "/rmargin-template (" right ") def")) ;;@body ;;Draws a vertical ruler with X coordinate @1 and labeled with string ;;@2. If @3 is positive, then the ticks are @3 long on the right side ;;of @1; and @2 and numeric legends are on the left. If @3 is ;;negative, then the ticks are -@3 long on the left side of @1; and @2 ;;and numeric legends are on the right. (define (rule-vertical x-coord text tick-width) (scheme->ps x-coord " (" text ") " tick-width " rule-vertical")) ;;@body ;;Draws a horizontal ruler with Y coordinate @1 and labeled with ;;string @2. If @3 is positive, then the ticks are @3 long on the top ;;side of @1; and @2 and numeric legends are on the bottom. If @3 is ;;negative, then the ticks are -@3 long on the bottom side of @1; and ;;@2 and numeric legends are on the top. (define (rule-horizontal y-coord text tick-height) (scheme->ps y-coord " (" text ") " tick-height " rule-horizontal")) ;;@body ;;Draws the y-axis. (define (y-axis) 'y-axis) ;;@body ;;Draws the x-axis. (define (x-axis) 'x-axis) ;;@body ;;Draws vertical lines through @code{graphrect} at each tick on the ;;vertical ruler. (define (grid-verticals) 'grid-verticals) ;;@body ;;Draws horizontal lines through @code{graphrect} at each tick on the ;;horizontal ruler. (define (grid-horizontals) 'grid-horizontals) ;;@node Legacy Plotting, Example Graph, Legending, PostScript Graphing ;;@subsubsection Legacy Plotting (define (graph:plot tmp data xlabel ylabel . histogram?) (set! histogram? (if (null? histogram?) #f (car histogram?))) (if (list? data) (let ((len (length data)) (nra (make-array (A:floR64b) (length data) 2))) (do ((idx 0 (+ 1 idx)) (lst data (cdr lst))) ((>= idx len) (set! data nra)) (array-set! nra (caar lst) idx 0) (array-set! nra (if (list? (cdar lst)) (cadar lst) (cdar lst)) idx 1)))) (create-postscript-graph tmp (or graph:dimensions '(600 300)) (whole-page) (setup-plot (column-range data 0) (apply combine-ranges (do ((idx (+ -1 (cadr (array-dimensions data))) (+ -1 idx)) (lst '() (cons (column-range data idx) lst))) ((< idx 1) lst)))) (outline-rect plotrect) (x-axis) (y-axis) (do ((idx (+ -1 (cadr (array-dimensions data))) (+ -1 idx)) (lst '() (cons (plot-column data 0 idx (if histogram? 'bargraph 'line)) lst))) ((< idx 1) lst)) (rule-vertical leftedge ylabel 10) (rule-horizontal bottomedge xlabel 10))) (define (functions->array vlo vhi npts . funcs) (let ((dats (make-array (A:floR32b) npts (+ 1 (length funcs))))) (define jdx 1) (array-index-map! (make-shared-array dats (lambda (idx) (list idx 0)) npts) (lambda (idx) (+ vlo (* (- vhi vlo) (/ idx (+ -1 npts)))))) (for-each (lambda (func) (array-map! (make-shared-array dats (lambda (idx) (list idx jdx)) npts) func (make-shared-array dats (lambda (idx) (list idx 0)) npts)) (set! jdx (+ 1 jdx))) funcs) dats)) (define (graph:plot-function tmp func vlo vhi . npts) (set! npts (if (null? npts) 200 (car npts))) (let ((dats (functions->array vlo vhi npts func))) (graph:plot tmp dats "" ""))) ;;@body ;;A list of the width and height of the graph to be plotted using ;;@code{plot}. (define graph:dimensions #f) ;;@args func x1 x2 npts ;;@args func x1 x2 ;;Creates and displays using @code{(system "gv tmp.eps")} an ;;encapsulated PostScript graph of the function of one argument @1 ;;over the range @2 to @3. If the optional integer argument @4 is ;;supplied, it specifies the number of points to evaluate @1 at. ;; ;;@defunx x1 x2 npts func1 func2 ... ;;Creates and displays an encapsulated PostScript graph of the ;;one-argument functions @var{func1}, @var{func2}, ... over the range ;;@var{x1} to @var{x2} at @var{npts} points. ;; ;;@defunx plot coords x-label y-label ;;@var{coords} is a list or vector of coordinates, lists of x and y ;;coordinates. @var{x-label} and @var{y-label} are strings with which ;;to label the x and y axes. (define (plot . args) (call-with-tmpnam (lambda (tmp) (cond ((procedure? (car args)) (apply graph:plot-function tmp args)) ((or (array? (car args)) (and (pair? (car args)) (pair? (caar args)))) (apply graph:plot tmp args)) (else (let ((dats (apply functions->array args))) (graph:plot tmp dats "" "")))) (system (string-append "gv '" tmp "'"))) ".eps")) ;;@node Example Graph, , Legacy Plotting, PostScript Graphing ;;@subsubsection Example Graph ;;@noindent ;;The file @file{am1.5.html}, a table of solar irradiance, is fetched ;;with @samp{wget} if it isn't already in the working directory. The ;;file is read and stored into an array, @var{irradiance}. ;; ;;@code{create-postscript-graph} is then called to create an ;;encapsulated-PostScript file, @file{solarad.eps}. The size of the ;;page is set to 600 by 300. @code{whole-page} is called and leaves ;;the rectangle on the PostScript stack. @code{setup-plot} is called ;;with a literal range for x and computes the range for column 1. ;; ;;Two calls to @code{top-title} are made so a different font can be ;;used for the lower half. @code{in-graphic-context} is used to limit ;;the scope of the font change. The graphing area is outlined and a ;;rule drawn on the left side. ;; ;;Because the X range was intentionally reduced, ;;@code{in-graphic-context} is called and @code{clip-to-rect} limits ;;drawing to the plotting area. A black line is drawn from data ;;column 1. That line is then overlayed with a mountain plot of the ;;same column colored "Bright Sun". ;; ;;After returning from the @code{in-graphic-context}, the bottom ruler ;;is drawn. Had it been drawn earlier, all its ticks would have been ;;painted over by the mountain plot. ;; ;;The color is then changed to @samp{seagreen} and the same graphrect ;;is setup again, this time with a different Y scale, 0 to 1000. The ;;graphic context is again clipped to @var{plotrect}, linedash is set, ;;and column 2 is plotted as a dashed line. Finally the rightedge is ;;ruled. Having the line and its scale both in green helps ;;disambiguate the scales. ;;@example ;;(require 'eps-graph) ;;(require 'line-i/o) ;;(require 'string-port) ;; ;;(define irradiance ;; (let ((url "http://www.pv.unsw.edu.au/am1.5.html") ;; (file "am1.5.html")) ;; (define (read->list line) ;; (define elts '()) ;; (call-with-input-string line ;; (lambda (iprt) (do ((elt (read iprt) (read iprt))) ;; ((eof-object? elt) elts) ;; (set! elts (cons elt elts)))))) ;; (if (not (file-exists? file)) ;; (system (string-append "wget -c -O" file " " url))) ;; (call-with-input-file file ;; (lambda (iprt) ;; (define lines '()) ;; (do ((line (read-line iprt) (read-line iprt))) ;; ((eof-object? line) ;; (let ((nra (make-array (A:floR64b) ;; (length lines) ;; (length (car lines))))) ;; (do ((lns lines (cdr lns)) ;; (idx (+ -1 (length lines)) (+ -1 idx))) ;; ((null? lns) nra) ;; (do ((kdx (+ -1 (length (car lines))) (+ -1 kdx)) ;; (lst (car lns) (cdr lst))) ;; ((null? lst)) ;; (array-set! nra (car lst) idx kdx))))) ;; (if (and (positive? (string-length line)) ;; (char-numeric? (string-ref line 0))) ;; (set! lines (cons (read->list line) lines)))))))) ;; ;;(let ((xrange '(.25 2.5))) ;; (create-postscript-graph ;; "solarad.eps" '(600 300) ;; (whole-page) ;; (setup-plot xrange (column-range irradiance 1)) ;; (title-top ;; "Solar Irradiance http://www.pv.unsw.edu.au/am1.5.html") ;; (in-graphic-context ;; (set-font "Helvetica-Oblique" 12) ;; (title-top ;; "" ;; "Key Centre for Photovoltaic Engineering UNSW - Air Mass 1.5 Global Spectrum")) ;; (outline-rect plotrect) ;; (rule-vertical leftedge "W/(m^2.um)" 10) ;; (in-graphic-context (clip-to-rect plotrect) ;; (plot-column irradiance 0 1 'line) ;; (set-color "Bright Sun") ;; (plot-column irradiance 0 1 'mountain) ;; ) ;; (rule-horizontal bottomedge "Wavelength in .um" 5) ;; (set-color 'seagreen) ;; ;; (setup-plot xrange '(0 1000) graphrect) ;; (in-graphic-context (clip-to-rect plotrect) ;; (set-linedash 5 2) ;; (plot-column irradiance 0 2 'line)) ;; (rule-vertical rightedge "Integrated .W/(m^2)" -10) ;; )) ;; ;;(system "gv solarad.eps") ;;@end example slib-3b1/grapheps.txi0000644001705200017500000003521710747237372012553 0ustar tbtb@code{(require 'eps-graph)} @noindent This is a graphing package creating encapsulated-PostScript files. Its motivations and design choice are described in @url{http://swiss.csail.mit.edu/~jaffer/Docupage/grapheps} @noindent A dataset to be plotted is taken from a 2-dimensional array. Corresponding coordinates are in rows. Coordinates from any pair of columns can be plotted. @defun create-postscript-graph filename.eps size elt1 @dots{} @var{filename.eps} should be a string naming an output file to be created. @var{size} should be an exact integer, a list of two exact integers, or #f. @var{elt1}, ... are values returned by graphing primitives described here. @code{create-postscript-graph} creates an @dfn{Encapsulated-PostScript} file named @var{filename.eps} containing @cindex Encapsulated-PostScript graphs as directed by the @var{elt1}, ... arguments. The size of the graph is determined by the @var{size} argument. If a list of two integers, they specify the width and height. If one integer, then that integer is the width and the height is 3/4 of the width. If #f, the graph will be 800 by 600. @end defun @noindent These graphing procedures should be called as arguments to @code{create-postscript-graph}. The order of these arguments is significant; PostScript graphics state is affected serially from the first @var{elt} argument to the last. @defun whole-page Pushes a rectangle for the whole encapsulated page onto the PostScript stack. This pushed rectangle is an implicit argument to @code{partition-page} or @code{setup-plot}. @end defun @menu * Column Ranges:: * Drawing the Graph:: * Graphics Context:: * Rectangles:: * Legending:: * Legacy Plotting:: * Example Graph:: @end menu @node Column Ranges, Drawing the Graph, PostScript Graphing, PostScript Graphing @subsubsection Column Ranges @noindent A @dfn{range} is a list of two numbers, the minimum and the maximum. @cindex range @cindex range Ranges can be given explicity or computed in PostScript by @code{column-range}. @defun column-range array k Returns the range of values in 2-dimensional @var{array} column @var{k}. @end defun @defun pad-range range p Expands @var{range} by @var{p}/100 on each end. @end defun @defun snap-range range Expands @var{range} to round number of ticks. @end defun @defun combine-ranges range1 range2 @dots{} Returns the minimal range covering all @var{range1}, @var{range2}, ... @end defun @defun setup-plot x-range y-range pagerect @defunx setup-plot x-range y-range @var{x-range} and @var{y-range} should each be a list of two numbers or the value returned by @code{pad-range}, @code{snap-range}, or @code{combine-range}. @var{pagerect} is the rectangle bounding the graph to be drawn; if missing, the rectangle from the top of the PostScript stack is popped and used. Based on the given ranges, @code{setup-plot} sets up scaling and margins for making a graph. The margins are sized proportional to the @var{fontheight} value at the time of the call to setup-plot. @code{setup-plot} sets two variables: @table @var @item plotrect The region where data points will be plotted. @item graphrect The @var{pagerect} argument to @code{setup-plot}. Includes plotrect, legends, etc. @end table @end defun @node Drawing the Graph, Graphics Context, Column Ranges, PostScript Graphing @subsubsection Drawing the Graph @defun plot-column array x-column y-column proc3s Plots points with x coordinate in @var{x-column} of @var{array} and y coordinate @var{y-column} of @var{array}. The symbol @var{proc3s} specifies the type of glyph or drawing style for presenting these coordinates. @end defun @noindent The glyphs and drawing styles available are: @table @code @item line Draws line connecting points in order. @item mountain Fill area below line connecting points. @item cloud Fill area above line connecting points. @item impulse Draw line from x-axis to each point. @item bargraph Draw rectangle from x-axis to each point. @item disc Solid round dot. @item point Minimal point -- invisible if linewidth is 0. @item square Square box. @item diamond Square box at 45.o @item plus Plus sign. @item cross X sign. @item triup Triangle pointing upward @item tridown Triangle pointing downward @item pentagon Five sided polygon @item circle Hollow circle @end table @node Graphics Context, Rectangles, Drawing the Graph, PostScript Graphing @subsubsection Graphics Context @defun in-graphic-context arg @dots{} Saves the current graphics state, executes @var{args}, then restores to saved graphics state. @end defun @defun set-color color @var{color} should be a string naming a Resene color, a saturate color, or a number between 0 and 100. @code{set-color} sets the PostScript color to the color of the given string, or a grey value between black (0) and white (100). @end defun @defun set-font name fontheight @var{name} should be a (case-sensitive) string naming a PostScript font. @var{fontheight} should be a positive real number. @code{set-font} Changes the current PostScript font to @var{name} with height equal to @var{fontheight}. The default font is Helvetica (12pt). @end defun @noindent The base set of PostScript fonts is: @multitable @columnfractions .20 .25 .25 .30 @item Times @tab Times-Italic @tab Times-Bold @tab Times-BoldItalic @item Helvetica @tab Helvetica-Oblique @tab Helvetica-Bold @tab Helvetica-BoldOblique @item Courier @tab Courier-Oblique @tab Courier-Bold @tab Courier-BoldOblique @item Symbol @end multitable @noindent Line parameters do no affect fonts; they do effect glyphs. @defun set-linewidth w The default linewidth is 1. Setting it to 0 makes the lines drawn as skinny as possible. Linewidth must be much smaller than glyphsize for readable glyphs. @end defun @defun set-linedash j k Lines are drawn @var{j}-on @var{k}-off. @defunx set-linedash j Lines are drawn @var{j}-on @var{j}-off. @defunx set-linedash Turns off dashing. @end defun @defun set-glyphsize w Sets the (PostScript) variable glyphsize to @var{w}. The default glyphsize is 6. @end defun @noindent The effects of @code{clip-to-rect} are also part of the graphic context. @node Rectangles, Legending, Graphics Context, PostScript Graphing @subsubsection Rectangles @noindent A @dfn{rectangle} is a list of 4 numbers; the first two elements are @cindex rectangle the x and y coordinates of lower left corner of the rectangle. The other two elements are the width and height of the rectangle. @defun whole-page Pushes a rectangle for the whole encapsulated page onto the PostScript stack. This pushed rectangle is an implicit argument to @code{partition-page} or @code{setup-plot}. @end defun @defun partition-page xparts yparts Pops the rectangle currently on top of the stack and pushes @var{xparts} * @var{yparts} sub-rectangles onto the stack in decreasing y and increasing x order. If you are drawing just one graph, then you don't need @code{partition-page}. @end defun @defvar plotrect The rectangle where data points should be plotted. @var{plotrect} is set by @code{setup-plot}. @end defvar @defvar graphrect The @var{pagerect} argument of the most recent call to @code{setup-plot}. Includes plotrect, legends, etc. @end defvar @defun fill-rect rect fills @var{rect} with the current color. @end defun @defun outline-rect rect Draws the perimiter of @var{rect} in the current color. @end defun @defun clip-to-rect rect Modifies the current graphics-state so that nothing will be drawn outside of the rectangle @var{rect}. Use @code{in-graphic-context} to limit the extent of @code{clip-to-rect}. @end defun @node Legending, Legacy Plotting, Rectangles, PostScript Graphing @subsubsection Legending @defun title-top title subtitle @defunx title-top title Puts a @var{title} line and an optional @var{subtitle} line above the @code{graphrect}. @end defun @defun title-bottom title subtitle @defunx title-bottom title Puts a @var{title} line and an optional @var{subtitle} line below the @code{graphrect}. @end defun @defvar topedge @defvarx bottomedge These edge coordinates of @code{graphrect} are suitable for passing as the first argument to @code{rule-horizontal}. @end defvar @defvar leftedge @defvarx rightedge These edge coordinates of @code{graphrect} are suitable for passing as the first argument to @code{rule-vertical}. @end defvar @defun set-margin-templates left right The margin-templates are strings whose displayed width is used to reserve space for the left and right side numerical legends. The default values are "-.0123456789". @end defun @defun rule-vertical x-coord text tick-width Draws a vertical ruler with X coordinate @var{x-coord} and labeled with string @var{text}. If @var{tick-width} is positive, then the ticks are @var{tick-width} long on the right side of @var{x-coord}; and @var{text} and numeric legends are on the left. If @var{tick-width} is negative, then the ticks are -@var{tick-width} long on the left side of @var{x-coord}; and @var{text} and numeric legends are on the right. @end defun @defun rule-horizontal y-coord text tick-height Draws a horizontal ruler with Y coordinate @var{y-coord} and labeled with string @var{text}. If @var{tick-height} is positive, then the ticks are @var{tick-height} long on the top side of @var{y-coord}; and @var{text} and numeric legends are on the bottom. If @var{tick-height} is negative, then the ticks are -@var{tick-height} long on the bottom side of @var{y-coord}; and @var{text} and numeric legends are on the top. @end defun @defun y-axis Draws the y-axis. @end defun @defun x-axis Draws the x-axis. @end defun @defun grid-verticals Draws vertical lines through @code{graphrect} at each tick on the vertical ruler. @end defun @defun grid-horizontals Draws horizontal lines through @code{graphrect} at each tick on the horizontal ruler. @end defun @node Legacy Plotting, Example Graph, Legending, PostScript Graphing @subsubsection Legacy Plotting @defvar graph:dimensions A list of the width and height of the graph to be plotted using @code{plot}. @end defvar @defun plot func x1 x2 npts @defunx plot func x1 x2 Creates and displays using @code{(system "gv tmp.eps")} an encapsulated PostScript graph of the function of one argument @var{func} over the range @var{x1} to @var{x2}. If the optional integer argument @var{npts} is supplied, it specifies the number of points to evaluate @var{func} at. @defunx x1 x2 npts func1 func2 ... Creates and displays an encapsulated PostScript graph of the one-argument functions @var{func1}, @var{func2}, ... over the range @var{x1} to @var{x2} at @var{npts} points. @defunx plot coords x-label y-label @var{coords} is a list or vector of coordinates, lists of x and y coordinates. @var{x-label} and @var{y-label} are strings with which to label the x and y axes. @end defun @node Example Graph, , Legacy Plotting, PostScript Graphing @subsubsection Example Graph @noindent The file @file{am1.5.html}, a table of solar irradiance, is fetched with @samp{wget} if it isn't already in the working directory. The file is read and stored into an array, @var{irradiance}. @code{create-postscript-graph} is then called to create an encapsulated-PostScript file, @file{solarad.eps}. The size of the page is set to 600 by 300. @code{whole-page} is called and leaves the rectangle on the PostScript stack. @code{setup-plot} is called with a literal range for x and computes the range for column 1. Two calls to @code{top-title} are made so a different font can be used for the lower half. @code{in-graphic-context} is used to limit the scope of the font change. The graphing area is outlined and a rule drawn on the left side. Because the X range was intentionally reduced, @code{in-graphic-context} is called and @code{clip-to-rect} limits drawing to the plotting area. A black line is drawn from data column 1. That line is then overlayed with a mountain plot of the same column colored "Bright Sun". After returning from the @code{in-graphic-context}, the bottom ruler is drawn. Had it been drawn earlier, all its ticks would have been painted over by the mountain plot. The color is then changed to @samp{seagreen} and the same graphrect is setup again, this time with a different Y scale, 0 to 1000. The graphic context is again clipped to @var{plotrect}, linedash is set, and column 2 is plotted as a dashed line. Finally the rightedge is ruled. Having the line and its scale both in green helps disambiguate the scales. @example (require 'eps-graph) (require 'line-i/o) (require 'string-port) (define irradiance (let ((url "http://www.pv.unsw.edu.au/am1.5.html") (file "am1.5.html")) (define (read->list line) (define elts '()) (call-with-input-string line (lambda (iprt) (do ((elt (read iprt) (read iprt))) ((eof-object? elt) elts) (set! elts (cons elt elts)))))) (if (not (file-exists? file)) (system (string-append "wget -c -O" file " " url))) (call-with-input-file file (lambda (iprt) (define lines '()) (do ((line (read-line iprt) (read-line iprt))) ((eof-object? line) (let ((nra (make-array (A:floR64b) (length lines) (length (car lines))))) (do ((lns lines (cdr lns)) (idx (+ -1 (length lines)) (+ -1 idx))) ((null? lns) nra) (do ((kdx (+ -1 (length (car lines))) (+ -1 kdx)) (lst (car lns) (cdr lst))) ((null? lst)) (array-set! nra (car lst) idx kdx))))) (if (and (positive? (string-length line)) (char-numeric? (string-ref line 0))) (set! lines (cons (read->list line) lines)))))))) (let ((xrange '(.25 2.5))) (create-postscript-graph "solarad.eps" '(600 300) (whole-page) (setup-plot xrange (column-range irradiance 1)) (title-top "Solar Irradiance http://www.pv.unsw.edu.au/am1.5.html") (in-graphic-context (set-font "Helvetica-Oblique" 12) (title-top "" "Key Centre for Photovoltaic Engineering UNSW - Air Mass 1.5 Global Spectrum")) (outline-rect plotrect) (rule-vertical leftedge "W/(m^2.um)" 10) (in-graphic-context (clip-to-rect plotrect) (plot-column irradiance 0 1 'line) (set-color "Bright Sun") (plot-column irradiance 0 1 'mountain) ) (rule-horizontal bottomedge "Wavelength in .um" 5) (set-color 'seagreen) (setup-plot xrange '(0 1000) graphrect) (in-graphic-context (clip-to-rect plotrect) (set-linedash 5 2) (plot-column irradiance 0 2 'line)) (rule-vertical rightedge "Integrated .W/(m^2)" -10) )) (system "gv solarad.eps") @end example slib-3b1/guile.init0000644001705200017500000005243410733633204012173 0ustar tbtb;"guile.init" Configuration file for SLIB for GUILE -*-scheme-*- ;;; Author: Aubrey Jaffer ;;; ;;; This code is in the public domain. (if (not (and (string<=? "1.6" (version)) (stringmemoizing-macro (lambda (exp env) (cons (if (= 1 (length env)) 'define-public 'base:define) (cdr exp))))) ;;; Hack to make syncase macros work in the slib module (if (nested-ref the-root-module '(app modules ice-9 syncase)) (set-object-property! (module-local-variable (current-module) 'define) '*sc-expander* '(define))) ;;; (software-type) should be set to the generic operating system type. ;;; UNIX, VMS, MACOS, AMIGA and MS-DOS are supported. (define software-type (if (string (lambda (path) (lambda () path))) (else %site-dir))) ;;; (library-vicinity) should be defined to be the pathname of the ;;; directory where files of Scheme library functions reside. (define library-vicinity (let ((library-path (or ;; Use this getenv if your implementation supports it. (and (defined? 'getenv) (getenv "SCHEME_LIBRARY_PATH")) ;; Rob Browning sent this; I'm not sure its a good idea. ;; See if we can find slib/guile.init (cf. implementation-vicinity). (let ((path (%search-load-path "slib/guile.init"))) (and path (substring path 0 (- (string-length path) 10)))) ;; Use this path if your scheme does not support GETENV ;; or if SCHEME_LIBRARY_PATH is not set. "/usr/lib/slib/" (in-vicinity (implementation-vicinity) "slib/")))) (lambda () library-path))) ;;; (home-vicinity) should return the vicinity of the user's HOME ;;; directory, the directory which typically contains files which ;;; customize a computer environment for a user. (define (home-vicinity) (let ((home (and (defined? 'getenv) (getenv "HOME")))) (and home (case (software-type) ((unix coherent ms-dos) ;V7 unix has a / on HOME (if (eqv? #\/ (string-ref home (+ -1 (string-length home)))) home (string-append home "/"))) (else home))))) ;@ (define (user-vicinity) (case (software-type) ((vms) "[.]") (else ""))) ;@ (define vicinity:suffix? (let ((suffi (case (software-type) ((amiga) '(#\: #\/)) ((macos thinkc) '(#\:)) ((ms-dos windows atarist os/2) '(#\\ #\/)) ((nosve) '(#\: #\.)) ((unix coherent plan9) '(#\/)) ((vms) '(#\: #\])) (else (warn "require.scm" 'unknown 'software-type (software-type)) "/")))) (lambda (chr) (and (memv chr suffi) #t)))) ;@ (define (pathname->vicinity pathname) (let loop ((i (- (string-length pathname) 1))) (cond ((negative? i) "") ((vicinity:suffix? (string-ref pathname i)) (substring pathname 0 (+ i 1))) (else (loop (- i 1)))))) ;@ (define (program-vicinity) (define clp (current-load-port)) (if clp (pathname->vicinity (port-filename clp)) (slib:error 'program-vicinity " called; use slib:load to load"))) ;@ (define sub-vicinity (case (software-type) ((vms) (lambda (vic name) (let ((l (string-length vic))) (if (or (zero? (string-length vic)) (not (char=? #\] (string-ref vic (- l 1))))) (string-append vic "[" name "]") (string-append (substring vic 0 (- l 1)) "." name "]"))))) (else (let ((*vicinity-suffix* (case (software-type) ((nosve) ".") ((macos thinkc) ":") ((ms-dos windows atarist os/2) "\\") ((unix coherent plan9 amiga) "/")))) (lambda (vic name) (string-append vic name *vicinity-suffix*)))))) ;@ (define (make-vicinity ) ) ;@ (define with-load-pathname (let ((exchange (lambda (new) (let ((old program-vicinity)) (set! program-vicinity new) old)))) (lambda (path thunk) (define old #f) (define vic (pathname->vicinity path)) (dynamic-wind (lambda () (set! old (exchange (lambda () vic)))) thunk (lambda () (exchange old)))))) ;;@ SLIB:FEATURES is a list of symbols naming the (SLIB) features ;;; initially supported by this implementation. (define slib:features (append (apply append (map (lambda (sym) (if (defined? sym) (list sym) '())) '(getenv program-arguments current-time char-ready?))) '( source ;can load scheme source files ;(SLIB:LOAD-SOURCE "filename") ;;; compiled ;can load compiled files ;(SLIB:LOAD-COMPILED "filename") vicinity srfi-59 srfi-96 ;; Scheme report features ;; R5RS-compliant implementations should provide all 9 features. ;;; r5rs ;conforms to eval ;R5RS two-argument eval values ;R5RS multiple values dynamic-wind ;R5RS dynamic-wind ;;; macro ;R5RS high level macros delay ;has DELAY and FORCE multiarg-apply ;APPLY can take more than 2 args. ;;; char-ready? rev4-optional-procedures ;LIST-TAIL, STRING-COPY, ;STRING-FILL!, and VECTOR-FILL! ;; These four features are optional in both R4RS and R5RS multiarg/and- ;/ and - can take more than 2 args. ;;; rationalize ;;; transcript ;TRANSCRIPT-ON and TRANSCRIPT-OFF with-file ;has WITH-INPUT-FROM-FILE and ;WITH-OUTPUT-TO-FILE ;;; r4rs ;conforms to ;;; ieee-p1178 ;conforms to ;;; r3rs ;conforms to rev2-procedures ;SUBSTRING-MOVE-LEFT!, ;SUBSTRING-MOVE-RIGHT!, ;SUBSTRING-FILL!, ;STRING-NULL?, APPEND!, 1+, ;-1+, ?, >=? ;;; object-hash ;has OBJECT-HASH hash ;HASH, HASHV, HASHQ full-continuation ;can return multiple times ;;; ieee-floating-point ;conforms to IEEE Standard 754-1985 ;IEEE Standard for Binary ;Floating-Point Arithmetic. ;; Other common features ;;; srfi-0 ;srfi-0, COND-EXPAND finds all srfi-* ;;; sicp ;runs code from Structure and ;Interpretation of Computer ;Programs by Abelson and Sussman. defmacro ;has Common Lisp DEFMACRO ;;; record ;has user defined data structures string-port ;has CALL-WITH-INPUT-STRING and ;CALL-WITH-OUTPUT-STRING line-i/o ;;; sort ;;; pretty-print ;;; object->string ;;; format ;Common-lisp output formatting ;;; trace ;has macros: TRACE and UNTRACE ;;; compiler ;has (COMPILER) ;;; ed ;(ED) is editor system ;posix (system ) ;;; getenv ;posix (getenv ) ;;; program-arguments ;returns list of strings (argv) ;;; current-time ;returns time in seconds since 1/1/1970 ;; Implementation Specific features logical random ;Random numbers array array-for-each ))) ;;@ (FILE-POSITION . ) (define (file-position port . args) (if (null? args) (ftell port) (seek port (car args) SEEK_SET))) (if (string>=? (scheme-implementation-version) "1.8") (module-replace! (current-module) '(file-position))) ;;; (OUTPUT-PORT-WIDTH ) (define (output-port-width . arg) 79) ;;; (OUTPUT-PORT-HEIGHT ) (define (output-port-height . arg) 24) ;;; (CURRENT-ERROR-PORT) ;;(define current-error-port ;; (let ((port (current-output-port))) ;; (lambda () port))) ;; If the program is killed by a signal, /bin/sh normally gives an ;; exit code of 128+signum. If /bin/sh itself is killed by a signal ;; then we do the same 128+signum here. ;; ;; "status:stop-sig" shouldn't arise here, since system shouldn't be ;; calling waitpid with WUNTRACED, but allow for it anyway, just in ;; case. (define system (let ((guile-core-system system)) (lambda (str) (define st (guile-core-system str)) (or (status:exit-val st) (+ 128 (or (status:term-sig st) (status:stop-sig st))))))) ;; This has to be done after the definition so that the original ;; binding will still be visible during the definition. (if (string>=? (scheme-implementation-version) "1.8") (module-replace! (current-module) '(system))) ;;; for line-i/o (use-modules (ice-9 popen)) (define (system->line command . tmp) (let ((ipip (open-input-pipe command))) (define line (read-line ipip)) (let ((status (close-pipe ipip))) (and (or (eqv? 0 (status:exit-val status)) (status:term-sig status) (status:stop-sig status)) (if (eof-object? line) "" line))))) ;; rdelim was loaded by default in guile 1.6, but not in 1.8 ;; load it to get read-line, read-line! and write-line, ;; and re-export them for the benefit of loading this file from (ice-9 slib) (cond ((string>=? (scheme-implementation-version) "1.8") (use-modules (ice-9 rdelim)) (re-export read-line) (re-export read-line!) (re-export write-line))) (define delete-file (let ((guile-core-delete-file delete-file)) (lambda (filename) (catch 'system-error (lambda () (guile-core-delete-file filename) #t) (lambda args #f))))) ;; This has to be done after the definition so that the original ;; binding will still be visible during the definition. (if (string>=? (scheme-implementation-version) "1.8") (module-replace! (current-module) '(delete-file))) ;;; FORCE-OUTPUT flushes any pending output on optional arg output port ;;; use this definition if your system doesn't have such a procedure. ;;(define (force-output . arg) #t) ;;; CALL-WITH-INPUT-STRING and CALL-WITH-OUTPUT-STRING are the string ;;; port versions of CALL-WITH-*PUT-FILE. (define (make-exchanger obj) (lambda (rep) (let ((old obj)) (set! obj rep) old))) (define open-file (let ((guile-core-open-file open-file)) (lambda (filename modes) (guile-core-open-file filename (if (symbol? modes) (symbol->string modes) modes))))) ;; This has to be done after the definition so that the original ;; binding will still be visible during the definition. (if (string>=? (scheme-implementation-version) "1.8") (module-replace! (current-module) '(open-file))) (define (call-with-open-ports . ports) (define proc (car ports)) (cond ((procedure? proc) (set! ports (cdr ports))) (else (set! ports (reverse ports)) (set! proc (car ports)) (set! ports (reverse (cdr ports))))) (let ((ans (apply proc ports))) (for-each close-port ports) ans)) (if (not (defined? 'browse-url)) ;; Nothing special to do for this, so straight from ;; Template.scm. Maybe "sensible-browser" for a debian ;; system would be worth trying too (and would be good on a ;; tty). (define (browse-url url) (define (try cmd end) (zero? (system (string-append cmd url end)))) (or (try "netscape-remote -remote 'openURL(" ")'") (try "netscape -remote 'openURL(" ")'") (try "netscape '" "'&") (try "netscape '" "'")))) ;;; "rationalize" adjunct procedures. ;;(define (find-ratio x e) ;; (let ((rat (rationalize x e))) ;; (list (numerator rat) (denominator rat)))) ;;(define (find-ratio-between x y) ;; (find-ratio (/ (+ x y) 2) (/ (- x y) 2))) ;;; CHAR-CODE-LIMIT is one greater than the largest integer which can ;;; be returned by CHAR->INTEGER. ;; In Guile-1.8.0: (string>? (string #\000) (string #\200)) ==> #t (if (string=? (version) "1.8.0") (define char-code-limit 128)) ;;; MOST-POSITIVE-FIXNUM is used in modular.scm ;;(define most-positive-fixnum #x0FFFFFFF) ;;; SLIB:EVAL is single argument eval using the top-level (user) environment. (define slib:eval (if (string=? (scheme-implementation-version) "1.8") (define (slib:load-helper loader) (lambda (name) (save-module-excursion (lambda () (set-current-module slib-module) (let ((errinfo (catch 'system-error (lambda () (loader name) #f) (lambda args args)))) (if (and errinfo (catch 'system-error (lambda () (loader (string-append name ".scm")) #f) (lambda args args))) (apply throw errinfo))))))) (define slib:load (slib:load-helper load)) (define slib:load-from-path (slib:load-helper load-from-path)) ) (else ;;Here for backward compatability (define scheme-file-suffix (let ((suffix (case (software-type) ((nosve) "_scm") (else ".scm")))) (lambda () suffix))) (define (guile:wrap-case-insensitive proc) (lambda args (save-module-excursion (lambda () (set-current-module slib-module) (let ((old (read-options))) (dynamic-wind (lambda () (read-enable 'case-insensitive)) (lambda () (apply proc args)) (lambda () (read-options old)))))))) (define read (guile:wrap-case-insensitive read)) (define slib:load (let ((load-file (guile:wrap-case-insensitive load))) (lambda () (load-file (string-append (scheme-file-suffix)))))) )) ;;;(SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever ;;;suffix all the module files in SLIB have. See feature 'SOURCE. (define slib:load-source slib:load) ;;; (SLIB:LOAD-COMPILED "foo") should load the file that was produced ;;; by compiling "foo.scm" if this implementation can compile files. ;;; See feature 'COMPILED. (define slib:load-compiled slib:load) (define defmacro:eval slib:eval) (define defmacro:load slib:load) (define (defmacro:expand* x) (require 'defmacroexpand) (apply defmacro:expand* x '())) ;@ (define gentemp (let ((*gensym-counter* -1)) (lambda () (set! *gensym-counter* (+ *gensym-counter* 1)) (string->symbol (string-append "slib:G" (number->string *gensym-counter*)))))) (if (string>=? (scheme-implementation-version) "1.8") (module-replace! (current-module) '(gentemp))) ;;; If your implementation provides R4RS macros: (define macro:eval slib:eval) (define macro:load slib:load-source) (define slib:warn warn) (define slib:error error) ;;; define these as appropriate for your system. (define slib:tab #\tab) (define slib:form-feed #\page) ;;; {Time} (define difftime -) (define offset-time +) ;;; Early version of 'logical is built-in (define (copy-bit index to bool) (if bool (logior to (arithmetic-shift 1 index)) (logand to (lognot (arithmetic-shift 1 index))))) (define (bit-field n start end) (logand (- (expt 2 (- end start)) 1) (arithmetic-shift n (- start)))) (define (bitwise-if mask n0 n1) (logior (logand mask n0) (logand (lognot mask) n1))) (define (copy-bit-field to from start end) (bitwise-if (arithmetic-shift (lognot (ash -1 (- end start))) start) (arithmetic-shift from start) to)) (define (rotate-bit-field n count start end) (define width (- end start)) (set! count (modulo count width)) (let ((mask (lognot (ash -1 width)))) (define azn (logand mask (arithmetic-shift n (- start)))) (logior (arithmetic-shift (logior (logand mask (arithmetic-shift azn count)) (arithmetic-shift azn (- count width))) start) (logand (lognot (ash mask start)) n)))) (define (log2-binary-factors n) (+ -1 (integer-length (logand n (- n))))) (define (bit-reverse k n) (do ((m (if (negative? n) (lognot n) n) (arithmetic-shift m -1)) (k (+ -1 k) (+ -1 k)) (rvs 0 (logior (arithmetic-shift rvs 1) (logand 1 m)))) ((negative? k) (if (negative? n) (lognot rvs) rvs)))) (define (reverse-bit-field n start end) (define width (- end start)) (let ((mask (lognot (ash -1 width)))) (define zn (logand mask (arithmetic-shift n (- start)))) (logior (arithmetic-shift (bit-reverse width zn) start) (logand (lognot (ash mask start)) n)))) (define (integer->list k . len) (if (null? len) (do ((k k (arithmetic-shift k -1)) (lst '() (cons (odd? k) lst))) ((<= k 0) lst)) (do ((idx (+ -1 (car len)) (+ -1 idx)) (k k (arithmetic-shift k -1)) (lst '() (cons (odd? k) lst))) ((negative? idx) lst)))) (define (list->integer bools) (do ((bs bools (cdr bs)) (acc 0 (+ acc acc (if (car bs) 1 0)))) ((null? bs) acc))) (define (booleans->integer . bools) (list->integer bools)) ;;;; SRFI-60 aliases (define arithmetic-shift ash) (define bitwise-ior logior) (define bitwise-xor logxor) (define bitwise-and logand) (define bitwise-not lognot) ;;(define bit-count logcount) (define bit-set? logbit?) (define any-bits-set? logtest) (define first-set-bit log2-binary-factors) (define bitwise-merge bitwise-if) ;;; array-for-each (define (array-indexes ra) (let ((ra0 (apply make-array '#() (array-shape ra)))) (array-index-map! ra0 list) ra0)) (define (array:copy! dest source) (array-map! dest identity source)) (define (array-null? array) (zero? (apply * (map (lambda (bnd) (- 1 (apply - bnd))) (array-shape array))))) ;; DIMENSIONS->UNIFORM-ARRAY and list->uniform-array in Guile-1.6.4 ;; cannot make empty arrays. (define make-array (lambda (prot . args) (if (array-null? prot) (dimensions->uniform-array args (array-prototype prot)) (dimensions->uniform-array args (array-prototype prot) (apply array-ref prot (map car (array-shape prot))))))) ;; This has to be done after the definition so that the original ;; binding will still be visible during the definition. (if (string>=? (scheme-implementation-version) "1.8") (module-replace! (current-module) '(make-array))) (define create-array make-array) (define (make-uniform-wrapper prot) (if (string? prot) (set! prot (string->number prot))) (if prot (if (stringuniform-array 1 prot (list prot)) (list->uniform-array 0 prot opt))) (lambda opt (if (null? opt) (list->uniform-array 1 prot (list prot)) (list->uniform-array 0 prot (car opt))))) vector)) (define ac64 (make-uniform-wrapper "+i")) (define ac32 ac64) (define ar64 (make-uniform-wrapper "1/3")) (define ar32 (make-uniform-wrapper "1.")) (define as64 vector) (define as32 (make-uniform-wrapper -32)) (define as16 as32) (define as8 as32) (define au64 vector) (define au32 (make-uniform-wrapper 32)) (define au16 au32) (define au8 au32) (define at1 (make-uniform-wrapper #t)) ;;; New SRFI-58 names ;; flonums (define A:floC128b ac64) (define A:floC64b ac64) (define A:floC32b ac32) (define A:floC16b ac32) (define A:floR128b ar64) (define A:floR64b ar64) (define A:floR32b ar32) (define A:floR16b ar32) ;; decimal flonums (define A:floR128d ar64) (define A:floR64d ar64) (define A:floR32d ar32) ;; fixnums (define A:fixZ64b as64) (define A:fixZ32b as32) (define A:fixZ16b as16) (define A:fixZ8b as8) (define A:fixN64b au64) (define A:fixN32b au32) (define A:fixN16b au16) (define A:fixN8b au8) (define A:bool at1) ;;; And case-insensitive versions ;; flonums (define a:floc128b ac64) (define a:floc64b ac64) (define a:floc32b ac32) (define a:floc16b ac32) (define a:flor128b ar64) (define a:flor64b ar64) (define a:flor32b ar32) (define a:flor16b ar32) ;; decimal flonums (define a:flor128d ar64) (define a:flor64d ar64) (define a:flor32d ar32) ;; fixnums (define a:fixz64b as64) (define a:fixz32b as32) (define a:fixz16b as16) (define a:fixz8b as8) (define a:fixn64b au64) (define a:fixn32b au32) (define a:fixn16b au16) (define a:fixn8b au8) (define a:bool at1) ;;; {Random numbers} (define (make-random-state . args) (let ((seed (if (null? args) *random-state* (car args)))) (cond ((string? seed)) ((number? seed) (set! seed (number->string seed))) (else (let () (require 'object->string) (set! seed (object->limited-string seed 50))))) (seed->random-state seed))) (if (not (defined? 'random:chunk)) (define (random:chunk sta) (random 256 sta))) ;;; workaround for Guile 1.6.7 bug (cond ((or (array? 'guile) (array? '(1 6 7))) (define array? (let ((old-array? array?)) (lambda (obj) (and (old-array? obj) (not (or (list? obj) (symbol? obj) (record? obj))))))) (if (string>=? (scheme-implementation-version) "1.8") (module-replace! (current-module) '(array?))))) ;;; Support for older versions of Scheme. Not enough code for its own file. ;;(define (last-pair l) (if (pair? (cdr l)) (last-pair (cdr l)) l)) (define t #t) (define nil #f) ;;; rev2-procedures (define ? >) (define >=? >=) (if (string>=? (scheme-implementation-version) "1.8") (module-replace! (current-module) '(provide provided?))) (slib:load (in-vicinity (library-vicinity) "require")) slib-3b1/hash.scm0000644001705200017500000000655010614256454011634 0ustar tbtb; "hash.scm", hashing functions for Scheme. ; Copyright (C) 1992, 1993, 1995, 2003 Aubrey Jaffer ; ;Permission to copy this software, to modify it, to redistribute it, ;to distribute modified versions, and to use it for any purpose is ;granted, subject to the following restrictions and understandings. ; ;1. Any copy made of this software must include this copyright notice ;in full. ; ;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; ;3. In conjunction with products arising from the use of this ;material, there shall be no use of my name in any advertising, ;promotional, or sales literature without prior written consent in ;each case. (define (hash:hash-string-ci str n) (let ((len (string-length str))) (if (> len 5) (let loop ((h (modulo 264 n)) (i 5)) (if (positive? i) (loop (modulo (+ (* h 256) (char->integer (char-downcase (string-ref str (modulo h len))))) n) (- i 1)) h)) (let loop ((h 0) (i (- len 1))) (if (>= i 0) (loop (modulo (+ (* h 256) (char->integer (char-downcase (string-ref str i)))) n) (- i 1)) h))))) (define hash:hash-string hash:hash-string-ci) (define (hash:hash-symbol sym n) (hash:hash-string (symbol->string sym) n)) ;;; This can overflow on implemenatations where inexacts have a larger ;;; range than exact integers. (define hash:hash-number (if (provided? 'inexact) (lambda (num n) (if (integer? num) (modulo (if (exact? num) num (inexact->exact num)) n) (hash:hash-string-ci (number->string (if (exact? num) (exact->inexact num) num)) n))) (lambda (num n) (if (integer? num) (modulo num n) (hash:hash-string-ci (number->string num) n))))) ;@ (define (hash obj n) (let hs ((d 10) (obj obj)) (cond ((number? obj) (hash:hash-number obj n)) ((char? obj) (modulo (char->integer (char-downcase obj)) n)) ((symbol? obj) (hash:hash-symbol obj n)) ((string? obj) (hash:hash-string obj n)) ((vector? obj) (let ((len (vector-length obj))) (if (> len 5) (let lp ((h 1) (i (quotient d 2))) (if (positive? i) (lp (modulo (+ (* h 256) (hs 2 (vector-ref obj (modulo h len)))) n) (- i 1)) h)) (let loop ((h (- n 1)) (i (- len 1))) (if (>= i 0) (loop (modulo (+ (* h 256) (hs (quotient d len) (vector-ref obj i))) n) (- i 1)) h))))) ((pair? obj) (if (positive? d) (modulo (+ (hs (quotient d 2) (car obj)) (hs (quotient d 2) (cdr obj))) n) 1)) (else (modulo (cond ((null? obj) 256) ((boolean? obj) (if obj 257 258)) ((eof-object? obj) 259) ((input-port? obj) 260) ((output-port? obj) 261) ((procedure? obj) 262) (else 263)) n))))) (define hash:hash hash) ;;; Object-hash is somewhat expensive on copying GC systems (like ;;; PC-Scheme and MITScheme). We use it only on strings, pairs, and ;;; vectors. This also allows us to use it for both hashq and hashv. ;@ (define hashv (if (provided? 'object-hash) (lambda (obj k) (if (or (string? obj) (pair? obj) (vector? obj)) (modulo (object-hash obj) k) (hash:hash obj k))) hash)) (define hashq hashv) slib-3b1/hashtab.scm0000644001705200017500000001240410137476076012322 0ustar tbtb; "hashtab.scm", hash tables for Scheme. ; Copyright (C) 1992, 1993, 2003 Aubrey Jaffer ; ;Permission to copy this software, to modify it, to redistribute it, ;to distribute modified versions, and to use it for any purpose is ;granted, subject to the following restrictions and understandings. ; ;1. Any copy made of this software must include this copyright notice ;in full. ; ;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; ;3. In conjunction with products arising from the use of this ;material, there shall be no use of my name in any advertising, ;promotional, or sales literature without prior written consent in ;each case. (require 'hash) (require 'alist) ;;@code{(require 'hash-table)} ;;@ftindex hash-table ;;@body ;;Returns a hash function (like @code{hashq}, @code{hashv}, or ;;@code{hash}) corresponding to the equality predicate @var{pred}. ;;@var{pred} should be @code{eq?}, @code{eqv?}, @code{equal?}, @code{=}, ;;@code{char=?}, @code{char-ci=?}, @code{string=?}, or ;;@code{string-ci=?}. (define (predicate->hash pred) (cond ((eq? pred eq?) hashq) ((eq? pred eqv?) hashv) ((eq? pred equal?) hash) ((eq? pred =) hashv) ((eq? pred char=?) hashv) ((eq? pred char-ci=?) hashv) ((eq? pred string=?) hash) ((eq? pred string-ci=?) hash) (else (slib:error "unknown predicate for hash" pred)))) ;;@noindent ;;A hash table is a vector of association lists. ;;@body ;;Returns a vector of @var{k} empty (association) lists. (define (make-hash-table k) (make-vector k '())) ;;@noindent ;;Hash table functions provide utilities for an associative database. ;;These functions take an equality predicate, @var{pred}, as an argument. ;;@var{pred} should be @code{eq?}, @code{eqv?}, @code{equal?}, @code{=}, ;;@code{char=?}, @code{char-ci=?}, @code{string=?}, or ;;@code{string-ci=?}. ;;@body ;;Returns a hash association function of 2 arguments, @var{key} and ;;@var{hashtab}, corresponding to @var{pred}. The returned function ;;returns a key-value pair whose key is @var{pred}-equal to its first ;;argument or @code{#f} if no key in @var{hashtab} is @var{pred}-equal to ;;the first argument. (define (predicate->hash-asso pred) (let ((hashfun (predicate->hash pred)) (asso (predicate->asso pred))) (lambda (key hashtab) (asso key (vector-ref hashtab (hashfun key (vector-length hashtab))))))) ;;@body ;;Returns a procedure of 2 arguments, @var{hashtab} and @var{key}, which ;;returns the value associated with @var{key} in @var{hashtab} or ;;@code{#f} if @var{key} does not appear in @var{hashtab}. (define (hash-inquirer pred) (let ((hashfun (predicate->hash pred)) (ainq (alist-inquirer pred))) (lambda (hashtab key) (ainq (vector-ref hashtab (hashfun key (vector-length hashtab))) key)))) ;;@body ;;Returns a procedure of 3 arguments, @var{hashtab}, @var{key}, and ;;@var{value}, which modifies @var{hashtab} so that @var{key} and ;;@var{value} associated. Any previous value associated with @var{key} ;;will be lost. (define (hash-associator pred) (let ((hashfun (predicate->hash pred)) (asso (alist-associator pred))) (lambda (hashtab key val) (let* ((num (hashfun key (vector-length hashtab)))) (vector-set! hashtab num (asso (vector-ref hashtab num) key val))) hashtab))) ;;@body ;;Returns a procedure of 2 arguments, @var{hashtab} and @var{key}, which ;;modifies @var{hashtab} so that the association whose key is @var{key} is ;;removed. (define (hash-remover pred) (let ((hashfun (predicate->hash pred)) (arem (alist-remover pred))) (lambda (hashtab key) (let* ((num (hashfun key (vector-length hashtab)))) (vector-set! hashtab num (arem (vector-ref hashtab num) key))) hashtab))) ;;@args proc hash-table ;;Returns a new hash table formed by mapping @var{proc} over the ;;keys and values of @var{hash-table}. @var{proc} must be a function of 2 ;;arguments which returns the new value part. (define (hash-map proc ht) (define nht (make-vector (vector-length ht))) (do ((i (+ -1 (vector-length ht)) (+ -1 i))) ((negative? i) nht) (vector-set! nht i (alist-map proc (vector-ref ht i))))) ;;@args proc hash-table ;;Applies @var{proc} to each pair of keys and values of @var{hash-table}. ;;@var{proc} must be a function of 2 arguments. The returned value is ;;unspecified. (define (hash-for-each proc ht) (do ((i (+ -1 (vector-length ht)) (+ -1 i))) ((negative? i)) (alist-for-each proc (vector-ref ht i)))) ;;@body ;;@0 accepts a hash table predicate and returns a function of two ;;arguments @var{hashtab} and @var{new-k} which is specialized for ;;that predicate. ;; ;;This function is used for nondestrutively resizing a hash table. ;;@var{hashtab} should be an existing hash-table using @1, @var{new-k} ;;is the size of a new hash table to be returned. The new hash table ;;will have all of the associations of the old hash table. (define (hash-rehasher pred) (let ((hashfun (predicate->hash pred))) (lambda (hashtab newk) (let ((newtab (make-hash-table newk))) (hash-for-each (lambda (key value) (let ((num (hashfun key newk))) (vector-set! newtab num (cons (cons key value) (vector-ref newtab num))))) hashtab) newtab)))) slib-3b1/hashtab.txi0000644001705200017500000000525310747237373012352 0ustar tbtb@code{(require 'hash-table)} @ftindex hash-table @defun predicate->hash pred Returns a hash function (like @code{hashq}, @code{hashv}, or @code{hash}) corresponding to the equality predicate @var{pred}. @var{pred} should be @code{eq?}, @code{eqv?}, @code{equal?}, @code{=}, @code{char=?}, @code{char-ci=?}, @code{string=?}, or @code{string-ci=?}. @end defun @noindent A hash table is a vector of association lists. @defun make-hash-table k Returns a vector of @var{k} empty (association) lists. @end defun @noindent Hash table functions provide utilities for an associative database. These functions take an equality predicate, @var{pred}, as an argument. @var{pred} should be @code{eq?}, @code{eqv?}, @code{equal?}, @code{=}, @code{char=?}, @code{char-ci=?}, @code{string=?}, or @code{string-ci=?}. @defun predicate->hash-asso pred Returns a hash association function of 2 arguments, @var{key} and @var{hashtab}, corresponding to @var{pred}. The returned function returns a key-value pair whose key is @var{pred}-equal to its first argument or @code{#f} if no key in @var{hashtab} is @var{pred}-equal to the first argument. @end defun @defun hash-inquirer pred Returns a procedure of 2 arguments, @var{hashtab} and @var{key}, which returns the value associated with @var{key} in @var{hashtab} or @code{#f} if @var{key} does not appear in @var{hashtab}. @end defun @defun hash-associator pred Returns a procedure of 3 arguments, @var{hashtab}, @var{key}, and @var{value}, which modifies @var{hashtab} so that @var{key} and @var{value} associated. Any previous value associated with @var{key} will be lost. @end defun @defun hash-remover pred Returns a procedure of 2 arguments, @var{hashtab} and @var{key}, which modifies @var{hashtab} so that the association whose key is @var{key} is removed. @end defun @defun hash-map proc hash-table Returns a new hash table formed by mapping @var{proc} over the keys and values of @var{hash-table}. @var{proc} must be a function of 2 arguments which returns the new value part. @end defun @defun hash-for-each proc hash-table Applies @var{proc} to each pair of keys and values of @var{hash-table}. @var{proc} must be a function of 2 arguments. The returned value is unspecified. @end defun @defun hash-rehasher pred @code{hash-rehasher} accepts a hash table predicate and returns a function of two arguments @var{hashtab} and @var{new-k} which is specialized for that predicate. This function is used for nondestrutively resizing a hash table. @var{hashtab} should be an existing hash-table using @var{pred}, @var{new-k} is the size of a new hash table to be returned. The new hash table will have all of the associations of the old hash table. @end defun slib-3b1/html4each.scm0000644001705200017500000002063010170361627012551 0ustar tbtb;;;; HTML scan calls procedures for word, tag, whitespac, and newline. ;;; Copyright 2002 Aubrey Jaffer ; ;Permission to copy this software, to modify it, to redistribute it, ;to distribute modified versions, and to use it for any purpose is ;granted, subject to the following restrictions and understandings. ; ;1. Any copy made of this software must include this copyright notice ;in full. ; ;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; ;3. In conjunction with products arising from the use of this ;material, there shall be no use of my name in any advertising, ;promotional, or sales literature without prior written consent in ;each case. (require 'line-i/o) (require 'string-port) (require 'scanf) (require-if 'compiling 'string-case) ;;@code{(require 'html-for-each)} ;;@ftindex html-for-each ;;@body ;;@1 is an input port or a string naming an existing file containing ;;HTML text. ;;@2 is a procedure of one argument or #f. ;;@3 is a procedure of one argument or #f. ;;@4 is a procedure of one argument or #f. ;;@5 is a procedure of no arguments or #f. ;; ;;@0 opens and reads characters from port @1 or the file named by ;;string @1. Sequential groups of characters are assembled into ;;strings which are either ;; ;;@itemize @bullet ;;@item ;;enclosed by @samp{<} and @samp{>} (hypertext markups or comments); ;;@item ;;end-of-line; ;;@item ;;whitespace; or ;;@item ;;none of the above (words). ;;@end itemize ;; ;;Procedures are called according to these distinctions in order of ;;the string's occurrence in @1. ;; ;;@5 is called with no arguments for end-of-line @emph{not within a ;;markup or comment}. ;; ;;@4 is called with strings of non-newline whitespace. ;; ;;@3 is called with hypertext markup strings (including @samp{<} and ;;@samp{>}). ;; ;;@2 is called with the remaining strings. ;; ;;@0 returns an unspecified value. (define (html-for-each file word-proc markup-proc white-proc newline-proc) (define nl (string #\newline)) (define (string-index str . chrs) (define len (string-length str)) (do ((pos 0 (+ 1 pos))) ((or (>= pos len) (memv (string-ref str pos) chrs)) (and (< pos len) pos)))) (define (proc-words line edx) (let loop ((idx 0)) (define ldx idx) (do ((idx idx (+ 1 idx))) ((or (>= idx edx) (not (char-whitespace? (string-ref line idx)))) (do ((jdx idx (+ 1 jdx))) ((or (>= jdx edx) (char-whitespace? (string-ref line jdx))) (and white-proc (not (= ldx idx)) (white-proc (substring line ldx idx))) (and word-proc (not (= idx jdx)) (word-proc (substring line idx jdx))) (if (< jdx edx) (loop jdx)))))))) ((if (input-port? file) call-with-open-ports call-with-input-file) file (lambda (iport) (do ((line (read-line iport) (read-line iport))) ((eof-object? line)) (do ((idx (string-index line #\<) (string-index line #\<))) ((not idx) (proc-words line (string-length line))) ; seen '<' (proc-words line idx) (let ((trm (if (and (<= (+ 4 idx) (string-length line)) (string=? "" #\>))) (let loop ((lne (substring line idx (string-length line))) (tag "") (quot #f)) (define edx (or (eof-object? lne) (if quot (string-index lne quot) (if (char? trm) (string-index lne #\" #\' #\>) (string-index lne #\>))))) (cond ((not edx) ; still inside tag ;;(print quot trm 'within-tag lne) (loop (read-line iport) (and markup-proc (string-append tag lne nl)) quot)) ((eqv? #t edx) ; EOF ;;(print quot trm 'eof lne) (slib:error 'unterminated 'HTML 'entity file) (and markup-proc (markup-proc tag))) ((eqv? quot (string-ref lne edx)) ; end of quoted string ;;(print quot trm 'end-quote lne) (set! edx (+ 1 edx)) (loop (substring lne edx (string-length lne)) (and markup-proc (string-append tag (substring lne 0 edx))) #f)) ((not (eqv? #\> (string-ref lne edx))) ; start of quoted ;;(print quot trm 'start-quote lne) (set! edx (+ 1 edx)) (loop (substring lne edx (string-length lne)) (and markup-proc (string-append tag (substring lne 0 edx))) (string-ref lne (+ -1 edx)))) ((or (and (string? trm) ; found matching '>' or '-->' (<= 2 edx) (equal? trm (substring lne (+ -2 edx) (+ 1 edx)))) (eqv? (string-ref lne edx) trm)) ;;(print quot trm 'end-> lne) (set! edx (+ 1 edx)) (and markup-proc (markup-proc (string-append tag (substring lne 0 edx)))) ; process words after '>' (set! line (substring lne edx (string-length lne)))) (else ;;(print quot trm 'within-comment lne) (set! edx (+ 1 edx)) (loop (substring lne edx (string-length lne)) (and markup-proc (string-append tag (substring lne 0 edx))) #f)))))) (and newline-proc (newline-proc)))))) ;;@args file limit ;;@args file ;;@1 is an input port or a string naming an existing file containing ;;HTML text. If supplied, @2 must be an integer. @2 defaults to ;;1000. ;; ;;@0 opens and reads HTML from port @1 or the file named by string @1, ;;until reaching the (mandatory) @samp{TITLE} field. @0 returns the ;;title string with adjacent whitespaces collapsed to one space. @0 ;;returns #f if the title field is empty, absent, if the first ;;character read from @1 is not @samp{#\<}, or if the end of title is ;;not found within the first (approximately) @2 words. (define (html:read-title file . limit) (set! limit (if (null? limit) 1000 (* 2 (car limit)))) ((if (input-port? file) call-with-open-ports call-with-input-file) file (lambda (port) (and (eqv? #\< (peek-char port)) (call-with-current-continuation (lambda (return) (define (cnt . args) (if (negative? limit) (return #f) (set! limit (+ -1 limit)))) (define capturing? #f) (define text '()) (html-for-each port (lambda (str) (cnt) (if capturing? (set! text (cons " " (cons str text))))) (lambda (str) (cnt) (cond ((prefix-ci? "symbol}) consed onto an association list of the ;;attribute name-symbols and values. Each value is a number or ;;string; or #t if the name had no value assigned within the markup. (define (htm-fields htm) (require 'string-case) (and (not (and (> (string-length htm) 4) (equal? "' that terminates the comment. CDSECT The current position is right after `' combination that terminates PI. [16] PI ::= '' Char*)))? '?>' -- Function: ssax:skip-internal-dtd port The current pos in the port is inside an internal DTD subset (e.g., after reading `#\[' that begins an internal DTD subset) Skip until the `]>' combination that terminates this DTD. -- Function: ssax:read-cdata-body port str-handler seed This procedure must be called after we have read a string `' combination is the end of the CDATA section. `>' is treated as an embedded `>' character. * `<' and `&' are not specially recognized (and are not expanded)! -- Function: ssax:read-char-ref port [66] CharRef ::= '&#' [0-9]+ ';' | '&#x' [0-9a-fA-F]+ ';' This procedure must be called after we we have read `&#' that introduces a char reference. The procedure reads this reference and returns the corresponding char. The current position in PORT will be after the `;' that terminates the char reference. Faults detected: WFC: XML-Spec.html#wf-Legalchar According to Section `4.1 Character and Entity References' of the XML Recommendation: "[Definition: A character reference refers to a specific character in the ISO/IEC 10646 character set, for example one not directly accessible from available input devices.]" -- Function: ssax:handle-parsed-entity port name entities content-handler str-handler seed Expands and handles a parsed-entity reference. NAME is a symbol, the name of the parsed entity to expand. CONTENT-HANDLER is a procedure of arguments PORT, ENTITIES, and SEED that returns a seed. STR-HANDLER is called if the entity in question is a pre-declared entity. `ssax:handle-parsed-entity' returns the result returned by CONTENT-HANDLER or STR-HANDLER. Faults detected: WFC: XML-Spec.html#wf-entdeclared WFC: XML-Spec.html#norecursion -- Function: attlist-add attlist name-value Add a NAME-VALUE pair to the existing ATTLIST, preserving its sorted ascending order; and return the new list. Return #f if a pair with the same name already exists in ATTLIST -- Function: attlist-remove-top attlist Given an non-null ATTLIST, return a pair of values: the top and the rest. -- Function: ssax:read-attributes port entities This procedure reads and parses a production "Attribute". [41] Attribute ::= Name Eq AttValue [10] AttValue ::= '"' ([^<&"] | Reference)* '"' | "'" ([^<&'] | Reference)* "'" [25] Eq ::= S? '=' S? The procedure returns an ATTLIST, of Name (as UNRES-NAME), Value (as string) pairs. The current character on the PORT is a non-whitespace character that is not an NCName-starting character. Note the following rules to keep in mind when reading an "AttValue": Before the value of an attribute is passed to the application or checked for validity, the XML processor must normalize it as follows: * A character reference is processed by appending the referenced character to the attribute value. * An entity reference is processed by recursively processing the replacement text of the entity. The named entities `amp', `lt', `gt', `quot', and `apos' are pre-declared. * A whitespace character (#x20, #x0D, #x0A, #x09) is processed by appending #x20 to the normalized value, except that only a single #x20 is appended for a "#x0D#x0A" sequence that is part of an external parsed entity or the literal entity value of an internal parsed entity. * Other characters are processed by appending them to the normalized value. Faults detected: WFC: XML-Spec.html#CleanAttrVals WFC: XML-Spec.html#uniqattspec -- Function: ssax:resolve-name port unres-name namespaces apply-default-ns? Convert an UNRES-NAME to a RES-NAME, given the appropriate NAMESPACES declarations. The last parameter, APPLY-DEFAULT-NS?, determines if the default namespace applies (for instance, it does not for attribute names). Per REC-xml-names/#nsc-NSDeclared, the "xml" prefix is considered pre-declared and bound to the namespace name "http://www.w3.org/XML/1998/namespace". `ssax:resolve-name' tests for the namespace constraints: `http://www.w3.org/TR/REC-xml-names/#nsc-NSDeclared' -- Function: ssax:complete-start-tag tag port elems entities namespaces Complete parsing of a start-tag markup. `ssax:complete-start-tag' must be called after the start tag token has been read. TAG is an UNRES-NAME. ELEMS is an instance of the ELEMS slot of XML-DECL; it can be #f to tell the function to do _no_ validation of elements and their attributes. `ssax:complete-start-tag' returns several values: * ELEM-GI: a RES-NAME. * ATTRIBUTES: element's attributes, an ATTLIST of (RES-NAME . STRING) pairs. The list does NOT include xmlns attributes. * NAMESPACES: the input list of namespaces amended with namespace (re-)declarations contained within the start-tag under parsing * ELEM-CONTENT-MODEL On exit, the current position in PORT will be the first character after `>' that terminates the start-tag markup. Faults detected: VC: XML-Spec.html#enum VC: XML-Spec.html#RequiredAttr VC: XML-Spec.html#FixedAttr VC: XML-Spec.html#ValueType WFC: XML-Spec.html#uniqattspec (after namespaces prefixes are resolved) VC: XML-Spec.html#elementvalid WFC: REC-xml-names/#dt-NSName _Note_: although XML Recommendation does not explicitly say it, xmlns and xmlns: attributes don't have to be declared (although they can be declared, to specify their default value). -- Function: ssax:read-external-id port Parses an ExternalID production: [75] ExternalID ::= 'SYSTEM' S SystemLiteral | 'PUBLIC' S PubidLiteral S SystemLiteral [11] SystemLiteral ::= ('"' [^"]* '"') | ("'" [^']* "'") [12] PubidLiteral ::= '"' PubidChar* '"' | "'" (PubidChar - "'")* "'" [13] PubidChar ::= #x20 | #x0D | #x0A | [a-zA-Z0-9] | [-'()+,./:=?;!*#@$_%] Call `ssax:read-external-id' when an ExternalID is expected; that is, the current character must be either #\S or #\P that starts correspondingly a SYSTEM or PUBLIC token. `ssax:read-external-id' returns the SYSTEMLITERAL as a string. A PUBIDLITERAL is disregarded if present. 4.11.5 Mid-Level Parsers and Scanners ------------------------------------- These procedures parse productions corresponding to the whole (document) entity or its higher-level pieces (prolog, root element, etc). -- Function: ssax:scan-misc port Scan the Misc production in the context: [1] document ::= prolog element Misc* [22] prolog ::= XMLDecl? Misc* (doctypedec l Misc*)? [27] Misc ::= Comment | PI | S Call `ssax:scan-misc' in the prolog or epilog contexts. In these contexts, whitespaces are completely ignored. The return value from `ssax:scan-misc' is either a PI-token, a DECL-token, a START token, or *EOF*. Comments are ignored and not reported. -- Function: ssax:read-char-data port expect-eof? str-handler iseed Read the character content of an XML document or an XML element. [43] content ::= (element | CharData | Reference | CDSect | PI | Comment)* To be more precise, `ssax:read-char-data' reads CharData, expands CDSect and character entities, and skips comments. `ssax:read-char-data' stops at a named reference, EOF, at the beginning of a PI, or a start/end tag. EXPECT-EOF? is a boolean indicating if EOF is normal; i.e., the character data may be terminated by the EOF. EOF is normal while processing a parsed entity. ISEED is an argument passed to the first invocation of STR-HANDLER. `ssax:read-char-data' returns two results: SEED and TOKEN. The SEED is the result of the last invocation of STR-HANDLER, or the original ISEED if STR-HANDLER was never called. TOKEN can be either an eof-object (this can happen only if EXPECT-EOF? was #t), or: * an xml-token describing a START tag or an END-tag; For a start token, the caller has to finish reading it. * an xml-token describing the beginning of a PI. It's up to an application to read or skip through the rest of this PI; * an xml-token describing a named entity reference. CDATA sections and character references are expanded inline and never returned. Comments are silently disregarded. As the XML Recommendation requires, all whitespace in character data must be preserved. However, a CR character (#x0D) must be disregarded if it appears before a LF character (#x0A), or replaced by a #x0A character otherwise. See Secs. 2.10 and 2.11 of the XML Recommendation. See also the canonical XML Recommendation. -- Function: ssax:assert-token token kind gi error-cont Make sure that TOKEN is of anticipated KIND and has anticipated GI. Note that the GI argument may actually be a pair of two symbols, Namespace-URI or the prefix, and of the localname. If the assertion fails, ERROR-CONT is evaluated by passing it three arguments: TOKEN KIND GI. The result of ERROR-CONT is returned. 4.11.6 High-level Parsers ------------------------- These procedures are to instantiate a SSAX parser. A user can instantiate the parser to do the full validation, or no validation, or any particular validation. The user specifies which PI he wants to be notified about. The user tells what to do with the parsed character and element data. The latter handlers determine if the parsing follows a SAX or a DOM model. -- Function: ssax:make-pi-parser my-pi-handlers Create a parser to parse and process one Processing Element (PI). MY-PI-HANDLERS is an association list of pairs `(PI-TAG . PI-HANDLER)' where PI-TAG is an NCName symbol, the PI target; and PI-HANDLER is a procedure taking arguments PORT, PI-TAG, and SEED. PI-HANDLER should read the rest of the PI up to and including the combination `?>' that terminates the PI. The handler should return a new seed. One of the PI-TAGs may be the symbol `*DEFAULT*'. The corresponding handler will handle PIs that no other handler will. If the *DEFAULT* PI-TAG is not specified, `ssax:make-pi-parser' will assume the default handler that skips the body of the PI. `ssax:make-pi-parser' returns a procedure of arguments PORT, PI-TAG, and SEED; that will parse the current PI according to MY-PI-HANDLERS. -- Function: ssax:make-elem-parser my-new-level-seed my-finish-element my-char-data-handler my-pi-handlers Create a parser to parse and process one element, including its character content or children elements. The parser is typically applied to the root element of a document. MY-NEW-LEVEL-SEED is a procedure taking arguments: ELEM-GI ATTRIBUTES NAMESPACES EXPECTED-CONTENT SEED where ELEM-GI is a RES-NAME of the element about to be processed. MY-NEW-LEVEL-SEED is to generate the seed to be passed to handlers that process the content of the element. MY-FINISH-ELEMENT is a procedure taking arguments: ELEM-GI ATTRIBUTES NAMESPACES PARENT-SEED SEED MY-FINISH-ELEMENT is called when parsing of ELEM-GI is finished. The SEED is the result from the last content parser (or from MY-NEW-LEVEL-SEED if the element has the empty content). PARENT-SEED is the same seed as was passed to MY-NEW-LEVEL-SEED. MY-FINISH-ELEMENT is to generate a seed that will be the result of the element parser. MY-CHAR-DATA-HANDLER is a STR-HANDLER as described in Data Types above. MY-PI-HANDLERS is as described for `ssax:make-pi-handler' above. The generated parser is a procedure taking arguments: START-TAG-HEAD PORT ELEMS ENTITIES NAMESPACES PRESERVE-WS? SEED The procedure must be called after the start tag token has been read. START-TAG-HEAD is an UNRES-NAME from the start-element tag. ELEMS is an instance of ELEMS slot of XML-DECL. Faults detected: VC: XML-Spec.html#elementvalid WFC: XML-Spec.html#GIMatch -- Function: ssax:make-parser user-handler-tag user-handler ... Create an XML parser, an instance of the XML parsing framework. This will be a SAX, a DOM, or a specialized parser depending on the supplied user-handlers. `ssax:make-parser' takes an even number of arguments; USER-HANDLER-TAG is a symbol that identifies a procedure (or association list for `PROCESSING-INSTRUCTIONS') (USER-HANDLER) that follows the tag. Given below are tags and signatures of the corresponding procedures. Not all tags have to be specified. If some are omitted, reasonable defaults will apply. `DOCTYPE' handler-procedure: PORT DOCNAME SYSTEMID INTERNAL-SUBSET? SEED If INTERNAL-SUBSET? is #t, the current position in the port is right after we have read `[' that begins the internal DTD subset. We must finish reading of this subset before we return (or must call `skip-internal-dtd' if we aren't interested in reading it). PORT at exit must be at the first symbol after the whole DOCTYPE declaration. The handler-procedure must generate four values: ELEMS ENTITIES NAMESPACES SEED ELEMS is as defined for the ELEMS slot of XML-DECL. It may be #f to switch off validation. NAMESPACES will typically contain USER-PREFIXes for selected URI-SYMBs. The default handler-procedure skips the internal subset, if any, and returns `(values #f '() '() seed)'. `UNDECL-ROOT' procedure: ELEM-GI SEED where ELEM-GI is an UNRES-NAME of the root element. This procedure is called when an XML document under parsing contains _no_ DOCTYPE declaration. The handler-procedure, as a DOCTYPE handler procedure above, must generate four values: ELEMS ENTITIES NAMESPACES SEED The default handler-procedure returns (values #f '() '() seed) `DECL-ROOT' procedure: ELEM-GI SEED where ELEM-GI is an UNRES-NAME of the root element. This procedure is called when an XML document under parsing does contains the DOCTYPE declaration. The handler-procedure must generate a new SEED (and verify that the name of the root element matches the doctype, if the handler so wishes). The default handler-procedure is the identity function. `NEW-LEVEL-SEED' procedure: see ssax:make-elem-parser, my-new-level-seed `FINISH-ELEMENT' procedure: see ssax:make-elem-parser, my-finish-element `CHAR-DATA-HANDLER' procedure: see ssax:make-elem-parser, my-char-data-handler `PROCESSING-INSTRUCTIONS' association list as is passed to `ssax:make-pi-parser'. The default value is '() The generated parser is a procedure of arguments PORT and SEED. This procedure parses the document prolog and then exits to an element parser (created by `ssax:make-elem-parser') to handle the rest. [1] document ::= prolog element Misc* [22] prolog ::= XMLDecl? Misc* (doctypedec | Misc*)? [27] Misc ::= Comment | PI | S [28] doctypedecl ::= '' [29] markupdecl ::= elementdecl | AttlistDecl | EntityDecl | NotationDecl | PI | Comment 4.11.7 Parsing XML to SXML -------------------------- -- Function: ssax:xml->sxml port namespace-prefix-assig This is an instance of the SSAX parser that returns an SXML representation of the XML document to be read from PORT. NAMESPACE-PREFIX-ASSIG is a list of `(USER-PREFIX . URI-STRING)' that assigns USER-PREFIXes to certain namespaces identified by particular URI-STRINGs. It may be an empty list. `ssax:xml->sxml' returns an SXML tree. The port points out to the first character after the root element.  File: slib.info, Node: Printing Scheme, Next: Time and Date, Prev: Parsing XML, Up: Textual Conversion Packages 4.12 Printing Scheme ==================== * Menu: * Generic-Write:: 'generic-write * Object-To-String:: 'object->string * Pretty-Print:: 'pretty-print, 'pprint-file  File: slib.info, Node: Generic-Write, Next: Object-To-String, Prev: Printing Scheme, Up: Printing Scheme 4.12.1 Generic-Write -------------------- `(require 'generic-write)' `generic-write' is a procedure that transforms a Scheme data value (or Scheme program expression) into its textual representation and prints it. The interface to the procedure is sufficiently general to easily implement other useful formatting procedures such as pretty printing, output to a string and truncated output. -- Procedure: generic-write obj display? width output OBJ Scheme data value to transform. DISPLAY? Boolean, controls whether characters and strings are quoted. WIDTH Extended boolean, selects format: #f single line format integer > 0 pretty-print (value = max nb of chars per line) OUTPUT Procedure of 1 argument of string type, called repeatedly with successive substrings of the textual representation. This procedure can return `#f' to stop the transformation. The value returned by `generic-write' is undefined. Examples: (write obj) == (generic-write obj #f #f DISPLAY-STRING) (display obj) == (generic-write obj #t #f DISPLAY-STRING) where DISPLAY-STRING == (lambda (s) (for-each write-char (string->list s)) #t)  File: slib.info, Node: Object-To-String, Next: Pretty-Print, Prev: Generic-Write, Up: Printing Scheme 4.12.2 Object-To-String ----------------------- `(require 'object->string)' -- Function: object->string obj Returns the textual representation of OBJ as a string. -- Function: object->limited-string obj limit Returns the textual representation of OBJ as a string of length at most LIMIT.  File: slib.info, Node: Pretty-Print, Prev: Object-To-String, Up: Printing Scheme 4.12.3 Pretty-Print ------------------- `(require 'pretty-print)' -- Procedure: pretty-print obj -- Procedure: pretty-print obj port `pretty-print's OBJ on PORT. If PORT is not specified, `current-output-port' is used. Example: (pretty-print '((1 2 3 4 5) (6 7 8 9 10) (11 12 13 14 15) (16 17 18 19 20) (21 22 23 24 25))) -| ((1 2 3 4 5) -| (6 7 8 9 10) -| (11 12 13 14 15) -| (16 17 18 19 20) -| (21 22 23 24 25)) -- Procedure: pretty-print->string obj -- Procedure: pretty-print->string obj width Returns the string of OBJ `pretty-print'ed in WIDTH columns. If WIDTH is not specified, `(output-port-width)' is used. Example: (pretty-print->string '((1 2 3 4 5) (6 7 8 9 10) (11 12 13 14 15) (16 17 18 19 20) (21 22 23 24 25))) => "((1 2 3 4 5) (6 7 8 9 10) (11 12 13 14 15) (16 17 18 19 20) (21 22 23 24 25)) " (pretty-print->string '((1 2 3 4 5) (6 7 8 9 10) (11 12 13 14 15) (16 17 18 19 20) (21 22 23 24 25)) 16) => "((1 2 3 4 5) (6 7 8 9 10) (11 12 13 14 15) (16 17 18 19 20) (21 22 23 24 25)) " `(require 'pprint-file)' -- Procedure: pprint-file infile -- Procedure: pprint-file infile outfile Pretty-prints all the code in INFILE. If OUTFILE is specified, the output goes to OUTFILE, otherwise it goes to `(current-output-port)'. -- Function: pprint-filter-file infile proc outfile -- Function: pprint-filter-file infile proc INFILE is a port or a string naming an existing file. Scheme source code expressions and definitions are read from the port (or file) and PROC is applied to them sequentially. OUTFILE is a port or a string. If no OUTFILE is specified then `current-output-port' is assumed. These expanded expressions are then `pretty-print'ed to this port. Whitepsace and comments (introduced by `;') which are not part of scheme expressions are reproduced in the output. This procedure does not affect the values returned by `current-input-port' and `current-output-port'. `pprint-filter-file' can be used to pre-compile macro-expansion and thus can reduce loading time. The following will write into `exp-code.scm' the result of expanding all defmacros in `code.scm'. (require 'pprint-file) (require 'defmacroexpand) (defmacro:load "my-macros.scm") (pprint-filter-file "code.scm" defmacro:expand* "exp-code.scm")  File: slib.info, Node: Time and Date, Next: NCBI-DNA, Prev: Printing Scheme, Up: Textual Conversion Packages 4.13 Time and Date ================== * Menu: * Time Zone:: * Posix Time:: 'posix-time * Common-Lisp Time:: 'common-lisp-time * Time Infrastructure:: If `(provided? 'current-time)': The procedures `current-time', `difftime', and `offset-time' deal with a "calendar time" datatype which may or may not be disjoint from other Scheme datatypes. -- Function: current-time Returns the time since 00:00:00 GMT, January 1, 1970, measured in seconds. Note that the reference time is different from the reference time for `get-universal-time' in *Note Common-Lisp Time::. -- Function: difftime caltime1 caltime0 Returns the difference (number of seconds) between twe calendar times: CALTIME1 - CALTIME0. CALTIME0 may also be a number. -- Function: offset-time caltime offset Returns the calendar time of CALTIME offset by OFFSET number of seconds `(+ caltime offset)'.  File: slib.info, Node: Time Zone, Next: Posix Time, Prev: Time and Date, Up: Time and Date 4.13.1 Time Zone ---------------- (require 'time-zone) -- Data Format: TZ-string POSIX standards specify several formats for encoding time-zone rules. : If the first character of is `/', then specifies the absolute pathname of a tzfile(5) format time-zone file. Otherwise, is interpreted as a pathname within TZFILE:VICINITY (/usr/lib/zoneinfo/) naming a tzfile(5) format time-zone file. The string consists of 3 or more alphabetic characters. specifies the time difference from GMT. The is positive if the local time zone is west of the Prime Meridian and negative if it is east. can be the number of hours or hours and minutes (and optionally seconds) separated by `:'. For example, `-4:30'. is the at least 3 alphabetic characters naming the local daylight-savings-time. specifies the offset from the Prime Meridian when daylight-savings-time is in effect. The non-tzfile formats can optionally be followed by transition times specifying the day and time when a zone changes from standard to daylight-savings and back again. ,/