From 8466d8cfa486fb30d1755c4261b781135083787b Mon Sep 17 00:00:00 2001 From: Bryan Newbold Date: Mon, 20 Feb 2017 00:05:29 -0800 Subject: Import Upstream version 3a1 --- ANNOUNCE | 136 +- Bev2slib.scm | 2 +- COPYING | 2 +- ChangeLog | 2079 +++++++++- DrScheme.init | 61 +- FAQ | 23 +- Makefile | 309 +- README | 88 +- RScheme.init | 50 +- STk.init | 63 +- Template.scm | 146 +- alist.scm | 55 +- alist.txi | 70 + alistab.scm | 33 +- array.scm | 186 +- array.txi | 227 ++ arraymap.scm | 83 +- arraymap.txi | 68 + batch.scm | 145 +- bigloo.init | 82 +- break.scm | 29 +- byte.scm | 214 +- byte.txi | 179 + bytenumb.scm | 346 ++ bytenumb.txi | 181 + chap.scm | 47 +- chap.txi | 46 + charplot.scm | 380 +- chez.init | 75 +- cie1931.xyz | 82 + cie1964.xyz | 82 + cltime.scm | 10 +- coerce.scm | 2 +- collect.scm | 105 +- collectx.scm | 247 ++ color.scm | 674 ++++ color.txi | 345 ++ colornam.scm | 117 + colornam.txi | 75 + colorspc.scm | 536 +++ comlist.scm | 317 +- comparse.scm | 76 +- comparse.txi | 81 + crc.scm | 137 + cring.scm | 30 +- cvs.scm | 140 + cvs.txi | 32 + daylight.scm | 356 ++ daylight.txi | 117 + db2html.scm | 77 +- db2html.txi | 13 +- dbcom.scm | 215 ++ dbinterp.scm | 34 + dbrowse.scm | 14 +- dbsyn.scm | 54 + dbutil.scm | 674 ++-- dbutil.txi | 219 ++ debug.scm | 6 +- defmacex.scm | 4 +- determ.scm | 157 +- determ.txi | 47 + differ.scm | 521 ++- differ.txi | 105 + dirs.scm | 98 + dirs.txi | 46 + dwindtst.scm | 2 +- dynamic.scm | 10 +- dynwind.scm | 6 +- elk.init | 69 +- eval.scm | 12 +- factor.scm | 39 +- fft.scm | 44 +- fft.txi | 32 + fluidlet.scm | 9 +- fmtdoc.txi | 434 --- format.scm | 1676 --------- formatst.scm | 647 ---- gambit.init | 73 +- genwrite.scm | 4 +- getopt.scm | 34 +- getparam.scm | 132 +- getparam.txi | 85 + glob.scm | 136 +- glob.txi | 100 + grapheps.ps | 344 ++ grapheps.scm | 617 +++ grapheps.txi | 465 +++ guile.init | 420 ++- hash.scm | 42 +- hashtab.scm | 78 +- hashtab.txi | 84 + html4each.scm | 240 ++ html4each.txi | 70 + htmlform.scm | 74 +- htmlform.txi | 27 +- http-cgi.scm | 34 +- lineio.scm | 34 +- lineio.txi | 19 +- logical.scm | 335 +- macscheme.init | 47 +- macwork.scm | 18 +- makcrc.scm | 96 - manifest.scm | 350 ++ manifest.txi | 145 + matfile.scm | 187 + matfile.txi | 31 + mbe.scm | 72 +- minimize.scm | 3 +- mitscheme.init | 305 +- mkclrnam.scm | 259 ++ mkclrnam.txi | 54 + mklibcat.scm | 401 +- modular.scm | 180 +- modular.txi | 114 + mulapply.scm | 22 +- mularg.scm | 20 +- mwexpand.scm | 40 +- mwsynrul.scm | 8 +- ncbi-dna.scm | 172 + ncbi-dna.txi | 54 + nclients.scm | 385 -- nclients.txi | 103 - null.scm | 1 + obj2str.scm | 3 +- objdoc.txi | 238 -- object.scm | 18 +- object.texi | 238 ++ paramlst.scm | 18 +- phil-spc.scm | 94 + phil-spc.txi | 38 + plottest.scm | 27 +- pnm.scm | 277 +- pnm.txi | 66 + pp.scm | 8 +- ppfile.scm | 7 +- prec.scm | 72 +- printf.scm | 21 +- priorque.scm | 73 +- priorque.txi | 33 + process.scm | 7 +- promise.scm | 15 +- pscheme.init | 44 +- psxtime.scm | 40 +- qp.scm | 35 +- queue.scm | 77 +- queue.txi | 60 + r4rsyn.scm | 2 +- randinex.scm | 42 +- randinex.txi | 21 +- random.scm | 69 +- random.txi | 26 +- ratize.scm | 43 +- ratize.txi | 41 + rdms.scm | 287 +- recobj.scm | 11 +- record.scm | 27 +- repl.scm | 81 +- report.scm | 116 - require.scm | 280 +- resenecolours.txt | 1410 +++++++ root.scm | 14 +- s48-0_57.init | 85 +- saturate.txt | 39 + sc2.scm | 15 +- sc4opt.scm | 17 +- sc4sc3.scm | 2 +- scainit.scm | 25 +- scamacr.scm | 2 +- scanf.scm | 514 ++- scheme2c.init | 70 +- scheme48.init | 85 +- schmooz.scm | 403 +- schmooz.texi | 18 +- scm.init | 1 - scmacro.scm | 21 +- scsh.init | 63 +- selfset.scm | 2 +- sierpinski.scm | 2 +- simetrix.scm | 5 +- slib.info | 10668 +++++++++++++++++++++++++++++++++++----------------- slib.sh | 119 + slib.spec | 37 +- slib.texi | 7882 +++++++++++++++++++++----------------- solid.scm | 943 +++++ solid.txi | 441 +++ sort.scm | 251 +- soundex.scm | 30 +- srfi-1.scm | 230 +- srfi-1.txi | 254 ++ srfi-2.scm | 41 + srfi-2.txi | 8 + srfi-8.scm | 14 + srfi-8.txi | 8 + srfi-9.scm | 16 + srfi.scm | 2 +- srfi.txi | 42 + stdio.scm | 5 +- strcase.scm | 41 +- strport.scm | 6 +- strsrch.scm | 164 +- structure.scm | 2 +- subarray.scm | 172 + subarray.txi | 94 + synchk.scm | 2 +- synclo.scm | 12 +- synrul.scm | 2 +- t3.init | 49 +- tek40.scm | 92 - tek41.scm | 147 - timezone.scm | 16 +- top-refs.scm | 285 ++ top-refs.txi | 65 + trace.scm | 24 +- transact.scm | 486 +++ transact.txi | 150 + tree.scm | 69 +- tree.txi | 48 + trnscrpt.scm | 18 +- tsort.scm | 58 +- tsort.txi | 53 + tzfile.scm | 134 +- umbscheme.init | 50 +- uri.scm | 139 +- uri.txi | 87 +- values.scm | 4 +- version.txi | 4 +- vet.scm | 218 ++ vet.txi | 35 + vscm.init | 66 +- withfile.scm | 26 +- wttest.scm | 2 +- wttree.scm | 6 +- yasyn.scm | 253 +- 233 files changed, 35357 insertions(+), 14805 deletions(-) create mode 100644 alist.txi create mode 100644 array.txi create mode 100644 arraymap.txi create mode 100644 byte.txi create mode 100644 bytenumb.scm create mode 100644 bytenumb.txi create mode 100644 chap.txi create mode 100644 cie1931.xyz create mode 100644 cie1964.xyz create mode 100644 collectx.scm create mode 100644 color.scm create mode 100644 color.txi create mode 100644 colornam.scm create mode 100644 colornam.txi create mode 100644 colorspc.scm create mode 100644 comparse.txi create mode 100644 crc.scm create mode 100644 cvs.scm create mode 100644 cvs.txi create mode 100644 daylight.scm create mode 100644 daylight.txi create mode 100644 dbcom.scm create mode 100644 dbinterp.scm create mode 100644 dbsyn.scm create mode 100644 dbutil.txi create mode 100644 determ.txi create mode 100644 differ.txi create mode 100644 dirs.scm create mode 100644 dirs.txi create mode 100644 fft.txi delete mode 100644 fmtdoc.txi delete mode 100644 format.scm delete mode 100644 formatst.scm create mode 100644 getparam.txi create mode 100644 glob.txi create mode 100644 grapheps.ps create mode 100644 grapheps.scm create mode 100644 grapheps.txi create mode 100644 hashtab.txi create mode 100644 html4each.scm create mode 100644 html4each.txi delete mode 100644 makcrc.scm create mode 100644 manifest.scm create mode 100644 manifest.txi create mode 100644 matfile.scm create mode 100644 matfile.txi create mode 100644 mkclrnam.scm create mode 100644 mkclrnam.txi create mode 100644 modular.txi create mode 100644 ncbi-dna.scm create mode 100644 ncbi-dna.txi delete mode 100644 nclients.scm delete mode 100644 nclients.txi create mode 100644 null.scm delete mode 100644 objdoc.txi create mode 100644 object.texi create mode 100644 phil-spc.scm create mode 100644 phil-spc.txi create mode 100644 pnm.txi create mode 100644 priorque.txi create mode 100644 queue.txi create mode 100644 ratize.txi delete mode 100644 report.scm create mode 100644 resenecolours.txt create mode 100644 saturate.txt create mode 100755 slib.sh create mode 100644 solid.scm create mode 100644 solid.txi create mode 100644 srfi-1.txi create mode 100644 srfi-2.scm create mode 100644 srfi-2.txi create mode 100644 srfi-8.scm create mode 100644 srfi-8.txi create mode 100644 srfi-9.scm create mode 100644 srfi.txi create mode 100644 subarray.scm create mode 100644 subarray.txi delete mode 100644 tek40.scm delete mode 100644 tek41.scm create mode 100644 top-refs.scm create mode 100644 top-refs.txi create mode 100644 transact.scm create mode 100644 transact.txi create mode 100644 tree.txi create mode 100644 tsort.txi create mode 100644 vet.scm create mode 100644 vet.txi diff --git a/ANNOUNCE b/ANNOUNCE index 6070290..a4201ba 100644 --- a/ANNOUNCE +++ b/ANNOUNCE @@ -1,72 +1,56 @@ -This message announces the availability of Scheme Library release slib2d2. - -New in slib2d2: - - * s48-0_57.init: Added. - * array.scm (make-shared-array): Fixed offset. - * record.scm: Changed identifiers containing VECTOR to VECT or VCT - (but no help for scheme48-0.57). - * 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. - * array.scm: Rewritten to sidestep license issues. - (array=?): Added. - * slib.texi (Arrays): Documentation integrated with array.scm. - * tree.scm (tree:subst): Rewritten; takes optional equality - predicate argument. - * Makefile (docfiles): Added "COPYING". - * mitcomp.pat: Unmaintained; removed. - * RScheme.init: Put in the public domain. - * 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. - * scmactst.scm: Removed for lack of license. - * struct.scm, structst.scm: Removed. struct.scm lacks license. - * scheme48.init (atan): Added workaround. - * Makefile (slib48-0.55): Makes slib48, but fluid-let broken. - * 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". - * slib.texi (Installation): Added specific instructions for - DrScheme, MIT-Scheme, and Guile. - * guile.init: Added. - * require.scm (program-vicinity): Improved error message. - * slib.texi (Installation): Explicit instructions for MzScheme. - * Makefile (pdf): Added target for creating $(htmldir)slib.pdf. - * slib.texi (Installation): Expanded instructions. - * 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. - * srfi-1.scm: Added. - * comlist.scm (comlist:remove): Returns don't disturb order. - * array.scm: Generalized so strings and vectors are arrays. - * slib.texi (Standard Formatted Output): %b was missing. - * 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. - * differ.scm: An O(NP) Sequence Comparison Algorithm. - * srfi.scm (cond-expand): Added. - * wttree.scm (error:error): Replaces error. - * dbutil.scm (make-defaulter): number defaults to 0. - * Makefile (rpm): Fixed dependencies. - -From Jacques Mequin - * gambit.init: (set-case-conversion! #t) - * scheme48.init (defmacro): Defmacro in terms of define-syntax - using defmacro:expand*. - -From Wade Humeniuk - * yasyn.scm, object.scm, recobj.scm: Placed in public domain. +This message announces the availability of Scheme Library release slib3a1. + +New in slib3a1: + + SLIB 3 has undergone major development from SLIB2d6. + + Most noticeable is that SLIB now has a module system with documented + semantics and a suite of reflexive tools for deriving reference and + module dependencies from library code. The reflexive tools are + designed to support compiler-writer's needs as expressed in + discussions arising from comp.lang.scheme in July 2003. + + The module semantics are intended to be compatible both with + implementations having module systems and those lacking. Ivan + Shmakov has been striving to integrate SLIB's and Scheme48's module + systems. His efforts and SLIB's reflexive tools have found a great + many bugs, some of them present since SLIB's beginnings. + + "make install" now creates a "slib" shell script for running various + Schemes with SLIB initialization. Currently supported + implementations are gsi (Gambit), Guile, MzScheme, Scheme48, and + SCM. + + The byte-number module converts between byte-vectors, + twos-complement integers, and IEEE floating-point formats -- all in + R4RS-compliant Scheme code. It also converts byte-vectors to a form + whose lexicographic ordering matches the encoded number's ordering. + + The correctly ordered byte representations of numbers tie in with + SLIB's relational database being extended to include indexed + sequential access methods (ISAM). The Database-interpolation module + uses sequential methods to synthesize continuous functions from + discrete data tables. + + These "continuous databases" are vital to my soon-to-be-released + optics program which calculates spectral responses of layered thin + films. + + The character plotting utility has been improved, and is now + complemented by eps-graph, a very flexible graphing library for + producing encapsulated-PostScript files. + + SRFI-2, SRFI-8, and SRFI-9 are added. + + Although I have endeavored to support legacy usage, some programs + will need modification to work with SLIB 3. Some issues that I know + of are: + + * REQUIRE no longer accepts a string as its argument. + * The RANDOM module is split into RANDOM and RANDOM-INEXACT. + * Some refactoring among TRANSACT, GLOB, and LINE-I/O. + + -=-=- SLIB is a portable Scheme library providing compatibiliy and utility functions for all standard Scheme implementations. @@ -79,17 +63,17 @@ Documentation includes a manifest, installation instructions, and coding guidelines for the library. Documentation of each library package is supplied. SLIB Documentation is online at: - http://swissnet.ai.mit.edu/~jaffer/SLIB.html + http://swissnet.ai.mit.edu/~jaffer/SLIB.html SLIB is available from: - http://swissnet.ai.mit.edu/ftpdir/scm/slib2d2.zip - http://swissnet.ai.mit.edu/ftpdir/scm/slib-2d2-1.noarch.rpm - swissnet.ai.mit.edu:/pub/scm/slib2d2.zip - swissnet.ai.mit.edu:/pub/scm/slib-2d2-1.noarch.rpm + http://swissnet.ai.mit.edu/ftpdir/scm/slib3a1.zip + http://swissnet.ai.mit.edu/ftpdir/scm/slib-3a1-1.noarch.rpm + swissnet.ai.mit.edu:/pub/scm/slib3a1.zip + swissnet.ai.mit.edu:/pub/scm/slib-3a1-1.noarch.rpm SLIB-PSD is a portable debugger for Scheme (requires emacs editor): - http://swissnet.ai.mit.edu/ftpdir/scm/slib-psd1-3.zip - swissnet.ai.mit.edu:/pub/scm/slib-psd1-3.zip + http://swissnet.ai.mit.edu/ftpdir/scm/slib-psd1-3.tar.gz + swissnet.ai.mit.edu:/pub/scm/slib-psd1-3.tar.gz SCHELOG is an embedding of Prolog in Scheme+SLIB: http://www.cs.rice.edu/CS/PLT/packages/schelog/ diff --git a/Bev2slib.scm b/Bev2slib.scm index 8461c5c..30562f5 100644 --- a/Bev2slib.scm +++ b/Bev2slib.scm @@ -8,7 +8,7 @@ ;1. Any copy made of this software must include this copyright notice ;in full. ; -;2. I have made no warrantee or representation that the operation of +;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. ; diff --git a/COPYING b/COPYING index c16d8bd..a2eb7dd 100644 --- a/COPYING +++ b/COPYING @@ -27,7 +27,7 @@ the beginning of "require.scm" states: ;1. Any copy made of this software must include this copyright notice ;in full. ; - ;2. I have made no warrantee or representation that the operation of + ;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. ; diff --git a/ChangeLog b/ChangeLog index e5f19fa..857cc78 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,2066 @@ +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. @@ -692,7 +2755,7 @@ Sun Sep 12 22:45:01 EDT 1999 Aubrey Jaffer 1999-06-05 Radey Shouman - * glob.scm (glob:substitute??): (glob:substitute-ci??): Now accept + * glob.scm (glob:substitute??, glob:substitute-ci??): Now accept a procedure or string as template argument, for more general transformations. @@ -793,7 +2856,7 @@ Sun Sep 12 22:45:01 EDT 1999 Aubrey Jaffer 1999-02-25 Radey Shouman * printf.scm (stdio:iprintf): Fixed bug in %f format, - (printf "%.1f" 0.001) printed "0", now prints "0.0" + (printf "%.1f" 0.001) printed "0", now prints "0.0" 1999-02-12 Hakan L. Younes @@ -913,7 +2976,7 @@ Sun Jan 17 12:33:31 EST 1999 Aubrey Jaffer * 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.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? @@ -1672,7 +3735,7 @@ Wed Aug 21 20:38:26 1996 Aubrey Jaffer 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. + scaexpp.scm: Added missing copyright notice and terms. Thu Jul 18 17:37:14 1996 Aubrey Jaffer @@ -1929,7 +3992,7 @@ 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 + * 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. @@ -1949,8 +4012,8 @@ Mon Jan 2 10:26:45 1995 Aubrey Jaffer (jaffer@jacal) 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: + 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 @@ -2245,7 +4308,7 @@ Thu Feb 17 01:19:47 1994 Aubrey Jaffer (jaffer@jacal) 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. + * mbe.scm: Macro by Example define-syntax using defmacro. Tue Feb 15 17:18:56 1994 Aubrey Jaffer (jaffer@jacal) diff --git a/DrScheme.init b/DrScheme.init index 0676250..9942897 100644 --- a/DrScheme.init +++ b/DrScheme.init @@ -1,6 +1,59 @@ ;;;"DrScheme.init" Initialization for SLIB for DrScheme -*-scheme-*- -;; Friedrich Dominicus -;; Newsgroups: comp.lang.scheme -;; Date: 02 Oct 2000 09:24:57 +0200 +;;; Author: Aubrey Jaffer +;;; +;;; This code is in the public domain. -(require-library "init.ss" "slibinit") +(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 '" "'"))) + +(cond ((stringC, Scheme48, SCM, SCSH, T3.1, -UMB-Scheme, and VSCM. +SLIB supports Bigloo, Chez, ELK, GAMBIT, Guile, 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? @@ -25,8 +25,6 @@ SLIB is available via http from: SLIB is available via ftp from: swissnet.ai.mit.edu:/pub/scm/ -SLIB is also included with SCM floppy disks. - [] How do I install SLIB? Read the INSTALLATION INSTRUCTIONS in "slib/README". @@ -48,7 +46,7 @@ Several times a year. [] What is the latest version? -The version as of this writing is slib2d2. The latest documentation +The version as of this writing is slib3a1. The latest documentation is available online at: http://swissnet.ai.mit.edu/~jaffer/SLIB.html @@ -132,6 +130,17 @@ 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. +[] What happened to FORMAT? + +In order for FORMAT to call itself for FORMAT error messages, the +original author made its code non-reentrant. For that reason and the +reasons below, FORMAT was removed; I saw little evidence of anyone +using it. + +If someone fixes FORMAT, I will put it back into SLIB. The last +versions of FORMAT are in "format.scm", "formatst.scm", and +"fmtdoc.txi" in http://swissnet.ai.mit.edu/ftpdir/scm/OLD/slib2d5.zip + [] Why does SLIB have PRINTF when it already has the more powerful (CommonLisp) FORMAT? diff --git a/Makefile b/Makefile index 30a16b2..6739f4e 100644 --- a/Makefile +++ b/Makefile @@ -9,146 +9,214 @@ intro: @echo "Welcome to SLIB. Read \"README\" and \"slib.info\" (or" @echo "\"slib.texi\") to learn how to install and use SLIB." @echo - @echo -make slib.info include srcdir.mk srcdir.mk: .. Makefile echo -e "srcdir = `pwd`/\n" > srcdir.mk #srcdir=$(HOME)/slib/ -PREVDOCS = prevdocs/ -dvidir=../dvi/ -dvi: $(dvidir)slib.dvi -$(dvidir)slib.dvi: version.txi slib.texi $(dvidir)slib.fn schmooz.texi -# cd $(dvidir);export TEXINPUTS=$(srcdir):;texi2dvi $(srcdir)slib.texi - -(cd $(dvidir);export TEXINPUTS=$(srcdir):;texindex slib.??) - cd $(dvidir);export TEXINPUTS=$(srcdir):;tex $(srcdir)slib.texi -$(dvidir)slib.fn: - cd $(dvidir);export TEXINPUTS=$(srcdir):;tex $(srcdir)slib.texi \ - $(srcdir)schmooz.texi -xdvi: $(dvidir)slib.dvi - xdvi -s 6 $(dvidir)slib.dvi -htmldir=../public_html/ -slib_toc.html: version.txi slib.texi htmlform.txi schmooz.texi - texi2html -split -verbose slib.texi -pdf: $(htmldir)slib.pdf -$(htmldir)slib.pdf: version.txi slib.texi $(dvidir)slib.fn schmooz.texi -# cd $(dvidir);dvipdf slib.dvi # doesn't have links! - cd $(dvidir);export TEXINPUTS=$(srcdir):;pdftex $(srcdir)slib.texi - mv $(dvidir)slib.pdf $(htmldir) -xpdf: $(htmldir)slib.pdf - xpdf -z 3 $(htmldir)slib.pdf - -html: $(htmldir)slib_toc.html -$(htmldir)slib_toc.html: slib_toc.html Makefile - hitch $(PREVDOCS)slib_\*.html slib_\*.html $(htmldir) +VERSION = 3a1 +RELEASE = 1 rpm_prefix=/usr/src/redhat/ - -prefix = /usr/local +prefix = /usr/local/ exec_prefix = $(prefix) -bindir = $(exec_prefix)/bin -libdir = $(exec_prefix)/lib -infodir = $(exec_prefix)/info +# directory where `make install' will put executable. +bindir = $(exec_prefix)bin/ +libdir = $(exec_prefix)lib/ +infodir = $(prefix)info/ + +PREVDOCS = prevdocs/ + +htmldir=../public_html/ +dvidir=../dvi/ + RUNNABLE = scheme48 -LIB = $(libdir)/$(RUNNABLE) +LIB = $(libdir)$(RUNNABLE)/ VM = scheme48vm IMAGE = slib.image INSTALL_DATA = install -c -$(LIB)/slibcat: - touch $(LIB)/slibcat +$(LIB)slibcat: + touch $(LIB)slibcat + +catalogs: + -if type scm; then scm -c "(require 'new-catalog)"; fi + -if type guile; then guile -l guile.init -c\ + "(use-modules (ice-9 slib)) (require 'new-catalog)"; fi + -if type umb-scheme; then export SCHEME_INIT=umbscheme.init;\ + echo "(require 'new-catalog)" | umb-scheme; fi + -if type mzscheme; then export SCHEME_LIBRARY_PATH=`pwd`/;\ + mzscheme -g -f DrScheme.init -e "(require 'new-catalog)" $(bindir)/slib48 - chmod +x $(bindir)/slib48 + (echo '#! /bin/sh';\ + echo exec $(RUNNABLE) -i '$(LIB)$(IMAGE)' \"\$$\@\") \ + > $(bindir)slib48 + chmod +x $(bindir)slib48 + +install: + test -d $(bindir) || mkdir $(bindir) + echo '#! /bin/sh' > $(bindir)slib + echo export SCHEME_LIBRARY_PATH=$(libdir)slib/ >> $(bindir)slib + echo VERSION=$(VERSION) >> $(bindir)slib + cat slib.sh >> $(bindir)slib + chmod +x $(bindir)slib #### Stuff for maintaining SLIB below #### -VERSION = 2d2 ver = $(VERSION) version.txi: Makefile - echo @set SLIBVERSION $(VERSION) > version.txi + echo @set SLIBVERSION $(ver) > version.txi echo @set SLIBDATE `date +"%B %Y"` >> version.txi scheme = scm -htmlform.txi: *.scm - $(scheme) -rschmooz -e'(schmooz "slib.texi")' -slib.info: version.txi slib.texi htmlform.txi objdoc.txi schmooz.texi - makeinfo slib.texi --no-split -o slib.info - mv slib.info slib$(VERSION).info - if [ -f $(PREVDOCS)slib.info ];\ - then infobar $(PREVDOCS)slib.info slib$(VERSION).info slib.info;\ - else cp slib$(VERSION).info slib.info;fi -info: installinfo -installinfo: $(infodir)/slib.info -$(infodir)/slib.info: slib.info - cp -a slib.info $(infodir)/slib.info - -install-info $(infodir)/slib.info $(infodir)/dir - -rm $(infodir)/slib.info.gz -infoz: installinfoz -installinfoz: $(infodir)/slib.info.gz -$(infodir)/slib.info.gz: $(infodir)/slib.info - gzip -f $(infodir)/slib.info - -ffiles = printf.scm format.scm genwrite.scm obj2str.scm pp.scm \ - ppfile.scm strcase.scm debug.scm trace.scm lineio.scm \ - strport.scm scanf.scm chap.scm qp.scm break.scm stdio.scm \ - strsrch.scm prec.scm schmooz.scm differ.scm -lfiles = sort.scm comlist.scm tree.scm logical.scm random.scm tsort.scm \ - coerce.scm +collect.sc: + echo "(require 'macros-that-work)" > collect.sc + echo "(require 'pprint-file)" >> collect.sc + echo "(require 'yasos)" >> collect.sc + echo "(pprint-filter-file \"collect.scm\" macwork:expand \"collectx.scm\")" >> collect.sc + echo "(slib:exit #t)" >> collect.sc + +collectx.scm: collect.scm macwork.scm collect.sc + $(scheme) < collect.sc + +ffiles = printf.scm genwrite.scm pp.scm \ + ppfile.scm strcase.scm debug.scm trace.scm \ + strport.scm scanf.scm qp.scm break.scm stdio.scm \ + strsrch.scm prec.scm schmooz.scm defmacex.scm mbe.scm +lfiles = sort.scm comlist.scm logical.scm revfiles = sc4opt.scm sc4sc3.scm sc2.scm mularg.scm mulapply.scm \ - trnscrpt.scm withfile.scm dynwind.scm promise.scm values.scm \ - eval.scm -afiles = ratize.scm randinex.scm modular.scm factor.scm \ - charplot.scm root.scm minimize.scm cring.scm determ.scm \ + trnscrpt.scm withfile.scm dynwind.scm promise.scm \ + values.scm eval.scm null.scm +afiles = charplot.scm root.scm cring.scm \ selfset.scm psxtime.scm cltime.scm timezone.scm tzfile.scm -bfiles = collect.scm fluidlet.scm object.scm recobj.scm yasyn.scm +bfiles = fluidlet.scm object.scm recobj.scm yasyn.scm collect.scm collectx.scm scfiles = r4rsyn.scm scmacro.scm synclo.scm synrul.scm synchk.scm \ repl.scm macwork.scm mwexpand.scm mwdenote.scm mwsynrul.scm scafiles = scainit.scm scaglob.scm scamacr.scm scaoutp.scm scaexpp.scm \ structure.scm -dfiles = defmacex.scm mbe.scm srfi.scm -srfiles = srfi-1.scm -efiles = record.scm dynamic.scm queue.scm process.scm \ - priorque.scm hash.scm hashtab.scm alist.scm \ - wttree.scm wttest.scm array.scm arraymap.scm \ - sierpinski.scm soundex.scm byte.scm nclients.scm pnm.scm \ - simetrix.scm -rfiles = rdms.scm alistab.scm dbutil.scm paramlst.scm report.scm \ - batch.scm makcrc.scm dbrowse.scm comparse.scm getopt.scm \ - htmlform.scm db2html.scm http-cgi.scm getparam.scm glob.scm \ - fft.scm uri.scm -gfiles = tek40.scm tek41.scm -docfiles = ANNOUNCE README COPYING FAQ slib.info slib.texi schmooz.texi \ - ChangeLog coerce.txi lineio.txi nclients.txi factor.txi minimize.txi \ - obj2str.txi randinex.txi random.txi uri.txi db2html.txi \ - htmlform.txi http-cgi.txi version.txi fmtdoc.txi objdoc.txi -mfiles = Makefile require.scm Template.scm syncase.sh mklibcat.scm \ - Bev2slib.scm slib.spec +srfiles = srfi-9.scm +efiles = record.scm dynamic.scm process.scm hash.scm \ + wttree.scm wttest.scm sierpinski.scm soundex.scm simetrix.scm +rfiles = rdms.scm alistab.scm paramlst.scm \ + batch.scm crc.scm dbrowse.scm getopt.scm dbinterp.scm \ + dbcom.scm dbsyn.scm +gfiles = colorspc.scm cie1931.xyz cie1964.xyz resenecolours.txt saturate.txt + +txiscms =grapheps.scm glob.scm getparam.scm \ + vet.scm top-refs.scm hashtab.scm chap.scm comparse.scm\ + alist.scm ratize.scm modular.scm dirs.scm priorque.scm queue.scm\ + srfi.scm srfi-1.scm srfi-2.scm srfi-8.scm\ + pnm.scm http-cgi.scm htmlform.scm html4each.scm db2html.scm uri.scm\ + fft.scm solid.scm random.scm randinex.scm obj2str.scm ncbi-dna.scm\ + minimize.scm factor.scm determ.scm daylight.scm colornam.scm\ + mkclrnam.scm color.scm subarray.scm dbutil.scm array.scm transact.scm\ + arraymap.scm phil-spc.scm lineio.scm differ.scm cvs.scm tree.scm\ + coerce.scm byte.scm bytenumb.scm matfile.scm tsort.scm manifest.scm +txifiles =grapheps.txi glob.txi getparam.txi\ + vet.txi top-refs.txi hashtab.txi chap.txi comparse.txi\ + alist.txi ratize.txi modular.txi dirs.txi priorque.txi queue.txi\ + srfi.txi srfi-1.txi srfi-2.txi srfi-8.txi\ + pnm.txi http-cgi.txi htmlform.txi html4each.txi db2html.txi uri.txi\ + fft.txi solid.txi random.txi randinex.txi obj2str.txi ncbi-dna.txi\ + minimize.txi factor.txi determ.txi daylight.txi colornam.txi\ + mkclrnam.txi color.txi subarray.txi dbutil.txi array.txi transact.txi\ + arraymap.txi phil-spc.txi lineio.txi differ.txi cvs.txi tree.txi\ + coerce.txi byte.txi bytenumb.txi matfile.txi tsort.txi manifest.txi +% = `echo $(txiscms) | sed 's%.scm%.txi%g'` + +docfiles = ANNOUNCE README COPYING FAQ slib.info slib.texi schmooz.texi\ + ChangeLog version.txi object.texi $(txifiles) +mkfiles = Makefile require.scm Template.scm syncase.sh mklibcat.scm \ + Bev2slib.scm slib.spec slib.sh grapheps.ps ifiles = bigloo.init chez.init elk.init macscheme.init mitscheme.init \ scheme2c.init scheme48.init s48-0_57.init gambit.init t3.init \ vscm.init scm.init scsh.init pscheme.init STk.init \ RScheme.init DrScheme.init umbscheme.init guile.init -tfiles = plottest.scm formatst.scm macrotst.scm dwindtst.scm +tfiles = plottest.scm macrotst.scm dwindtst.scm sfiles = $(ffiles) $(lfiles) $(revfiles) $(afiles) $(scfiles) $(efiles) \ - $(rfiles) $(gfiles) $(scafiles) $(dfiles) $(srfiles) -allfiles = $(docfiles) $(mfiles) $(ifiles) $(sfiles) $(tfiles) $(bfiles) + $(rfiles) $(gfiles) $(scafiles) $(txiscms) $(srfiles) +allfiles = $(docfiles) $(mkfiles) $(ifiles) $(sfiles) $(tfiles) $(bfiles) + +$(txifiles): $(txiscms) schmooz.scm + $(scheme) -rschmooz -e'(schmooz "slib.texi")' + +dvi: $(dvidir)slib.dvi +$(dvidir)slib.dvi: version.txi slib.texi $(dvidir)slib.fn \ + $(txifiles) object.texi schmooz.texi +# cd $(dvidir);export TEXINPUTS=$(srcdir):;texi2dvi $(srcdir)slib.texi + -(cd $(dvidir);export TEXINPUTS=$(srcdir):;texindex slib.??) + cd $(dvidir);export TEXINPUTS=$(srcdir):;tex $(srcdir)slib.texi +$(dvidir)slib.fn: + cd $(dvidir);export TEXINPUTS=$(srcdir):;tex $(srcdir)slib.texi \ + $(srcdir)schmooz.texi +xdvi: $(dvidir)slib.dvi + xdvi -s 3 $(dvidir)slib.dvi + +pdf: $(htmldir)slib.pdf +$(htmldir)slib.pdf: version.txi slib.texi $(dvidir)slib.fn schmooz.texi +# cd $(dvidir);dvipdf slib.dvi # doesn't have links! + cd $(dvidir);export TEXINPUTS=$(srcdir):;pdftex $(srcdir)slib.texi + mv $(dvidir)slib.pdf $(htmldir) +xpdf: $(htmldir)slib.pdf + xpdf -z 3 $(htmldir)slib.pdf + +TEXI2HTML = /usr/local/bin/texi2html -split -verbose +slib_toc.html: $(txifiles) version.txi slib.texi schmooz.texi + ${TEXI2HTML} slib.texi +html: $(htmldir)slib_toc.html +$(htmldir)slib_toc.html: slib_toc.html Makefile + -rm -f slib_stoc.html + if [ -f $(PREVDOCS)slib_toc.html ]; \ + then hitch $(PREVDOCS)slib_\*.html slib_\*.html $(htmldir); \ + else cp slib_*.html $(htmldir);fi + +slib$(VERSION).info: $(txifiles) version.txi slib.texi schmooz.texi + makeinfo slib.texi --no-warn --no-split -o slib.info + mv slib.info slib$(VERSION).info +slib.info: slib$(VERSION).info + if [ -f $(PREVDOCS)slib.info ];\ + then infobar $(PREVDOCS)slib.info slib$(VERSION).info slib.info;\ + else cp slib$(VERSION).info slib.info;fi +info: installinfo +installinfo: $(infodir)slib.info +$(infodir)slib.info: slib.info + cp -a slib.info $(infodir)slib.info + -install-info $(infodir)slib.info $(infodir)dir + -rm $(infodir)slib.info.gz +infoz: installinfoz +installinfoz: $(infodir)slib.info.gz +$(infodir)slib.info.gz: $(infodir)slib.info + gzip -f $(infodir)slib.info makedev = make -f $(HOME)/makefile.dev CHPAT=$(HOME)/bin/chpat RSYNC=rsync -avessh +UPLOADEE=swissnet_upload dest = $(HOME)/dist/ temp/slib: $(allfiles) -rm -rf temp @@ -162,27 +230,29 @@ infotemp/slib: slib.info mkdir infotemp/slib ln slib.info slib.info-* infotemp/slib #For change-barred HTML. -prevdocs: srcdir.mk Makefile - cd prevdocs; unzip -a $(dest)slib*.zip - rm prevdocs/slib/slib.info - cd prevdocs/slib; make slib.info; make slib_toc.html - cd prevdocs; mv -f slib/slib.info slib/*.html ./ - rm -rf prevdocs/slib +$(PREVDOCS)slib_toc.html: +$(PREVDOCS)slib.info: srcdir.mk Makefile + cd $(PREVDOCS); unzip -ao $(dest)slib*.zip + rm $(PREVDOCS)slib/slib.info + cd $(PREVDOCS)slib; make slib.info; make slib_toc.html + cd $(PREVDOCS); mv -f slib/slib.info slib/*.html ./ + rm -rf $(PREVDOCS)slib distinfo: $(dest)slib.info.zip $(dest)slib.info.zip: infotemp/slib $(makedev) TEMP=infotemp/ DEST=$(dest) PROD=slib ver=.info zip rm -rf infotemp -release: dist rpm +release: dist pdf tar.gz # rpm cvs tag -F slib$(VERSION) cp ANNOUNCE $(htmldir)SLIB_ANNOUNCE.txt cp COPYING $(htmldir)SLIB_COPYING.txt $(RSYNC) $(htmldir)SLIB.html $(htmldir)SLIB_ANNOUNCE.txt \ - $(htmldir)SLIB_COPYING.txt nestle.ai.mit.edu:public_html/ + $(htmldir)SLIB_COPYING.txt $(UPLOADEE):public_html/ $(RSYNC) $(dest)README $(dest)slib$(VERSION).zip \ - $(dest)slib-$(VERSION)-1.noarch.rpm\ - $(dest)slib-$(VERSION)-1.src.rpm nestle.ai.mit.edu:dist/ + $(dest)slib$(VERSION).tar.gz $(htmldir)slib.pdf \ + $(dest)slib-$(VERSION)-$(RELEASE).noarch.rpm \ + $(dest)slib-$(VERSION)-$(RELEASE).src.rpm $(UPLOADEE):dist/ # upload $(dest)README $(dest)slib$(VERSION).zip ftp.gnu.org:gnu/jacal/ # $(MAKE) indiana indiana: @@ -195,23 +265,27 @@ indiana: postnews: echo -e "Newsgroups: comp.lang.scheme\n" | cat - ANNOUNCE | \ inews -h -O -S \ - -f "announce@docupress.com (Aubrey Jaffer & Radey Shouman)" \ + -f "announce@voluntocracy.org (Aubrey Jaffer & Radey Shouman)" \ -t "SLIB$(VERSION) Released" -d world upzip: $(HOME)/pub/slib.zip - $(RSYNC) $(HOME)/pub/slib.zip nestle.ai.mit.edu:pub/ + $(RSYNC) $(HOME)/pub/slib.zip $(UPLOADEE):pub/ dist: $(dest)slib$(VERSION).zip $(dest)slib$(VERSION).zip: temp/slib $(makedev) DEST=$(dest) PROD=slib ver=$(VERSION) zip +tar.gz: $(dest)slib$(VERSION).tar.gz +$(dest)slib$(VERSION).tar.gz: temp/slib + $(makedev) DEST=$(dest) PROD=slib ver=$(VERSION) tar.gz + rpm: pubzip -#$(dest)slib-$(VERSION)-1.noarch.rpm: $(dest)slib$(VERSION).zip +#$(dest)slib-$(VERSION)-$(RELEASE).noarch.rpm: $(dest)slib$(VERSION).zip cp $(HOME)/pub/slib.zip $(rpm_prefix)SOURCES/slib$(VERSION).zip rpm -ba slib.spec # --clean rm $(rpm_prefix)SOURCES/slib$(VERSION).zip - mv $(rpm_prefix)RPMS/noarch/slib-$(VERSION)-1.noarch.rpm \ - $(rpm_prefix)SRPMS/slib-$(VERSION)-1.src.rpm $(dest) + mv $(rpm_prefix)RPMS/noarch/slib-$(VERSION)-$(RELEASE).noarch.rpm \ + $(rpm_prefix)SRPMS/slib-$(VERSION)-$(RELEASE).src.rpm $(dest) shar: slib.shar slib.shar: temp/slib @@ -222,7 +296,7 @@ slib.com: temp/slib $(makedev) PROD=slib com zip: slib.zip slib.zip: temp/slib - $(makedev) PROD=slib zip + $(makedev) DEST=../ PROD=slib zip doszip: /c/scm/dist/slib$(VERSION).zip /c/scm/dist/slib$(VERSION).zip: temp/slib $(makedev) DEST=/c/scm/dist/ PROD=slib ver=$(VERSION) zip @@ -256,7 +330,7 @@ $(dest)slib-psd.tar.gz: psdtemp/slib $(makedev) DEST=$(dest) PROD=slib ver=-psd tar.gz TEMP=psdtemp/ new: - echo `date` \ Aubrey Jaffer \ \<`whoami`@`hostname`\>> change + echo `date -I` \ Aubrey Jaffer \ \<`whoami`@`hostname`\>> change echo>> change echo \ \* require.scm \(*SLIB-VERSION*\): Bumped from $(VERSION) to $(ver).>>change echo>> change @@ -267,7 +341,7 @@ new: ../synch/ANNOUNCE \ $(htmldir)README.html ../dist/README \ $(htmldir)JACAL.html \ - $(htmldir)SCM.html $(htmldir)Hobbit.html \ + $(htmldir)SCM.html \ $(htmldir)SIMSYNCH.html ../scm/scm.texi \ /c/scm/dist/install.bat /c/scm/dist/makefile \ /c/scm/dist/mkdisk.bat @@ -276,7 +350,7 @@ new: ../synch/ANNOUNCE \ $(htmldir)README.html ../dist/README \ $(htmldir)JACAL.html \ - $(htmldir)SCM.html $(htmldir)Hobbit.html \ + $(htmldir)SCM.html \ $(htmldir)SIMSYNCH.html ../scm/scm.texi \ /c/scm/dist/install.bat /c/scm/dist/makefile \ /c/scm/dist/mkdisk.bat @@ -285,19 +359,18 @@ new: cvs commit -lm '(*SLIB-VERSION*): Bumped from $(VERSION) to $(ver).' cvs tag -lF slib$(ver) -tagfiles = version.txi slib.texi $(mfiles) $(sfiles) $(bfiles) $(tfiles) \ - $(ifiles) +tagfiles = README version.txi slib.texi \ + $(mkfiles) $(sfiles) $(bfiles) $(tfiles) $(ifiles) # README and $(ifiles) cause semgentation faults in ETAGS for Emacs version 19. tags: $(tagfiles) etags $(tagfiles) test: $(sfiles) - scheme Template.scm $(sfiles) + $(scheme) Template.scm $(sfiles) rights: - scm -ladmin -e"(admin:check-all)" $(sfiles) $(tfiles) \ + $(scheme) -ladmin -e"(admin:check-all)" $(sfiles) $(tfiles) \ $(bfiles) $(ifiles) report: - scmlit -e"(slib:report #t)" - scm -e"(slib:report #t)" + $(scheme) -e"(slib:report #t)" clean: -rm -f *~ *.bak *.orig *.rej core a.out *.o \#* -rm -rf *temp diff --git a/README b/README index 8d4d31d..1443e0e 100644 --- a/README +++ b/README @@ -1,4 +1,4 @@ -This directory contains the distribution of Scheme Library slib2d2. +This directory contains the distribution of Scheme Library slib3a1. Slib conforms to Revised^5 Report on the Algorithmic Language Scheme and the IEEE P1178 specification. Slib supports Unix and similar systems, VMS, and MS-DOS. @@ -8,8 +8,8 @@ The maintainer can be reached at agj @ alum.mit.edu. MANIFEST - `README' is this file. It contains a MANIFEST, INSTALLATION - INSTRUCTIONS, and coding guidelines. + `README' is this file. It contains a MANIFEST and INSTALLATION + INSTRUCTIONS. `FAQ' Frequently Asked Questions and answers. `ChangeLog' documents changes to slib. `slib.texi' has documentation on library packages in TexInfo format. @@ -19,7 +19,7 @@ The maintainer can be reached at agj @ alum.mit.edu. `bigloo.init' is a configuration file for Bigloo. `chez.init' is a configuration file for Chez Scheme. `DrScheme.init' is a configuration file for DrScheme. - `elk.init' is a configuration file for ELK 2.1 + `elk.init' is a configuration file for ELK 3.0. `gambit.init' is a configuration file for Gambit Scheme. `macscheme.init' is a configuration file for MacScheme. `mitscheme.init' is a configuration file for MIT Scheme. @@ -32,16 +32,15 @@ The maintainer can be reached at agj @ alum.mit.edu. `scm.init' is a configuration file for SCM. `t3.init' is a configuration file for T3.1 in Scheme mode. `STk.init' is a configuration file for STk. - `umbscheme.init' is a configuration file for umb-scheme. + `umbscheme.init' is a configuration file for umb-scheme. `vscm.init' is a configuration file for VSCM. `guile.init' is a configuration file for guile. `mklibcat.scm' builds the *catalog* cache. `require.scm' has code which allows system independent access to the library files. + `slib.sh' is a shell script for running various Schemes with SLIB. `Bev2slib.scm' Converts Stephen Bevan's "*.map" files to SLIB catalog entries. - `format.scm' has Common-Lisp style format. - `formatst.scm' has code to test format.scm `pp.scm' has pretty-print. `ppfile.scm' has pprint-file and pprint-filter-file. `obj2str.scm' has object->string. @@ -63,6 +62,7 @@ The maintainer can be reached at agj @ alum.mit.edu. `hash.scm' defines hash, hashq, and hashv. `hashtab.scm' has hash tables. `sierpinski.scm' 2-dimensional coordinate hash. + `phil-spc.scm' Peano-Hilbert Space-Filling Curve. `soundex.scm' English name hash. `logical.scm' emulates 2's complement logical operations. `random.scm' has random number generator compatible with Common Lisp. @@ -75,10 +75,19 @@ The maintainer can be reached at agj @ alum.mit.edu. `selfset.scm' sets single letter identifiers to their symbols. `determ.scm' compute determinant of list of lists. `charplot.scm' has procedure for plotting on character screens. + `grapheps.scm' has procedures for creating PostScript graphs. + `grapheps.ps' is PostScript runtime support for creating graphs. + `matfile.scm' reads MAT-File Format version 4 (MATLAB). `plottest.scm' has code to test charplot.scm. - `tek40.scm' has routines for Tektronix 4000 series graphics. - `tek41.scm' has routines for Tektronix 4100 series graphics. - `getopt.scm' has posix-like getopt for parsing command line arguments. + `solid.scm' has VRML97 solid-modeling. + `colorspc.scm' has CIE and sRGB color transforms. + `colornam.scm' has color-name database functions. + `mkclrnam.scm' creates color-name databases. + `color.scm' has color data-type. + `cie1931.xyz' CIE XYZ(1931) Spectra from 380.nm to 780.nm. + `cie1964.xyz' CIE XYZ(1964) Spectra from 380.nm to 780.nm. + `daylight.scm' Model of sky colors. + `getopt.scm' has posix-like getopt for parsing command line arguments. `psxtime.scm' has Posix time conversion routines. `cltime.scm' has Common-Lisp time conversion routines. `timezone.scm' has the default time-zone, UTC. @@ -88,23 +97,29 @@ The maintainer can be reached at agj @ alum.mit.edu. `rdms.scm' has code to construct a relational database from a base table implementation. `alistab.scm' has association list base tables. - `dbutil.scm' has utilities for creating and manipulating relational + `dbutil.scm' has procedures for creating and opening relational databases. + `dbsyn.scm' has Syntactic extensions for RDMS (within-database). + `dbcom.scm' embeds *commands* in relational databases. + `dbinterp.scm' Interpolate function from database table. `htmlform.scm' generates HTML-3.2 with forms. `db2html.scm' convert relational database to hyperlinked tables and pages. `http-cgi.scm' serves WWW pages with HTTP or CGI. + `html4each.scm' parses HTML files. + `dirs.scm' maps over directory filenames. `uri.scm' encodes and decodes Uniform Resource Identifiers. `dbrowse.scm' browses relational databases. `paramlst.scm' has procedures for passing parameters by name. `getparam.scm' has procedures for converting getopt to parameters. - `report.scm' prints database reports. + `manifest.scm' List SLIB module requires and exports; useful for compiling. + `top-defs.scm' Finds external references. + `vet.scm' Checks each module imports, exports, and documentation. `schmooz.scm' is a simple, lightweight markup language for interspersing Texinfo documentation with Scheme source code. `glob.scm' has filename matching and manipulation. `batch.scm' Group and execute commands on various operating systems. - `makcrc.scm' Create Scheme procedure to calculate POSIX.2 checksums - or other CRCs. + `crc.scm' Calculate POSIX.2 checksums and other CRCs. `record.scm' a MITScheme user-definable datatypes package `promise.scm' has code from R4RS for supporting DELAY and FORCE. @@ -134,7 +149,8 @@ The maintainer can be reached at agj @ alum.mit.edu. `wttree.scm' has weight-balanced trees. `wttest.scm' tests weight-balanced trees. `process.scm' has multi-processing primitives. - `array.scm' has multi-dimensional arrays and sub-arrays. + `array.scm' has multi-dimensional arrays. + `subarray.scm' has subarray and accessory procedures. `arraymap.scm' has array-map!, array-for-each, and array-indexes. `sort.scm' has sorted?, sort, sort!, merge, and merge!. @@ -147,7 +163,7 @@ The maintainer can be reached at agj @ alum.mit.edu. `sc4opt.scm' has optional rev4 procedures. `sc4sc3.scm' has procedures to make a rev3 implementation run rev4 - code. + code. `sc2.scm' has rev2 procedures eliminated in subsequent versions. `mularg.scm' redefines - and / to take more than 2 arguments. `mulapply.scm' redefines apply to take more than 2 arguments. @@ -161,9 +177,11 @@ The maintainer can be reached at agj @ alum.mit.edu. `fluidlet.scm' has fluid-let syntax. `structure.scm' has undocumented syntax-case macros. `byte.scm' has arrays of small integers. - `nclients.scm' provides a Scheme interface to FTP and WWW Browsers. + `bytenumb.scm' convert byte-arrays to integers; IEEE floating-point numbers. + `transact.scm' File locking and backup. `pnm.scm' provides a Scheme interface to "portable bitmap" files. `simetrix.scm' provides SI Metric Interchange Format. + `ncbi-dna.scm' reads and manipulates DNA and protein sequences. `srfi.scm' implements Scheme Request for Implementation. `srfi-N.scm' implements srfi-N. @@ -237,6 +255,13 @@ when installing SLIB. (require 'new-catalog) + The catalog also supports color-name dictionaries. With an +SLIB-installed scheme implementation, type: + (require 'color-names) + (make-slib-color-name-db) + (require 'new-catalog) + (slib:exit) + Implementation-specific Instructions ------------------------------------ @@ -293,7 +318,7 @@ as outlined above. To use SLIB in MzScheme, set the SCHEME_LIBRARY_PATH environment variable to the installed SLIB location; then invoke MzScheme thus: - `mzscheme -L init.ss slibinit' + `mzscheme -f ${SCHEME_LIBRARY_PATH}DrScheme.init' - Implementation: MIT Scheme `scheme -load ${SCHEME_LIBRARY_PATH}mitscheme.init' @@ -326,27 +351,14 @@ library will then be accessible in a system independent fashion. Please mail new working configuration files to `agj @ alum.mit.edu' so that they can be included in the SLIB distribution. - CODING GUIDELINES + USING SLIB - All library packages are written in IEEE P1178 Scheme and assume that -a configuration file and `require.scm' package have already been + All library packages are written in IEEE P1178 Scheme and assume +that a configuration file and `require.scm' package have already been loaded. Other versions of Scheme can be supported in library packages -as well by using, for example, `(provided? 'rev3-report)' or `(require -'rev3-report)'. - - `require.scm' defines `*catalog*', an association list of module -names and filenames. When a new package is added to the library, an -entry should be added to `require.scm'. Local packages can also be -added to `*catalog*' and even shadow entries already in the table. - - The module name and `:' should prefix each symbol defined in the -package. Definitions for external use should then be exported by having -`(define foo module-name:foo)'. +as well by using, for example, `(provided? 'r3rs)' or `(require 'r3rs)'. - Submitted packages should not duplicate routines which are already in -SLIB files. Use `require' to force those features to be supported in -your package. Care should be taken that there are no circularities in -the `require's and `load's between the library packages. +The first chapter of the SLIB manual "The Library System" explains the +mechanics of using SLIB modules. - Documentation should be provided in Emacs Texinfo format if possible, -But documentation must be provided. + http://swissnet.ai.mit.edu/~jaffer/slib_1 diff --git a/RScheme.init b/RScheme.init index c03119c..b9a7d84 100644 --- a/RScheme.init +++ b/RScheme.init @@ -54,6 +54,19 @@ (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))))) + ;;; *FEATURES* should be set to a list of symbols describing features ;;; of this implementation. Suggestions for features are: @@ -66,7 +79,7 @@ ;; Scheme report features -; rev5-report ;conforms to +; r5rs ;conforms to ; eval ;R5RS two-argument eval ; values ;R5RS multiple values ; dynamic-wind ;R5RS dynamic-wind @@ -80,11 +93,11 @@ ;STRING-FILL!, LIST->VECTOR, ;VECTOR->LIST, and VECTOR-FILL! - rev4-report ;conforms to + r4rs ;conforms to ieee-p1178 ;conforms to -; rev3-report ;conforms to +; r3rs ;conforms to ; rev2-procedures ;SUBSTRING-MOVE-LEFT!, ;SUBSTRING-MOVE-RIGHT!, @@ -95,7 +108,7 @@ multiarg/and- ;/ and - can take more than 2 args. with-file ;has WITH-INPUT-FROM-FILE and - ;WITH-OUTPUT-FROM-FILE + ;WITH-OUTPUT-TO-FILE ; transcript ;TRANSCRIPT-ON and TRANSCRIPT-OFF ; ieee-floating-point ;conforms to IEEE Standard 754-1985 ;IEEE Standard for Binary @@ -160,6 +173,33 @@ ;;; 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 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) + (slib:warn "define BROWSE-URL in macscheme.init")) + ;;; CHAR-CODE-LIMIT is one greater than the largest integer which can ;;; be returned by CHAR->INTEGER. (define char-code-limit 65536) @@ -232,7 +272,7 @@ (let ((cep (current-error-port))) (if (provided? 'trace) (print-call-stack cep)) (display "Warn: " cep) - (for-each (lambda (x) (display x cep)) args)))) + (for-each (lambda (x) (display #\ cep) (write x cep)) args)))) ;;; define an error procedure for the library (define (slib:error msg . args) diff --git a/STk.init b/STk.init index b4f256d..97edf81 100644 --- a/STk.init +++ b/STk.init @@ -7,35 +7,29 @@ ;;; (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) '|STk|) ;;; (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://kaolin.unice.fr/STk/STk.html") ;;; (scheme-implementation-version) should return a string describing ;;; the version the scheme implementation loading this file. - (define (scheme-implementation-version) (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) "/usr/local/lib/stk/3.99.3/") ;;; (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 (getenv "SCHEME_LIBRARY_PATH") "/usr/local/lib/slib/"))) (lambda () library-path))) @@ -44,14 +38,18 @@ ;;; (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-path (or (getenv "HOME") "/"))) - (lambda () home-path))) +(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))))) ;;; *FEATURES* should be set to a list of symbols describing features ;;; of this implementation. Suggestions for features are: - (define *features* '( source ;can load scheme source files @@ -61,7 +59,7 @@ ;; Scheme report features -; rev5-report ;conforms to +; r5rs ;conforms to eval ;R5RS two-argument eval ; values ;R5RS multiple values dynamic-wind ;R5RS dynamic-wind @@ -75,11 +73,11 @@ ;STRING-FILL!, LIST->VECTOR, ;VECTOR->LIST, and VECTOR-FILL! - rev4-report ;conforms to + r4rs ;conforms to ieee-p1178 ;conforms to -; rev3-report ;conforms to +; r3rs ;conforms to ; rev2-procedures ;SUBSTRING-MOVE-LEFT!, ;SUBSTRING-MOVE-RIGHT!, @@ -90,7 +88,7 @@ multiarg/and- ;/ and - can take more than 2 args. with-file ;has WITH-INPUT-FROM-FILE and - ;WITH-OUTPUT-FROM-FILE + ;WITH-OUTPUT-TO-FILE ; transcript ;TRANSCRIPT-ON and TRANSCRIPT-OFF ieee-floating-point ;conforms to IEEE Standard 754-1985 ;IEEE Standard for Binary @@ -141,6 +139,37 @@ ;;; use this definition if your system doesn't have such a procedure. (define (force-output . arg) (apply flush arg)) +(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) (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'"))) + ;;; CHAR-CODE-LIMIT is one greater than the largest integer which can ;;; be returned by CHAR->INTEGER. (define char-code-limit 256) @@ -199,7 +228,7 @@ (let ((cep (current-error-port))) (if (provided? 'trace) (print-call-stack cep)) (display "Warn: " cep) - (for-each (lambda (x) (display x cep)) args)))) + (for-each (lambda (x) (display #\ cep) (write x cep)) args)))) ;;; define an error procedure for the library (define (slib:error . args) @@ -230,13 +259,11 @@ ;;; (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) ;;; diff --git a/Template.scm b/Template.scm index 6421d92..63c10c9 100644 --- a/Template.scm +++ b/Template.scm @@ -3,40 +3,34 @@ ;;; ;;; This code is in the public domain. -;;; (software-type) should be set to the generic operating system type. +;;@ (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 +;;@ (scheme-implementation-type) should return the name of the scheme ;;; implementation loading this file. - (define (scheme-implementation-type) 'Template) -;;; (scheme-implementation-home-page) should return a (string) URI +;;@ (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) #f) -;;; (scheme-implementation-version) should return a string describing +;;@ (scheme-implementation-version) should return a string describing ;;; the version the scheme implementation loading this file. - (define (scheme-implementation-version) "?") -;;; (implementation-vicinity) should be defined to be the pathname of +;;@ (implementation-vicinity) should be defined to be the pathname of ;;; the directory where any auxillary files to your Scheme ;;; implementation reside. - (define (implementation-vicinity) (case (software-type) ((UNIX) "/usr/local/src/scheme/") ((VMS) "scheme$src:") ((MS-DOS) "C:\\scheme\\"))) -;;; (library-vicinity) should be defined to be the pathname of the +;;@ (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 @@ -51,17 +45,21 @@ (else ""))))) (lambda () library-path))) -;;; (home-vicinity) should return the vicinity of the user's HOME +;;@ (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-path (getenv "HOME"))) - (lambda () home-path))) - -;;; *FEATURES* should be set to a list of symbols describing features +(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))))) + +;;@ *FEATURES* should be set to a list of symbols describing features ;;; of this implementation. Suggestions for features are: - (define *features* '( source ;can load scheme source files @@ -71,7 +69,7 @@ ;; Scheme report features - rev5-report ;conforms to + r5rs ;conforms to eval ;R5RS two-argument eval values ;R5RS multiple values dynamic-wind ;R5RS dynamic-wind @@ -85,11 +83,11 @@ ;STRING-FILL!, LIST->VECTOR, ;VECTOR->LIST, and VECTOR-FILL! - rev4-report ;conforms to + r4rs ;conforms to ieee-p1178 ;conforms to -; rev3-report ;conforms to +; r3rs ;conforms to ; rev2-procedures ;SUBSTRING-MOVE-LEFT!, ;SUBSTRING-MOVE-RIGHT!, @@ -100,7 +98,7 @@ ; multiarg/and- ;/ and - can take more than 2 args. ; with-file ;has WITH-INPUT-FROM-FILE and - ;WITH-OUTPUT-FROM-FILE + ;WITH-OUTPUT-TO-FILE ; transcript ;TRANSCRIPT-ON and TRANSCRIPT-OFF ieee-floating-point ;conforms to IEEE Standard 754-1985 ;IEEE Standard for Binary @@ -133,66 +131,66 @@ )) -;;; (OUTPUT-PORT-WIDTH ) +;;@ (OUTPUT-PORT-WIDTH ) (define (output-port-width . arg) 79) -;;; (OUTPUT-PORT-HEIGHT ) +;;@ (OUTPUT-PORT-HEIGHT ) (define (output-port-height . arg) 24) -;;; (CURRENT-ERROR-PORT) +;;@ (CURRENT-ERROR-PORT) (define current-error-port (let ((port (current-output-port))) (lambda () port))) -;;; (TMPNAM) makes a temporary file name. +;;@ (TMPNAM) makes a temporary file name. (define tmpnam (let ((cntr 100)) (lambda () (set! cntr (+ 1 cntr)) (string-append "slib_" (number->string cntr))))) -;;; (FILE-EXISTS? ) +;;@ (FILE-EXISTS? ) (define (file-exists? f) #f) -;;; (DELETE-FILE ) +;;@ (DELETE-FILE ) (define (delete-file f) #f) -;;; FORCE-OUTPUT flushes any pending output on optional arg output port +;;@ 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. -;;; "rationalize" adjunct procedures. +;;@ "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 +;;@ 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 +;;@ MOST-POSITIVE-FIXNUM is used in modular.scm (define most-positive-fixnum #x0FFFFFFF) -;;; Return argument +;;@ Return argument (define (identity x) x) -;;; SLIB:EVAL is single argument eval using the top-level (user) environment. +;;@ SLIB:EVAL is single argument eval using the top-level (user) environment. (define slib:eval eval) -;;; If your implementation provides R4RS macros: +;; If your implementation provides R4RS macros: ;(define macro:eval slib:eval) ;(define macro:load load) - (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))) @@ -200,7 +198,7 @@ (if a (apply (cdr a) (cdr e)) e)) (else e))) e)) - +;@ (define (macroexpand e) (if (pair? e) (let ((a (car e))) @@ -209,7 +207,7 @@ (if a (macroexpand (apply (cdr a) (cdr e))) e)) (else e))) e)) - +;@ (define gentemp (let ((*gensym-counter* -1)) (lambda () @@ -218,13 +216,15 @@ (string-append "slib:G" (number->string *gensym-counter*)))))) (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:eval-load evl) (if (not (file-exists? )) (set! (string-append (scheme-file-suffix)))) @@ -236,61 +236,89 @@ ((eof-object? o)) (evl o)) (set! *load-pathname* old-load-pathname))))) - +;@ (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 x cep)) args)))) + (for-each (lambda (x) (display #\ cep) (write x cep)) args)))) -;;; define an error procedure for the library +;;@ define an error procedure for the library (define (slib:error . args) (if (provided? 'trace) (print-call-stack (current-error-port))) (apply error args)) - -;;; define these as appropriate for your system. +;@ +(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)) -;;; Support for older versions of Scheme. Not enough code for its own file. +;;@ 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 +;;@ 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 in-vicinity string-append) -;;; Define SLIB:EXIT to be the implementation procedure to exit or +;;@ Define SLIB:EXIT to be the implementation procedure to exit or ;;; return if exitting not supported. (define slib:exit (lambda args #f)) -;;; Here for backward compatability +;;@ 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 +;;@ (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 +;;@ (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. - +;;@ At this point SLIB:LOAD must be able to load SLIB files. (define slib:load slib:load-source) (slib:load (in-vicinity (library-vicinity) "require")) diff --git a/alist.scm b/alist.scm index 5917c7c..f1bdd70 100644 --- a/alist.scm +++ b/alist.scm @@ -1,5 +1,5 @@ ;;;"alist.scm", alist functions for Scheme. -;;;Copyright (c) 1992, 1993 Aubrey Jaffer +;;;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 @@ -8,7 +8,7 @@ ;1. Any copy made of this software must include this copyright notice ;in full. ; -;2. I have made no warrantee or representation that the operation of +;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. ; @@ -17,6 +17,23 @@ ;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) @@ -30,12 +47,28 @@ ((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) @@ -44,6 +77,16 @@ 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) @@ -58,9 +101,17 @@ (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)) diff --git a/alist.txi b/alist.txi new file mode 100644 index 0000000..804df8a --- /dev/null +++ b/alist.txi @@ -0,0 +1,70 @@ +@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 diff --git a/alistab.scm b/alistab.scm index e51bd26..e8999bf 100644 --- a/alistab.scm +++ b/alistab.scm @@ -8,7 +8,7 @@ ;1. Any copy made of this software must include this copyright notice ;in full. ; -;2. I have made no warrantee or representation that the operation of +;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. ; @@ -23,7 +23,9 @@ ;;; 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*) @@ -42,13 +44,15 @@ (list resources (list 'free-id 1)))) (define (open-base infile writable) - (and (or (input-port? infile) (file-exists? infile)) - (cons (if (input-port? infile) #f infile) - ((lambda (fun) - (if (input-port? infile) - (fun infile) - (call-with-input-file infile fun))) - read)))) + (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) @@ -57,7 +61,8 @@ (else #f))) (lambda (port) (display (string-append - ";;; \"" outfile "\" SLIB alist-table database -*-scheme-*-") + ";;; \"" outfile "\" SLIB " *SLIB-VERSION* + " alist-table database -*-scheme-*-") port) (newline port) (newline port) (display "(" port) (newline port) @@ -303,12 +308,12 @@ (define (supported-type? type) (case type - ((base-id atom integer boolean string symbol expression number) #t) + ((atom ordinal integer boolean string symbol expression number) #t) (else #f))) (define (supported-key-type? type) (case type - ((atom integer number symbol string) #t) + ((atom ordinal integer number symbol string) #t) (else #f))) ;;make-table open-table remover assoc* make-assoc* @@ -349,4 +354,8 @@ (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) diff --git a/array.scm b/array.scm index 47df853..417e137 100644 --- a/array.scm +++ b/array.scm @@ -1,5 +1,5 @@ ;;;;"array.scm" Arrays for Scheme -; Copyright (C) 2001 Aubrey Jaffer +; Copyright (C) 2001, 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 @@ -8,7 +8,7 @@ ;1. Any copy made of this software must include this copyright notice ;in full. ; -;2. I have made no warrantee or representation that the operation of +;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. ; @@ -30,7 +30,12 @@ store ;data ))) -(define array:shape (record-accessor array:rtd 'shape)) +(define array:shape + (let ((shape (record-accessor array:rtd 'shape))) + (lambda (array) + (cond ((vector? array) (list (list 0 (+ -1 (vector-length array))))) + ((string? array) (list (list 0 (+ -1 (string-length array))))) + (else (shape array)))))) (define array:scales (let ((scales (record-accessor array:rtd 'scales))) @@ -77,7 +82,8 @@ ;;corresponding elements of @1 and @2 are @code{equal?}. ;; ;;@example -;;(array=? (make-array 'foo 3 3) (make-array 'foo '(0 2) '(1 2))) +;;(array=? (create-array '#(foo) 3 3) +;; (create-array '#(foo) '(0 2) '(0 2))) ;; @result{} #t ;;@end example (define (array=? array1 array2) @@ -87,17 +93,133 @@ (define (array:dimensions->shape dims) (map (lambda (dim) (if (list? dim) dim (list 0 (+ -1 dim)))) dims)) -;;@args initial-value bound1 bound2 @dots{} -;;Creates and returns an array with dimensions @var{bound1}, -;;@var{bound2}, @dots{} and filled with @1. -(define (make-array initial-value . dimensions) +;;@args prototype bound1 bound2 @dots{} +;; +;;Creates and returns an array of type @1 with dimensions @2, @3, +;;@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 non-zero origin, 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 (create-array prototype . dimensions) + (define range2length (lambda (bnd) (- 1 (apply - bnd)))) + ;;(if (not (array? prototype)) (set! prototype (vector prototype))) (let* ((shape (array:dimensions->shape dimensions)) - (dims (map (lambda (bnd) (- 1 (apply - bnd))) shape)) - (scales (reverse (cons 1 (cdr (reverse dims)))))) - (array:construct shape - scales - (- (apply + (map * (map car shape) scales))) - (make-vector (apply * dims) initial-value)))) + (dims (map range2length shape)) + (scales + (do ((dims (reverse (cdr dims)) (cdr dims)) + (scls '(1) (cons (* (car dims) (car scls)) scls))) + ((null? dims) scls)))) + (array:construct + shape + scales + (- (apply + (map * (map car shape) scales))) + (if (string? prototype) + (case (string-length prototype) + ((0) (make-string (apply * dims))) + (else (make-string (apply * dims) + (string-ref prototype 0)))) + (let ((pshape (array:shape prototype))) + (case (apply * (map range2length pshape)) + ((0) (make-vector (apply * dims))) + (else (make-vector (apply * dims) + (apply array-ref prototype + (map car pshape)))))))))) + +;;@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)))))) + +;;@args z +;;@args +;;Returns a high-precision complex uniform-array prototype. +(define Ac64 (make-prototype-checker 'Ac64 complex? vector)) +;;@args z +;;@args +;;Returns a complex uniform-array prototype. +(define Ac32 (make-prototype-checker 'Ac32 complex? vector)) + +;;@args x +;;@args +;;Returns a high-precision real uniform-array prototype. +(define Ar64 (make-prototype-checker 'Ar64 real? vector)) +;;@args x +;;@args +;;Returns a real uniform-array prototype. +(define Ar32 (make-prototype-checker 'Ar32 real? vector)) + +;;@args n +;;@args +;;Returns an exact signed integer uniform-array prototype with at least +;;64 bits of precision. +(define As64 (make-prototype-checker 'As64 (integer-bytes?? -8) vector)) +;;@args n +;;@args +;;Returns an exact signed integer uniform-array prototype with at least +;;32 bits of precision. +(define As32 (make-prototype-checker 'As32 (integer-bytes?? -4) vector)) +;;@args n +;;@args +;;Returns an exact signed integer uniform-array prototype with at least +;;16 bits of precision. +(define As16 (make-prototype-checker 'As16 (integer-bytes?? -2) vector)) +;;@args n +;;@args +;;Returns an exact signed integer uniform-array prototype with at least +;;8 bits of precision. +(define As8 (make-prototype-checker 'As8 (integer-bytes?? -1) vector)) + +;;@args k +;;@args +;;Returns an exact non-negative integer uniform-array prototype with at +;;least 64 bits of precision. +(define Au64 (make-prototype-checker 'Au64 (integer-bytes?? 8) vector)) +;;@args k +;;@args +;;Returns an exact non-negative integer uniform-array prototype with at +;;least 32 bits of precision. +(define Au32 (make-prototype-checker 'Au32 (integer-bytes?? 4) vector)) +;;@args k +;;@args +;;Returns an exact non-negative integer uniform-array prototype with at +;;least 16 bits of precision. +(define Au16 (make-prototype-checker 'Au16 (integer-bytes?? 2) vector)) +;;@args k +;;@args +;;Returns an exact non-negative integer uniform-array prototype with at +;;least 8 bits of precision. +(define Au8 (make-prototype-checker 'Au8 (integer-bytes?? 1) vector)) + +;;@args bool +;;@args +;;Returns a boolean uniform-array prototype. +(define At1 (make-prototype-checker 'At1 boolean? vector)) ;;@noindent ;;When constructing an array, @var{bound} is either an inclusive range of @@ -105,18 +227,18 @@ ;;a single integer. So ;; ;;@example -;;(make-array 'foo 3 3) @equiv{} (make-array 'foo '(0 2) '(0 2)) +;;(create-array '#(foo) 3 3) @equiv{} (create-array '#(foo) '(0 2) '(0 2)) ;;@end example ;;@args array mapper bound1 bound2 @dots{} -;;@code{make-shared-array} can be used to create shared subarrays of other +;;@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 fred (create-array '#(#f) 8 8)) ;;(define freds-diagonal ;; (make-shared-array fred (lambda (i) (list i i)) 8)) ;;(array-set! freds-diagonal 'foo 3) @@ -153,32 +275,28 @@ ;;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-shape obj)) 0)) + (if (array? obj) (length (array:shape obj)) 0)) -;;@body +;;@args array ;;Returns a list of inclusive bounds. ;; ;;@example -;;(array-shape (make-array 'foo 3 5)) +;;(array-shape (create-array '#() 3 5)) ;; @result{} ((0 2) (0 4)) ;;@end example -(define array-shape - (lambda (array) - (cond ((vector? array) (list (list 0 (+ -1 (vector-length array))))) - ((string? array) (list (list 0 (+ -1 (string-length array))))) - (else (array:shape array))))) +(define array-shape array:shape) ;;@body ;;@code{array-dimensions} is similar to @code{array-shape} but replaces ;;elements with a 0 minimum with one greater than the maximum. ;; ;;@example -;;(array-dimensions (make-array 'foo 3 5)) +;;(array-dimensions (create-array '#() 3 5)) ;; @result{} (3 5) ;;@end example (define (array-dimensions array) (map (lambda (bnd) (if (zero? (car bnd)) (+ 1 (cadr bnd)) bnd)) - (array-shape array))) + (array:shape array))) (define (array:in-bounds? array indices) (do ((bnds (array:shape array) (cdr bnds)) @@ -217,12 +335,8 @@ ;;; Legacy functions -;; These procedures are fast versions of @code{array-ref} and -;; @code{array-set!} for non-string arrays; they take a fixed number of -;; arguments and perform no bounds checking. -(define array-1d-ref array-ref) -(define array-2d-ref array-ref) -(define array-3d-ref array-ref) -(define array-1d-set! array-set!) -(define array-2d-set! array-set!) -(define array-3d-set! array-set!) +;; ;;@args initial-value bound1 bound2 @dots{} +;; ;;Creates and returns an array with dimensions @2, +;; ;;@3, @dots{} and filled with @1. +;; (define (make-array initial-value . dimensions) +;; (apply create-array (vector initial-value) dimensions)) diff --git a/array.txi b/array.txi new file mode 100644 index 0000000..bb09e16 --- /dev/null +++ b/array.txi @@ -0,0 +1,227 @@ +@code{(require 'array)} +@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. Strings +and vectors 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 array=? array1 array2 + +Returns @code{#t} if @var{array1} and @var{array2} have the same rank and shape and the +corresponding elements of @var{array1} and @var{array2} are @code{equal?}. + +@example +(array=? (create-array '#(foo) 3 3) + (create-array '#(foo) '(0 2) '(0 2))) + @result{} #t +@end example +@end defun + +@defun create-array prototype bound1 bound2 @dots{} + + +Creates and returns an array of type @var{prototype} with dimensions @var{bound1}, @var{bound2}, +@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 non-zero origin, 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 +@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 ac64 z + + +@defunx ac64 +Returns a high-precision complex uniform-array prototype. +@end defun + +@defun ac32 z + + +@defunx ac32 +Returns a complex uniform-array prototype. +@end defun + +@defun ar64 x + + +@defunx ar64 +Returns a high-precision real uniform-array prototype. +@end defun + +@defun ar32 x + + +@defunx ar32 +Returns a real uniform-array prototype. +@end defun + +@defun as64 n + + +@defunx as64 +Returns an exact signed integer uniform-array prototype with at least +64 bits of precision. +@end defun + +@defun as32 n + + +@defunx as32 +Returns an exact signed integer uniform-array prototype with at least +32 bits of precision. +@end defun + +@defun as16 n + + +@defunx as16 +Returns an exact signed integer uniform-array prototype with at least +16 bits of precision. +@end defun + +@defun as8 n + + +@defunx as8 +Returns an exact signed integer uniform-array prototype with at least +8 bits of precision. +@end defun + +@defun au64 k + + +@defunx au64 +Returns an exact non-negative integer uniform-array prototype with at +least 64 bits of precision. +@end defun + +@defun au32 k + + +@defunx au32 +Returns an exact non-negative integer uniform-array prototype with at +least 32 bits of precision. +@end defun + +@defun au16 k + + +@defunx au16 +Returns an exact non-negative integer uniform-array prototype with at +least 16 bits of precision. +@end defun + +@defun au8 k + + +@defunx au8 +Returns an exact non-negative integer uniform-array prototype with at +least 8 bits of precision. +@end defun + +@defun at1 bool + + +@defunx at1 +Returns a boolean uniform-array prototype. +@end defun +@noindent +When constructing an array, @var{bound} is either an inclusive range of +indices expressed as a two element list, or an upper bound expressed as +a single integer. So + +@example +(create-array '#(foo) 3 3) @equiv{} (create-array '#(foo) '(0 2) '(0 2)) +@end example + + +@defun make-shared-array array mapper bound1 bound2 @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 (create-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 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-shape array + +Returns a list of inclusive bounds. + +@example +(array-shape (create-array '#() 3 5)) + @result{} ((0 2) (0 4)) +@end example +@end defun + +@defun array-dimensions array + +@code{array-dimensions} is similar to @code{array-shape} but replaces +elements with a 0 minimum with one greater than the maximum. + +@example +(array-dimensions (create-array '#() 3 5)) + @result{} (3 5) +@end example +@end defun + +@defun array-in-bounds? array index1 index2 @dots{} + +Returns @code{#t} if its arguments would be acceptable to +@code{array-ref}. +@end defun + +@defun array-ref array index1 index2 @dots{} + +Returns the (@var{index1}, @var{index2}, @dots{}) element of @var{array}. +@end defun + +@deffn {Procedure} array-set! array obj index1 index2 @dots{} + +Stores @var{obj} in the (@var{index1}, @var{index2}, @dots{}) element of @var{array}. The value returned +by @code{array-set!} is unspecified. +@end deffn diff --git a/arraymap.scm b/arraymap.scm index 15e24da..747962e 100644 --- a/arraymap.scm +++ b/arraymap.scm @@ -1,5 +1,5 @@ ;;;; "arraymap.scm", applicative routines for arrays in Scheme. -;;; Copyright (c) 1993 Aubrey Jaffer +;;; 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 @@ -8,7 +8,7 @@ ;1. Any copy made of this software must include this copyright notice ;in full. ; -;2. I have made no warrantee or representation that the operation of +;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. ; @@ -19,6 +19,16 @@ (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 rshape inds) (if (null? (cdr rshape)) @@ -27,8 +37,7 @@ (cons (+ -1 i) inds))) ((< i (caar rshape))) (apply array-set! ra0 - (apply proc (map (lambda (ra) (apply array-ref ra is)) - ras)) + (apply proc (map (lambda (ra) (apply array-ref ra is)) ras)) is)) (let ((crshape (cdr rshape)) (ll (caar rshape))) @@ -37,14 +46,31 @@ (ramap crshape (cons i inds)))))) (ramap (reverse (array-shape 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 create-array prototype (array-shape 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 rshape inds) (if (null? (cdr rshape)) - (do ((i (caar rshape) (+ 1 i))) - ((> i (cadar rshape))) - (apply proc - (map (lambda (ra) - (apply array-ref ra (reverse (cons i inds)))) ras))) + (let ((sdni (reverse (cons #f inds)))) + (define lastpair (last-pair sdni)) + (do ((i (caar rshape) (+ 1 i))) + ((> i (cadar rshape))) + (set-car! lastpair i) + (apply proc (map (lambda (ra) (apply array-ref ra sdni)) ras)))) (let ((crshape (cdr rshape)) (ll (cadar rshape))) (do ((i (caar rshape) (+ 1 i))) @@ -52,6 +78,35 @@ (rafe crshape (cons i inds)))))) (rafe (array-shape (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 create-array '#() (array-shape ra)))) + (array-index-map! ra0 list) + ra0)) + +;;@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 create-array '#() (array-shape 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) (define (ramap rshape inds) (if (null? (cdr rshape)) @@ -69,10 +124,10 @@ (array-set! ra (fun)) (ramap (reverse (array-shape ra)) '()))) -(define (array-indexes ra) - (let ((ra0 (apply make-array '() (array-shape ra)))) - (array-index-map! ra0 list) - ra0)) - +;;@args source destination +;;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! source dest) (array-map! dest identity source)) diff --git a/arraymap.txi b/arraymap.txi new file mode 100644 index 0000000..f10ad65 --- /dev/null +++ b/arraymap.txi @@ -0,0 +1,68 @@ +@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 + +@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 create-array '#() (array-shape 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! source destination + +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 diff --git a/batch.scm b/batch.scm index 45b404c..bef29cc 100644 --- a/batch.scm +++ b/batch.scm @@ -8,7 +8,7 @@ ;1. Any copy made of this software must include this copyright notice ;in full. ; -;2. I have made no warrantee or representation that the operation of +;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. ; @@ -17,11 +17,14 @@ ;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 'database-utilities) (require 'string-port) -(require 'tree) +(require 'pretty-print) +(require 'common-list-functions) +(require-if '(and bignum compiling) 'posix-time) (define system (if (provided? 'system) @@ -43,6 +46,9 @@ (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 (write-batch-line str line-limit port) (cond ((and line-limit (>= (string-length str) line-limit)) (slib:warn 'write-batch-line 'too-long @@ -53,7 +59,7 @@ (write-batch-line str (batch:line-length-limit parms) (batch:port parms))) ;;; 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)) @@ -65,7 +71,7 @@ (batch:try-command parms str)) ((< (length fodder) 2) (slib:warn 'batch:try-chopped-command "can't fit in " line-limit - (cons proc (append args-but-last (list fodder)))) + (append args-but-last (list fodder))) #f) (else (let ((hlen (quotient (length fodder) 2))) (and (loop (last fodder hlen)) @@ -74,15 +80,15 @@ (define (batch:glued-line parms strings) (case (batch:dialect parms) ((vms) (apply string-join " " "$" strings)) - ((unix dos amigados system *unknown*) (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 amigados) (batch-line parms line)) + ((unix dos vms amigaos) (batch-line parms line)) ((system) (let ((port (batch:port parms))) (write `(system ,line) port) (newline port) @@ -91,11 +97,11 @@ (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)) @@ -106,12 +112,12 @@ ((unix) (write-batch-line (string-append "# " line) #f port)) ((dos) (write-batch-line (string-append "rem " line) #f port)) ((vms) (write-batch-line (string-append "$! " line) #f port)) - ((amigados) (write-batch-line (string-append "; " line) #f port)) + ((amigaos) (write-batch-line (string-append "; " line) #f port)) ((system) (write-batch-line (string-append "; " line) #f port)) ((*unknown*) (write-batch-line (string-append ";;; " line) #f port) ;;(newline port) #f))) - +;@ (define (batch:comment parms . lines) (define port (batch:port parms)) (define dialect (batch:dialect parms)) @@ -119,7 +125,7 @@ (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)) @@ -142,7 +148,7 @@ (every (lambda (string) (batch-line parms string)) lines) (batch-line parms (string-append "$EOD")))) - ((amigados) (batch-line parms (string-append "delete force " file)) + ((amigaos) (batch-line parms (string-append "delete force " file)) (every (lambda (str) (letrec ((star-quote @@ -162,7 +168,6 @@ lines)) ((system) (write `(delete-file ,file) port) (newline port) (delete-file file) - (require 'pretty-print) (pretty-print `(call-with-output-file ,file (lambda (fp) (for-each @@ -175,7 +180,6 @@ #t) ((*unknown*) (write `(delete-file ,file) port) (newline port) - (require 'pretty-print) (pretty-print `(call-with-output-file ,file (lambda (fp) @@ -185,7 +189,7 @@ ,lines))) port) #f))) - +;@ (define (batch:delete-file parms file) (define port (batch:port parms)) (case (batch:dialect parms) @@ -195,13 +199,13 @@ #t) ((vms) (batch-line parms (string-append "$DELETE " file)) #t) - ((amigados) (batch-line parms (string-append "delete force " file)) + ((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) @@ -209,15 +213,18 @@ ;;((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))) - ((amigados) (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))) + ((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 dialect name port) +(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) @@ -228,6 +235,7 @@ ((dos) "DOS") ((default-for-platform) "??") (else (symbol->string dialect)))) + " (" (symbol->string operating-system) ")" " script created by SLIB/batch " (cond ((provided? 'bignum) (require 'posix-time) @@ -235,9 +243,11 @@ (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) @@ -247,8 +257,11 @@ ((output-port? name) (lambda (proc) (proc name))) (else (lambda (proc) (proc (current-output-port))))) (lambda (port) - (write-line "#!/bin/sh" port) - (batch:write-header-comment dialect name 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) @@ -257,7 +270,7 @@ ((output-port? name) (lambda (proc) (proc name))) (else (lambda (proc) (proc (current-output-port))))) (lambda (port) - (batch:write-header-comment dialect name port) + (batch:write-header-comment parms name port) (proc port)))) ((vms) ((cond ((string? name) @@ -266,20 +279,20 @@ ((output-port? name) (lambda (proc) (proc name))) (else (lambda (proc) (proc (current-output-port))))) (lambda (port) - (batch:write-header-comment dialect name port) + (batch:write-header-comment parms name port) ;;(write-line "$DEFINE/USER SYS$OUTPUT BUILD.LOG" port) (proc port)))) - ((amigados) ((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 dialect name 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) @@ -290,7 +303,7 @@ ((output-port? name) (lambda (proc) (proc name))) (else (lambda (proc) (proc (current-output-port))))) (lambda (port) - (batch:write-header-comment dialect name port) + (batch:write-header-comment parms name port) (proc port)))) ((*unknown*) ((cond ((and (string? name) (provided? 'system)) @@ -302,7 +315,7 @@ ((output-port? name) (lambda (proc) (proc name))) (else (lambda (proc) (proc (current-output-port))))) (lambda (port) - (batch:write-header-comment dialect name port) + (batch:write-header-comment parms name port) (proc port)))))) ;;; This little ditty figures out how to use a Scheme extension or @@ -321,8 +334,9 @@ (else (let ((pl (make-parameter-list (map car parms)))) (adjoin-parameters! - pl (cons 'batch-dialect (os->batch-dialect - (parameter-list-ref parms 'platform)))) + pl (cons 'batch-dialect + (os->batch-dialect + (parameter-list-ref parms 'operating-system)))) (system (call-with-output-string (lambda (port) @@ -332,7 +346,7 @@ (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))) @@ -341,15 +355,15 @@ (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 @@ -369,21 +383,15 @@ obj "in" strings)))) strings))) -(define batch:platform (software-type)) -(cond ((and (eq? 'unix batch:platform) (provided? 'system)) - (let ((file-name (tmpnam))) - (system (string-append "uname > " file-name)) - (set! batch:platform (call-with-input-file file-name read)) - (delete-file file-name)))) - (define batch:database #f) -(define os->batch-dialect #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 @@ -394,7 +402,7 @@ ((unix 1023) (dos 127) (vms 1023) - (amigados 511) + (amigaos 511) (system 1023) (*unknown* -1))) @@ -406,7 +414,7 @@ (acorn *unknown*) (aix unix) (alliant *unknown*) - (amiga amigados) + (amiga amigaos) (apollo unix) (apple2 *unknown*) (arm *unknown*) @@ -415,6 +423,7 @@ (celerity *unknown*) (concurrent *unknown*) (convex *unknown*) + (darwin unix) (encore *unknown*) (harris *unknown*) (hp-ux unix) @@ -432,6 +441,7 @@ (novell *unknown*) (os/2 dos) (osf1 unix) + (plan9 unix) (prime *unknown*) (psion *unknown*) (pyramid *unknown*) @@ -445,10 +455,29 @@ (vms vms) ))) - ((database 'add-domain) '(operating-system operating-system #f symbol #f)) + (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)))) diff --git a/bigloo.init b/bigloo.init index 41a4179..9ded1a4 100644 --- a/bigloo.init +++ b/bigloo.init @@ -7,34 +7,29 @@ ;;; (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://kaolin.unice.fr/~serrano/bigloo/bigloo.html") + "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) "2.0c") +(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) (case (software-type) - ((UNIX) "/usr/local/lib/bigloo/") - ((VMS) "scheme$src:") - ((MS-DOS) "C:\\scheme\\"))) + ((UNIX) (string-append *default-lib-dir* "/")) + ((MS-DOS) "C:\\scheme\\") + (else ""))) ;;; (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 @@ -43,8 +38,11 @@ ;; Use this path if your scheme does not support GETENV ;; or if SCHEME_LIBRARY_PATH is not set. (case (software-type) - ((UNIX) "/usr/share/slib/") - ((VMS) "lib$scheme:") + ((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))) @@ -52,15 +50,19 @@ ;;; (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-path (getenv "HOME"))) - (lambda () home-path))) +(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))))) ;;; *FEATURES* should be set to a list of symbols describing features ;;; of this implementation. See Template.scm for the list of feature ;;; names. - (define *features* '( source ;can load scheme source files @@ -70,7 +72,7 @@ ;; Scheme report features -; rev5-report ;conforms to +; r5rs ;conforms to eval ;R5RS two-argument eval ; values ;R5RS multiple values ; dynamic-wind ;R5RS dynamic-wind @@ -84,11 +86,11 @@ ;STRING-FILL!, LIST->VECTOR, ;VECTOR->LIST, and VECTOR-FILL! - rev4-report ;conforms to + r4rs ;conforms to ieee-p1178 ;conforms to - rev3-report ;conforms to + r3rs ;conforms to ; rev2-procedures ;SUBSTRING-MOVE-LEFT!, ;SUBSTRING-MOVE-RIGHT!, @@ -99,7 +101,7 @@ multiarg/and- ;/ and - can take more than 2 args. with-file ;has WITH-INPUT-FROM-FILE and - ;WITH-OUTPUT-FROM-FILE + ;WITH-OUTPUT-TO-FILE transcript ;TRANSCRIPT-ON and TRANSCRIPT-OFF ieee-floating-point ;conforms to IEEE Standard 754-1985 ;IEEE Standard for Binary @@ -170,6 +172,37 @@ (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 '" "'"))) + ;;; "rationalize" adjunct procedures. (define (find-ratio x e) (let ((rat (rationalize x e))) @@ -216,7 +249,7 @@ (let ((cep (current-error-port))) (if (provided? 'trace) (print-call-stack cep)) (display "Warn: " cep) - (for-each (lambda (x) (display x cep)) args)))) + (for-each (lambda (x) (display #\ cep) (write x cep)) args)))) ;;; define an error procedure for the library @@ -238,7 +271,7 @@ )) -(define (promise:force p) (force p)) +;;(define force force) ;;; Define these if your implementation's syntax can support it and if ;;; they are not already defined. @@ -262,17 +295,14 @@ ;;; (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 slib:load-source) (define defmacro:eval slib:eval) diff --git a/break.scm b/break.scm index 4d18efc..d62eeb6 100644 --- a/break.scm +++ b/break.scm @@ -1,5 +1,5 @@ ;;;; "break.scm" Breakpoints for debugging in Scheme. -;;; Copyright (C) 1991, 1992, 1993, 1995 Aubrey Jaffer +;;; 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 @@ -8,7 +8,7 @@ ;1. Any copy made of this software must include this copyright notice ;in full. ; -;2. I have made no warrantee or representation that the operation of +;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. ; @@ -18,6 +18,7 @@ ;each case. (require 'qp) +(require 'alist) ;;;; BREAKPOINTS @@ -29,8 +30,8 @@ ;;; of breakpoint:continuation-stack and returns #f to it. (define breakpoint:continuation-stack '()) - -(define debug:breakpoint +;@ +(define breakpoint (let ((call-with-current-continuation call-with-current-continuation) (apply apply) (qpn qpn) (cons cons) (length length)) @@ -45,8 +46,8 @@ (debug:top-continuation (length breakpoint:continuation-stack)))))) (cond ((not (eq? ans breakpoint:continuation-stack)) ans)))))) - -(define debug:continue +;@ +(define continue (let ((null? null?) (car car) (cdr cdr)) (lambda args (cond ((null? breakpoint:continuation-stack) @@ -63,21 +64,17 @@ (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 breakpoint debug:breakpoint) -(define bkpt debug:breakpoint) -(define continue debug:continue) - +;@ (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 debug:breakpoint)) + (apply apply) (display display) (breakpoint breakpoint)) (lambda (function . optname) ;; (set! trace:indent 0) (let ((name (if (null? optname) function (car optname)))) @@ -92,7 +89,7 @@ ;;; 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)) @@ -101,7 +98,6 @@ ;;; niceties like keeping track of breakd functions and dealing with ;;; redefinition. -(require 'alist) (define break:adder (alist-associator eq?)) (define break:deler (alist-remover eq?)) @@ -131,9 +127,8 @@ ((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))) diff --git a/byte.scm b/byte.scm index b34816d..b7e12da 100644 --- a/byte.scm +++ b/byte.scm @@ -1,15 +1,219 @@ ;;; "byte.scm" small integers, not necessarily chars. +; Copyright (c) 2001, 2002, 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 (byte-ref str ind) (char->integer (string-ref str ind))) -(define (byte-set! str ind val) (string-set! str ind (integer->char val))) +;;@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 + +;;@body +;;@2 must be a valid index of @1. @0 returns byte @2 of @1 using +;;zero-origin indexing. +(define (byte-ref bytes k) (char->integer (string-ref bytes k))) + +;;@body +;;@2 must be a valid index of @1, and @var{byte} must be a small +;;nonnegative integer. @0 stores @var{byte} in element @2 of @1 and +;;returns an unspecified value. @c +(define (byte-set! bytes k byte) (string-set! bytes k (integer->char byte))) + +;;@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) (if (null? opt) (make-string len) (make-string len (integer->char (car opt))))) + +;;@args bytes +;;@0 returns length of byte-array @1. (define bytes-length string-length) + +;;@args byte @dots{} +;;Returns a newly allocated byte-array composed of the small +;;nonnegative arguments. +(define (bytes . args) (list->bytes args)) + +;;@args bytes +;;@0 returns a newly allocated list of the bytes that make up the +;;given byte-array. +(define (bytes->list bts) (map char->integer (string->list bts))) + +;;@args bytes +;;@0 returns a newly allocated byte-array formed from the small +;;nonnegative integers in the list @1. +(define (list->bytes lst) (list->string (map integer->char lst))) + +;;@noindent +;;@code{Bytes->list} and @code{list->bytes} are inverses so far as +;;@code{equal?} is concerned. +;;@findex equal? + +;;@args bytes +;;Returns a newly allocated copy of the given @1. +(define bytes-copy string-copy) + +;;@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)))) -(define (bytes . args) (list->bytes args)) -(define (bytes->list bts) (map char->integer (string->list bts))) -(define (list->bytes lst) (list->string (map integer->char lst))) + +;;@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 +;;string 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 substring-read! byts 0 n port) + (apply substring-read! byts (- n) 0 port)))) + (if (= cnt len) + byts + (if (positive? n) + (substring byts 0 cnt) + (substring 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 substring-write bytes 0 n port) + (apply substring-write bytes (- n) 0 port))) + +;;@noindent +;;@code{substring-read!} and @code{substring-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 string start end port +;;@args string 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 (substring-read! string 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! string 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! string idx byt))))))) + +;;@args string start end port +;;@args string 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 (substring-write string start end . port) + (if (>= end start) + (do ((idx start (+ 1 idx))) + ((>= idx end) (- end start)) + (apply write-byte (byte-ref string idx) port)) + (do ((idx (+ -1 start) (+ -1 idx))) + ((< idx end) (- start end)) + (apply write-byte (byte-ref string idx) port)))) diff --git a/byte.txi b/byte.txi new file mode 100644 index 0000000..01c725b --- /dev/null +++ b/byte.txi @@ -0,0 +1,179 @@ +@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 bytes->list bytes + +@code{bytes->list} returns a newly allocated list of the bytes that make up the +given byte-array. +@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 +@noindent +@code{Bytes->list} and @code{list->bytes} are inverses so far as +@code{equal?} is concerned. +@findex equal? + + +@defun bytes-copy bytes + +Returns a newly allocated copy of the given @var{bytes}. +@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 +string 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{substring-read!} and @code{substring-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} substring-read! string start end port + + +@deffnx {Procedure} substring-read! string start end +Fills @var{string} with up to @code{(abs (- @var{start} @var{end}))} bytes +read from @var{port}. The first byte read is stored at index @var{string}. +@code{substring-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 substring-write string start end port + + +@defunx substring-write string start end +@code{substring-write} writes @code{(abs (- @var{start} @var{end}))} bytes to +output-port @var{port}. The first byte written is index @var{start} of @var{string}. @code{substring-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 diff --git a/bytenumb.scm b/bytenumb.scm new file mode 100644 index 0000000..68ee748 --- /dev/null +++ b/bytenumb.scm @@ -0,0 +1,346 @@ +;;; "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) + +(define bn:expt + (if (provided? 'inexact) expt + (lambda (n k) (if (negative? k) 0 (integer-expt n k))))) + +;;@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 -1 1) (bn:expt 2 (- E 127)) (+ 1 F))) + ((zero? E) + (if (zero? F) + (if S (- zero) zero) + (* (if S -1 1) (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 #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{} -1/0 +;;(bytes->ieee-float (bytes #x7f #x80 0 0)) @result{} 1/0 +;;(bytes->ieee-float (bytes #x7f #x80 0 1)) @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 -1 1) (bn:expt 2 (- E 1023)) (+ 1 F))) + ((zero? E) + (if (zero? F) + (if S (- zero) zero) + (* (if S -1 1) (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 #x40 0 0 0 0 0 0 0)) @result{} 2 +;;(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{} -1/0 +;;(bytes->ieee-double (bytes #x7F #xF0 0 0 0 0 0 0)) @result{} 1/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 (negative? flt)) + (define (scale flt scl) + (cond ((zero? scl) (out (/ flt 2) scl)) + ((zero? flt) byts) + ((>= flt 16) + (let ((flt/16 (/ flt 16))) + (cond ((= flt/16 flt) + (byte-set! byts 0 (if S #xFF #x7F)) + (byte-set! byts 1 (if (= flt (* zero flt)) #xC0 #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))) + (scale (abs flt) 127)))) +;;@example +;;(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 -1/0)) @result{} (255 128 0 0) +;;(bytes->list (ieee-float->bytes 1/0)) @result{} (127 128 0 0) +;;(bytes->list (ieee-float->bytes 0/0)) @result{} (127 128 0 1) +;;@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 (negative? flt)) + (define (scale flt scl) + (cond ((zero? scl) (out (/ flt 2) scl)) + ((zero? flt) byts) + ((>= flt 16) + (let ((flt/16 (/ flt 16))) + (cond ((= flt/16 flt) + (byte-set! byts 0 (if S #xFF #x7F)) + (byte-set! byts 1 (if (= flt (* zero flt)) #xF8 #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))) + (scale (abs flt) 1023)))) +;;@example +;;(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 -1/0)) @result{} (255 240 0 0 0 0 0 0) +;;(bytes->list (ieee-double->bytes 1/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 #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{} -1/0 +(bytes->ieee-float (bytes #x7f #x80 0 0)) @result{} 1/0 +(bytes->ieee-float (bytes #x7f #x80 0 1)) @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 #x40 0 0 0 0 0 0 0)) @result{} 2 +(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{} -1/0 +(bytes->ieee-double (bytes #x7F #xF0 0 0 0 0 0 0)) @result{} 1/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 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 -1/0)) @result{} (255 128 0 0) +(bytes->list (ieee-float->bytes 1/0)) @result{} (127 128 0 0) +(bytes->list (ieee-float->bytes 0/0)) @result{} (127 128 0 1) +@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 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 -1/0)) @result{} (255 240 0 0 0 0 0 0) +(bytes->list (ieee-double->bytes 1/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? string1 string2) (chap:string=? string1 string2) (not (chap:stringinteger #\2) (char->integer #\1))) @@ -120,6 +146,19 @@ 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 ") ; (display s2) ; (newline))))) - -(define (chap:string>? s1 s2) (chap:string=? s1 s2) (not (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)) -(define (charplot:center-print! str width) - (let ((lpad (quotient (- width (string-length str)) 2))) - (charplot:printn! lpad #\ ) - (display str) - (charplot:printn! (- width (+ (string-length str) lpad)) #\ ))) - -(define (charplot:number->string x) - (sprintf #f "%g" x)) - -(define (charplot:scale-it z scale) - (if (and (exact? z) (integer? z)) - (quotient (* z (car scale)) (cadr scale)) - (inexact->exact (round (/ (* z (car scale)) (cadr scale)))))) +;;;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) - (define (fs2) - (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))) (cond ((zero? delta) (set! delta 1)) ((inexact? delta) (set! isize (exact->inexact isize)))) - (do ((d 1 (* d 10))) + (do ((d 1 (* d 10)) + (isize isize (* isize 10))) ((<= delta isize) - (do ((n 1 (* n 10))) + (do ((n 1 (* n 10)) + (delta delta (* delta 10))) ((>= (* delta 10) isize) - (list (* n (fs2)) d)) - (set! delta (* delta 10)))) - (set! isize (* isize 10)))) + (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 (create-array " " height width)) + ;;Put newlines on right edge + (do ((idx (+ -1 height) (+ -1 idx))) + ((negative? idx)) + (array-set! pra #\newline idx (+ -1 width))) + pra)) -(define (charplot:iplot! data xlabel ylabel xmin xscale ymin yscale) +;;;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))) - (charplot:center-print! ylabel 11) - (charplot:printn! (+ charplot:width 1) charplot:xborder) - (newline) - (set! data (sort! data (lambda (x y) (if (= (cdr x) (cdr y)) - (< (car x) (car y)) - (> (cdr x) (cdr y)))))) - (do ((ht (- charplot:height 1) (- ht 1))) + (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 ((a (make-string (+ charplot:width 1) - (if (= ht xaxis) charplot:xaxchar #\ ))) - (ystep (if (= 1 (gcd (car yscale) 3)) 2 3))) - (string-set! a charplot:width charplot:yborder) - (if (< -1 yaxis charplot:width) (string-set! a yaxis charplot:yaxchar)) - (do () - ((or (null? data) (not (>= (cdar data) ht)))) - (string-set! a (caar data) charplot:curve1) - (set! data (cdr data))) + (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)))) - (l (string-length v))) - (if (> l 10) - (display (substring v 0 10)) - (begin - (charplot:printn! (- 10 l) #\ ) - (display v))) - (display charplot:yborder) - (display charplot:xaxchar)) - (begin - (charplot:printn! 10 #\ ) - (display charplot:yborder) - (display #\ ))) - (display a) (newline))) - (let* ((xstep (if (= 1 (gcd (car xscale) 3)) 10 12)) - (xstep/2 (quotient (- xstep 2) 2)) - (fudge (modulo yaxis xstep))) - (charplot:printn! 10 #\ ) (display charplot:yborder) - (charplot:printn! (+ 1 fudge) charplot:xborder) - (display charplot:yaxchar) - (do ((i fudge (+ i xstep))) - ((> (+ i xstep) charplot:width) - (charplot:printn! (modulo (- charplot:width (+ i 1)) xstep) - charplot:xborder)) - (charplot:printn! xstep/2 charplot:xborder) - (display charplot:xtick) - (charplot:printn! xstep/2 charplot:xborder) - (display charplot:yaxchar)) - (display charplot:yborder) (newline) - (charplot:center-print! xlabel (+ 12 fudge (- xstep/2))) - (do ((i fudge (+ i xstep))) - ((>= i charplot:width)) - (charplot:center-print! (charplot:number->string - (/ (* (- i yaxis) (cadr xscale)) - (car xscale))) - xstep)) - (newline))) - -(define (charplot:plot! data xlabel ylabel) + (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)) + (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))) + +;;;Converts data to list of coordinates (list). +(define (charplot:data->lists data) (cond ((array? data) (case (array-rank data) - ((1) (set! data (map cons - (let ((ra (apply make-array #f + ((1) (set! data (map list + (let ((ra (apply create-array '#() (array-shape data)))) (array-index-map! ra identity) - (array->list ra)) - (array->list data)))) - ((2) (set! data (map (lambda (lst) (cons (car lst) (cadr lst))) - (array->list data))))))) - (let* ((xmax (apply max (map car data))) - (xmin (apply min (map car data))) - (xscale (charplot:find-scale charplot:width (- xmax xmin))) - (ymax (apply max (map cdr data))) - (ymin (apply min (map cdr data))) - (yscale (charplot:find-scale charplot:height (- ymax ymin))) - (ixmin (charplot:scale-it xmin xscale)) - (iymin (charplot:scale-it ymin yscale))) - (charplot:iplot! (map (lambda (p) - (cons (- (charplot:scale-it (car p) xscale) ixmin) - (- (charplot:scale-it (cdr p) yscale) iymin))) - data) - xlabel ylabel xmin xscale ymin yscale))) - -(define (plot-function! func vlo vhi . npts) - (set! npts (if (null? npts) 100 (car npts))) - (let ((dats (make-array 0.0 npts 2))) + (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 cadr (array-shape pra))))) + (newline)))) + +(define (charplot:plot-function func vlo vhi . npts) + (set! npts (if (null? npts) 64 (car npts))) + (let ((dats (create-array (Ar64) npts 2))) (array-index-map! (make-shared-array dats (lambda (idx) (list idx 0)) npts) - (lambda (idx) (+ vlo (* (- vhi vlo) (/ idx 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! charplot:plot!) + (charplot:plot dats "" ""))) +;@ +(define (plot . args) + (if (procedure? (car args)) + (apply charplot:plot-function args) + (apply charplot:plot args))) diff --git a/chez.init b/chez.init index 44acba8..19d796e 100644 --- a/chez.init +++ b/chez.init @@ -8,36 +8,30 @@ ;;; (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.cs.indiana.edu/chezscheme/") + "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 (lambda () "/usr/unsup/scheme/chez/")) ;;; (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 @@ -55,14 +49,18 @@ ;;; (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-path (getenv "HOME"))) - (lambda () home-path))) +(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))))) ;;; *FEATURES* should be set to a list of symbols describing features ;;; of this implementation. Suggestions for features are: - (define *features* '( source ;can load scheme source files @@ -72,7 +70,7 @@ ;; Scheme report features - rev5-report ;conforms to + r5rs ;conforms to eval ;R5RS two-argument eval values ;R5RS multiple values dynamic-wind ;R5RS dynamic-wind @@ -86,11 +84,11 @@ ;STRING-FILL!, LIST->VECTOR, ;VECTOR->LIST, and VECTOR-FILL! - rev4-report ;conforms to + r4rs ;conforms to ieee-p1178 ;conforms to - rev3-report ;conforms to + r3rs ;conforms to ; rev2-procedures ;SUBSTRING-MOVE-LEFT!, ;SUBSTRING-MOVE-RIGHT!, @@ -101,7 +99,7 @@ multiarg/and- ;/ and - can take more than 2 args. with-file ;has WITH-INPUT-FROM-FILE and - ;WITH-OUTPUT-FROM-FILE + ;WITH-OUTPUT-TO-FILE transcript ;TRANSCRIPT-ON and TRANSCRIPT-OFF ; ieee-floating-point ;conforms to IEEE Standard 754-1985 ;IEEE Standard for Binary @@ -132,13 +130,12 @@ ;; Implementation Specific features +;;; random ;Not the same as SLIB random fluid-let - random )) ;;; (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"))) @@ -154,7 +151,6 @@ ;;; (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"))) @@ -189,6 +185,37 @@ ;; 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))) @@ -218,7 +245,7 @@ (let ((cep (current-error-port))) (if (provided? 'trace) (print-call-stack cep)) (display "Error: " cep) - (for-each (lambda (x) (display x cep)) args) + (for-each (lambda (x) (display #\ cep) (write x cep)) args) (error #f "")))) ;;; define these as appropriate for your system. @@ -269,17 +296,14 @@ ;;; (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) ;;; The following make procedures in Chez Scheme compatible with @@ -309,7 +333,6 @@ ;;; Chez's (FORMAT F . A) corresponds to SLIB's (FORMAT #F F . A) ;;; See the FORMAT feature. - (define chez:format format) (define format @@ -325,7 +348,6 @@ ;;; 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))) @@ -397,10 +419,9 @@ (let ((cep (current-error-port))) (if (provided? 'trace) (print-call-stack cep)) (display "Warn: " cep) - (for-each (lambda (x) (display x cep)) args)))) + (for-each (lambda (x) (display #\ cep) (write x cep)) args)))) ;;; Load the REQUIRE package. - (slib:load (in-vicinity (library-vicinity) "require")) ;; end of chez.init diff --git a/cie1931.xyz b/cie1931.xyz new file mode 100644 index 0000000..ce74214 --- /dev/null +++ b/cie1931.xyz @@ -0,0 +1,82 @@ +;;; "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 diff --git a/cie1964.xyz b/cie1964.xyz new file mode 100644 index 0000000..89fa244 --- /dev/null +++ b/cie1964.xyz @@ -0,0 +1,82 @@ +;;; "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 diff --git a/cltime.scm b/cltime.scm index d22922c..76d06d2 100644 --- a/cltime.scm +++ b/cltime.scm @@ -8,7 +8,7 @@ ;1. Any copy made of this software must include this copyright notice ;in full. ; -;2. I have made no warrantee or representation that the operation of +;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. ; @@ -22,13 +22,13 @@ (require 'posix-time) (define time:1900 (time:invert 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) @@ -48,7 +48,7 @@ (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 (if (null? tzarg) (tzset) diff --git a/coerce.scm b/coerce.scm index 83023df..7505f3f 100644 --- a/coerce.scm +++ b/coerce.scm @@ -8,7 +8,7 @@ ;1. Any copy made of this software must include this copyright notice ;in full. ; -;2. I have made no warrantee or representation that the operation of +;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. ; diff --git a/collect.scm b/collect.scm index 35a333d..05bc2cf 100644 --- a/collect.scm +++ b/collect.scm @@ -2,49 +2,55 @@ ; COPYRIGHT (c) Kenneth Dickey 1992 ; ; This software may be used for any purpose whatever -; without warrantee of any kind. +; 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-operation (collect:collection? obj) +(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 (collect:empty? collection) (zero? (yasos:size collection))) - -(define-operation (collect:gen-elts ) ;; return element generator +;@ +(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 "Operation not supported: GEN-ELTS " (yasos:print obj #f))) + (slib:error 'gen-elts 'operation-not-supported + (collect:print #f))) ) ) - -(define-operation (collect:gen-keys collection) +;@ +(define-operation (gen-keys collection) (if (or (vector? collection) (list? collection) (string? collection)) - (let ( (max+1 (yasos:size collection)) (index 0) ) + (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")) + (else (slib:error 'no-more 'keys 'in 'generator)) ) ) ) - (slib:error "Operation not handled: GEN-KEYS " collection) + (slib:error 'gen-keys 'operation-not-handled collection) ) ) - -(define (collect:do-elts . ) - (let ( (max+1 (yasos:size (car ))) +;@ +(define (do-elts . ) + (let ( (max+1 (collect:size (car ))) (generators (map collect:gen-elts )) ) (let loop ( (counter 0) ) @@ -56,9 +62,9 @@ (else 'unspecific) ; done ) ) ) ) - -(define (collect:do-keys . ) - (let ( (max+1 (yasos:size (car ))) +;@ +(define (do-keys . ) + (let ( (max+1 (collect:size (car ))) (generators (map collect:gen-keys )) ) (let loop ( (counter 0) ) @@ -70,11 +76,11 @@ (else 'unspecific) ; done ) ) ) ) - -(define (collect:map-elts . ) - (let ( (max+1 (yasos:size (car ))) +;@ +(define (map-elts . ) + (let ( (max+1 (collect:size (car ))) (generators (map collect:gen-elts )) - (vec (make-vector (yasos:size (car )))) + (vec (make-vector (collect:size (car )))) ) (let loop ( (index 0) ) (cond @@ -85,11 +91,11 @@ (else vec) ; done ) ) ) ) - -(define (collect:map-keys . ) - (let ( (max+1 (yasos:size (car ))) +;@ +(define (map-keys . ) + (let ( (max+1 (collect:size (car ))) (generators (map collect:gen-keys )) - (vec (make-vector (yasos:size (car )))) + (vec (make-vector (collect:size (car )))) ) (let loop ( (index 0) ) (cond @@ -100,18 +106,18 @@ (else vec) ; done ) ) ) ) - -(define-operation (collect:for-each-key ) +;@ +(define-operation (for-each-key ) ;; default (collect:do-keys ) ;; talk about lazy! ) - -(define-operation (collect:for-each-elt ) +;@ +(define-operation (for-each-elt ) (collect:do-elts ) ) - -(define (collect:reduce . ) - (let ( (max+1 (yasos:size (car ))) +;@ +(define (reduce . ) + (let ( (max+1 (collect:size (car ))) (generators (map collect:gen-elts )) ) (let loop ( (count 0) ) @@ -127,9 +133,9 @@ -;; pred true for every elt? -(define (collect:every? . ) - (let ( (max+1 (yasos:size (car ))) +;;@ pred true for every elt? +(define (every? . ) + (let ( (max+1 (collect:size (car ))) (generators (map collect:gen-elts )) ) (let loop ( (count 0) ) @@ -143,9 +149,9 @@ ) ) ) ) -;; pred true for any elt? -(define (collect:any? . ) - (let ( (max+1 (yasos:size (car ))) +;;@ pred true for any elt? +(define (any? . ) + (let ( (max+1 (collect:size (car ))) (generators (map collect:gen-elts )) ) (let loop ( (count 0) ) @@ -191,7 +197,7 @@ (define (collect:list-gen-elts ) (lambda () (if (null? ) - (slib:error "No more list elements in generator") + (slib:error 'no-more 'list-elements 'in 'generator) (let ( (elt (car )) ) (set! (cdr )) elt)) @@ -200,7 +206,7 @@ ;; generator for vector elements (define (collect:make-vec-gen-elts ) (lambda (vec) - (let ( (max+1 (yasos:size vec)) + (let ( (max+1 (collect:size vec)) (index 0) ) (lambda () @@ -219,18 +225,9 @@ ;;; exports: -(define collection? collect:collection?) -(define empty? collect:empty?) -(define gen-keys collect:gen-keys) -(define gen-elts collect:gen-elts) -(define do-elts collect:do-elts) -(define do-keys collect:do-keys) -(define map-elts collect:map-elts) -(define map-keys collect:map-keys) -(define for-each-key collect:for-each-key) -(define for-each-elt collect:for-each-elt) -(define reduce collect:reduce) ; reduce is also in comlist.scm -(define every? collect:every?) -(define any? collect:any?) +(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" --- ;; diff --git a/collectx.scm b/collectx.scm new file mode 100644 index 0000000..7ba46b9 --- /dev/null +++ b/collectx.scm @@ -0,0 +1,247 @@ +;"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) + (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) + (set! !1 + (apply !1 + !1 + (map (lambda (g!5) (g!5)) generators!2))) + (loop!4 (collect:add1 count!3))) + (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" --- ;; diff --git a/color.scm b/color.scm new file mode 100644 index 0000000..7f80fe5 --- /dev/null +++ b/color.scm @@ -0,0 +1,674 @@ +;;; "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 convolve with a spectrum of +;;interest. The result of those convolutions 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 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 and 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 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) + (case space + ((CIEXYZ) (CIEXYZ->color args)) + ((RGB709) (RGB709->color args)) + ((L*a*b*) (L*a*b*->color args)) + ((L*u*v*) (L*u*v*->color args)) + ((L*C*h) (L*C*h->color args)) + ((sRGB) (sRGB->color args)) + ((xRGB) (apply xRGB->color args)) + ((e-sRGB) (e-sRGB->color args)) + (else (slib:error 'make-color ': 'not 'space? space)))) +;@ +(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? 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) diff --git a/color.txi b/color.txi new file mode 100644 index 0000000..ccbb3de --- /dev/null +++ b/color.txi @@ -0,0 +1,345 @@ +@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 convolve with a spectrum of +interest. The result of those convolutions 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 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 and 1. '(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 + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/colornam.scm b/colornam.scm new file mode 100644 index 0000000..e8e8812 --- /dev/null +++ b/colornam.scm @@ -0,0 +1,117 @@ +;;; "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)))))) diff --git a/colornam.txi b/colornam.txi new file mode 100644 index 0000000..f72167b --- /dev/null +++ b/colornam.txi @@ -0,0 +1,75 @@ +@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 diff --git a/colorspc.scm b/colorspc.scm new file mode 100644 index 0000000..3a88767 --- /dev/null +++ b/colorspc.scm @@ -0,0 +1,536 @@ +;;; "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° 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)))) +;@ +(define (XYZ:normalize-colors lst) + (define sum (apply max (map (lambda (XYZ) (apply + XYZ)) lst))) + (map (lambda (XYZ) (map (lambda (x) (/ x sum)) XYZ)) lst)) +;@ +(define (XYZ:normalize XYZ) + (car (XYZ:normalize-colors (list XYZ)))) + +;;; 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 (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->CIEXYZ wl) + (XYZ:normalize (wavelength->XYZ 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->CIEXYZ . args) + (XYZ:normalize (apply spectrum->XYZ 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) + (spectrum->XYZ (blackbody-spectrum temp 5.e-9))) +(define (temperature->CIEXYZ temp) + (XYZ:normalize (temperature->XYZ temp))) +(define (temperature->chromaticity temp) + (XYZ->chromaticity (temperature->XYZ temp))) diff --git a/comlist.scm b/comlist.scm index 008a2b0..2e3a6ef 100644 --- a/comlist.scm +++ b/comlist.scm @@ -1,5 +1,5 @@ ;;"comlist.scm" Implementation of COMMON LISP list functions for Scheme -; Copyright (C) 1991, 1993, 1995, 2001 Aubrey Jaffer. +; 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, @@ -9,7 +9,7 @@ ;1. Any copy made of this software must include this copyright notice ;in full. ; -;2. I have made no warrantee or representation that the operation of +;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. ; @@ -27,25 +27,32 @@ ;;; Colin Walters ;;; AGJ restored order July 2001. -;;;From: hugh@ear.mit.edu (Hugh Secker-Walker) -(define (comlist:make-list k . init) +;;;@ From: hugh@ear.mit.edu (Hugh Secker-Walker) +(define (make-list k . init) (set! init (if (pair? init) (car init))) (do ((k k (+ -1 k)) (result '() (cons init result))) ((<= k 0) result))) - -(define (comlist:copy-list lst) (append lst '())) - -(define (comlist:adjoin obj lst) (if (memv obj lst) lst (cons obj lst))) - -(define (comlist:union lst1 lst2) - (define ans (if (null? lst1) lst2 lst1)) - (cond ((null? lst2) lst1) - (else (for-each (lambda (elt) (set! ans (comlist:adjoin elt ans))) - lst2) - ans))) - -(define (comlist:intersection lst1 lst2) +;@ +(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) @@ -55,8 +62,8 @@ (build-intersection (cdr lst1) (cons (car lst1) result))) (else (build-intersection (cdr lst1) result)))))) - -(define (comlist:set-difference lst1 lst2) +;@ +(define (set-difference lst1 lst2) (if (null? lst2) lst1 (let build-difference ((lst1 lst1) @@ -64,25 +71,32 @@ (cond ((null? lst1) (reverse result)) ((memv (car lst1) lst2) (build-difference (cdr lst1) result)) (else (build-difference (cdr lst1) (cons (car lst1) result))))))) - -(define (comlist:position obj lst) - (letrec ((pos (lambda (n lst) - (cond ((null? lst) #f) - ((eqv? obj (car lst)) n) - (else (pos (+ 1 n) (cdr lst))))))) - (pos 0 lst))) - -(define (comlist:reduce-init pred? init lst) +;@ +(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 (comlist:reduce pred? lst) +;@ +(define (reduce pred? lst) (cond ((null? lst) lst) ((null? (cdr lst)) (car lst)) (else (comlist:reduce-init pred? (car lst) (cdr lst))))) - -(define (comlist:some pred lst . rest) +;@ +(define (some pred lst . rest) (cond ((null? rest) (let mapf ((lst lst)) (and (not (null? lst)) @@ -91,8 +105,8 @@ (and (not (null? lst)) (or (apply pred (car lst) (map car rest)) (mapf (cdr lst) (map cdr rest)))))))) - -(define (comlist:every pred lst . rest) +;@ +(define (every pred lst . rest) (cond ((null? rest) (let mapf ((lst lst)) (or (null? lst) @@ -101,18 +115,18 @@ (or (null? lst) (and (apply pred (car lst) (map car rest)) (mapf (cdr lst) (map cdr rest)))))))) - -(define (comlist:notany pred . ls) (not (apply comlist:some pred ls))) - -(define (comlist:notevery pred . ls) (not (apply comlist:every pred ls))) - -(define (comlist:list-of?? predicate . bound) +;@ +(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) - (every predicate obj)))) + (comlist:every predicate obj)))) ((1) (set! bound (car bound)) (cond ((negative? bound) @@ -120,12 +134,12 @@ (lambda (obj) (and (list? obj) (<= bound (length obj)) - (every predicate obj)))) + (comlist:every predicate obj)))) (else (lambda (obj) (and (list? obj) (<= (length obj) bound) - (every predicate obj)))))) + (comlist:every predicate obj)))))) ((2) (let ((low (car bound)) (high (cadr bound))) @@ -136,45 +150,45 @@ (lambda (obj) (and (list? obj) (<= low (length obj) high) - (every predicate obj))))) + (comlist:every predicate obj))))) (else (errout)))) - -(define (comlist:find-if pred? lst) +;@ +(define (find-if pred? lst) (cond ((null? lst) #f) ((pred? (car lst)) (car lst)) (else (comlist:find-if pred? (cdr lst))))) - -(define (comlist:member-if pred? lst) +;@ +(define (member-if pred? lst) (cond ((null? lst) #f) ((pred? (car lst)) lst) (else (comlist:member-if pred? (cdr lst))))) - -(define (comlist:remove pred? lst) +;@ +(define (remove obj lst) (define head (list '*head*)) (let remove ((lst lst) (tail head)) (cond ((null? lst)) - ((eqv? pred? (car lst)) (remove (cdr lst) tail)) + ((eqv? obj (car lst)) (remove (cdr lst) tail)) (else (set-cdr! tail (list (car lst))) (remove (cdr lst) (cdr tail))))) (cdr head)) - -(define (comlist:remove-if pred? lst) +;@ +(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 (comlist:remove-if-not pred? lst) +;@ +(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 comlist:nconc +;@ +(define nconc (if (provided? 'rev2-procedures) append! (lambda args (cond ((null? args) '()) @@ -185,8 +199,8 @@ (apply comlist:nconc (cdr args))) (car args)))))) -;;;From: hugh@ear.mit.edu (Hugh Secker-Walker) -(define (comlist:nreverse rev-it) +;;;@ 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)) @@ -195,100 +209,85 @@ (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 (comlist:last lst n) +;@ +(define (last lst n) (comlist:nthcdr (- (length lst) n) lst)) - -(define (comlist:butlast lst n) - (letrec - ((len (- (length lst) n)) - (bl (lambda (lst n) - (let build-until-zero ((lst lst) - (n n) - (result '())) - (cond ((null? lst) (reverse result)) - ((positive? n) - (build-until-zero - (cdr lst) (- n 1) (cons (car lst) result))) - (else (reverse result))))))) - (bl lst (if (negative? n) - (slib:error "negative argument to butlast" n) - len)))) - -(define (comlist:nthcdr 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 (comlist:butnthcdr n lst) - (letrec - ((bl (lambda (lst n) - (let build-until-zero ((lst lst) - (n n) - (result '())) - (cond ((null? lst) (reverse result)) - ((positive? n) - (build-until-zero - (cdr lst) (- n 1) (cons (car lst) result))) - (else (reverse result))))))) - (bl lst (if (negative? n) - (slib:error "negative argument to butnthcdr" n) - n)))) +;@ +(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 (comlist:and? . args) +;@ +(define (and? . args) (cond ((null? args) #t) ((car args) (apply comlist:and? (cdr args))) (else #f))) - -(define (comlist:or? . args) +;@ +(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 (comlist:has-duplicates? lst) +;;;@ 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 (comlist:remove-duplicates 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))))))) - (rem-dup lst '()))) - -(define (comlist:list* obj1 . obj2) - (define (list*1 obj) - (if (null? (cdr obj)) - (car obj) - (cons (car obj) (list*1 (cdr obj))))) - (if (null? obj2) - obj1 - (cons obj1 (list*1 obj2)))) - -(define (comlist:atom? obj) + (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 (comlist:delete obj lst) +;@ +(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 (comlist:delete-if pred 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 (comlist:delete-if-not pred lst) +;@ +(define (delete-if-not pred lst) (let delete-if ((lst lst)) (cond ((null? lst) '()) ((not (pred (car lst))) (delete-if (cdr lst))) @@ -296,42 +295,42 @@ (set-cdr! lst (delete-if (cdr lst))) lst)))) -;;; exports - -(define make-list comlist:make-list) -(define copy-list comlist:copy-list) -(define adjoin comlist:adjoin) -(define union comlist:union) -(define intersection comlist:intersection) -(define set-difference comlist:set-difference) -(define position comlist:position) -(define reduce-init comlist:reduce-init) -(define reduce comlist:reduce) ; reduce is also in collect.scm -(define some comlist:some) -(define every comlist:every) -(define notevery comlist:notevery) -(define notany comlist:notany) -(define find-if comlist:find-if) -(define member-if comlist:member-if) -(define remove comlist:remove) -(define remove-if comlist:remove-if) -(define remove-if-not comlist:remove-if-not) -(define nconc comlist:nconc) -(define nreverse comlist:nreverse) -(define last comlist:last) -(define butlast comlist:butlast) -(define nthcdr comlist:nthcdr) -(define butnthcdr comlist:butnthcdr) -(define and? comlist:and?) -(define or? comlist:or?) -(define has-duplicates? comlist:has-duplicates?) -(define remove-duplicates comlist:remove-duplicates) - -(define delete-if-not comlist:delete-if-not) -(define delete-if comlist:delete-if) -(define delete comlist:delete) -(define comlist:atom comlist:atom?) -(define atom comlist:atom?) -(define atom? comlist:atom?) -(define list* comlist:list*) -(define list-of?? comlist:list-of??) +;;; 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??) diff --git a/comparse.scm b/comparse.scm index 5a007b6..5dc1a50 100644 --- a/comparse.scm +++ b/comparse.scm @@ -1,5 +1,5 @@ ;;; "comparse.scm" Break command line into arguments. -;Copyright (C) 1995, 1997 Aubrey Jaffer +;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 @@ -8,7 +8,7 @@ ;1. Any copy made of this software must include this copyright notice ;in full. ; -;2. I have made no warrantee or representation that the operation of +;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. ; @@ -24,6 +24,10 @@ ;;; 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 "") @@ -86,6 +90,64 @@ (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)) @@ -94,6 +156,16 @@ "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)))) diff --git a/comparse.txi b/comparse.txi new file mode 100644 index 0000000..3ebe785 --- /dev/null +++ b/comparse.txi @@ -0,0 +1,81 @@ +@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 diff --git a/crc.scm b/crc.scm new file mode 100644 index 0000000..423622b --- /dev/null +++ b/crc.scm @@ -0,0 +1,137 @@ +;;;; "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))))))) diff --git a/cring.scm b/cring.scm index dfbb027..97a637d 100644 --- a/cring.scm +++ b/cring.scm @@ -1,5 +1,5 @@ ;;;"cring.scm" Extend Scheme numerics to any commutative ring. -;Copyright (C) 1997, 1998 Aubrey Jaffer +;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 @@ -8,7 +8,7 @@ ;1. Any copy made of this software must include this copyright notice ;in full. ; -;2. I have made no warrantee or representation that the operation of +;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. ; @@ -19,10 +19,21 @@ (require 'common-list-functions) (require 'relational-database) -(require 'database-utilities) +(require 'databases) (require 'sort) +(require-if '(not inexact) 'logical) ;for integer-expt +(define number^ (if (provided? 'inexact) expt integer-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))) @@ -41,12 +52,13 @@ (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)) @@ -59,6 +71,7 @@ rulesets)))) ;;; Distribute * over + (and -) +;@ (define distribute* (make-ruleset 'distribute* @@ -72,6 +85,7 @@ (apply - (map (lambda (trm) (* trm exp2)) (cdr exp1))))))) ;;; Distribute / over + (and -) +;@ (define distribute/ (make-ruleset 'distribute/ @@ -103,15 +117,7 @@ (else (expression-< (cdr x) (cdr y))))) (define (expression-sort seq) (sort! seq expression-<)) -(define number* *) -(define number+ +) -(define number- -) -(define number/ /) -(define number^ integer-expt) (define is-term-op? (lambda (term op) (and (pair? term) (eq? op (car term))))) -;;(define (sign x) (if (positive? x) 1 (if (negative? x) -1 0))) -(define number0? zero?) -(define (zero? x) (and (number? x) (number0? x))) ;; To convert to CR internal form, NUMBER-op all the `numbers' in the ;; argument list and remove them from the argument list. Collect the diff --git a/cvs.scm b/cvs.scm new file mode 100644 index 0000000..f1c853c --- /dev/null +++ b/cvs.scm @@ -0,0 +1,140 @@ +;;;;"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 and all its subdirectories. +(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 +;;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")) diff --git a/cvs.txi b/cvs.txi new file mode 100644 index 0000000..0ff1656 --- /dev/null +++ b/cvs.txi @@ -0,0 +1,32 @@ + +@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/} and all its 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 diff --git a/daylight.scm b/daylight.scm new file mode 100644 index 0000000..6c989b2 --- /dev/null +++ b/daylight.scm @@ -0,0 +1,356 @@ +;;; "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 Returns (unnormalized) XYZ values for color of sunlight for a +;;given @1 and @2. +(define (sunlight-XYZ turbidity theta_s) + (define spectrum (sunlight-spectrum turbidity theta_s)) + (and spectrum (spectrum->XYZ spectrum 380.e-9 780.e-9))) + +;;@body Given @1 and @2, @0 returns the CIEXYZ triple for color of +;;sunlight scaled to be just inside the RGB709 gamut. +(define (sunlight-CIEXYZ turbidity theta_s) + (define spectrum (sunlight-spectrum turbidity theta_s)) + (and spectrum (spectrum->CIEXYZ 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))) diff --git a/daylight.txi b/daylight.txi new file mode 100644 index 0000000..fa24afc --- /dev/null +++ b/daylight.txi @@ -0,0 +1,117 @@ +@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-xyz turbidity theta_s +Returns (unnormalized) XYZ values for color of sunlight for a +given @var{turbidity} and @var{theta_s}. +@end defun + +@defun sunlight-ciexyz turbidity theta_s +Given @var{turbidity} and @var{theta_s}, @code{sunlight-ciexyz} 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 diff --git a/db2html.scm b/db2html.scm index 3462966..df34389 100644 --- a/db2html.scm +++ b/db2html.scm @@ -8,7 +8,7 @@ ;1. Any copy made of this software must include this copyright notice ;in full. ; -;2. I have made no warrantee or representation that the operation of +;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. ; @@ -18,11 +18,20 @@ ;each case. (require 'uri) +(require 'printf) (require 'html-form) -(require 'net-clients) +(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) @@ -224,11 +233,11 @@ ;;@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 which indicate that the row -;;is to be deleted. Optional arguments @3, @4, and @5 default to the -;;@code{row:update}, @code{row:delete}, and @code{row:retrieve} of @1 in -;;@var{db}. +;;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) @@ -251,7 +260,7 @@ (table:update new-row) ((rdb 'sync-database)) #t) (else '("Row changed by other user")))) - ((equal? null-keys new-pkeys) ;blanked keys + ((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 )) @@ -268,6 +277,26 @@ (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. @@ -286,6 +315,7 @@ ;;@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)) @@ -313,7 +343,8 @@ (define foreign-choice-lists (map (lambda (domain-name) (define tab-name (ftn domain-name)) - (if tab-name (get-foreign-choices (rdb-open tab-name #f)) '())) + (if tab-name (get-foreign-choices + ((rdb 'open-table) tab-name #f)) '())) domains)) (define-tables rdb `(,(symbol-append table-name '- 'params) @@ -323,7 +354,7 @@ ,@field-specs)) `(,(symbol-append table-name '- 'pname) ((name string)) - ((parameter-index uint)) ;should be address-params + ((parameter-index ordinal)) ;should be address-params (("*keys*" 1) ("*row-hash*" 2) ,@(map (lambda (idx column) (list (symbol->string column) idx)) @@ -335,7 +366,10 @@ ,(symbol-append table-name '- 'pname) (command:modify-table ',table-name ',(map (lambda (fs) - (caadr (caddar (cddddr 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)))))) @@ -424,16 +458,17 @@ ;;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) - (call-with-output-file (in-vicinity (if dir (sub-vicinity "" dir) "") - index-filename) + (set! dir (if dir (sub-vicinity "" dir) "")) + (call-with-output-file (in-vicinity dir index-filename) (lambda (port) (display (catalog->page db caption) port))) - ((((db 'open-table) '*catalog-data* #f) 'for-each-row) - (lambda (row) - (call-with-output-file - (in-vicinity (sub-vicinity "" dir) (table-name->filename (car row))) - (lambda (port) - (display (table->linked-page db (car row) index-filename) 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 @@ -457,7 +492,7 @@ ;;@args db dir index-filename ;;@args db dir ;;@0 is just like @code{db->html-directory}, but calls -;;@code{browse-url-netscape} with the uri for the top page after the +;;@code{browse-url} with the uri for the top page after the ;;pages are created. (define (db->netscape . args) - (browse-url-netscape (apply db->html-directory args))) + (browse-url (apply db->html-directory args))) diff --git a/db2html.txi b/db2html.txi index 0acdd46..3b47f31 100644 --- a/db2html.txi +++ b/db2html.txi @@ -1,4 +1,5 @@ @code{(require 'db->html)} +@ftindex db->html @defun html:table options row @dots{} @@ -104,12 +105,12 @@ database is performed. @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 which indicate that the row +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 -is to be deleted. 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}. +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{} @@ -180,6 +181,6 @@ returned. @defunx db->netscape db dir @code{db->netscape} is just like @code{db->html-directory}, but calls -@code{browse-url-netscape} with the uri for the top page after the +@code{browse-url} with the uri for the top page after the pages are created. @end defun diff --git a/dbcom.scm b/dbcom.scm new file mode 100644 index 0000000..428e3db --- /dev/null +++ b/dbcom.scm @@ -0,0 +1,215 @@ +;;; "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))))) diff --git a/dbinterp.scm b/dbinterp.scm new file mode 100644 index 0000000..8ccb1df --- /dev/null +++ b/dbinterp.scm @@ -0,0 +1,34 @@ +;;; "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. + +;;@ 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)) + (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)))))))) diff --git a/dbrowse.scm b/dbrowse.scm index e186492..9401c6d 100644 --- a/dbrowse.scm +++ b/dbrowse.scm @@ -8,7 +8,7 @@ ;1. Any copy made of this software must include this copyright notice ;in full. ; -;2. I have made no warrantee or representation that the operation of +;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. ; @@ -17,11 +17,11 @@ ;promotional, or sales literature without prior written consent in ;each case. -(require 'database-utilities) +(require 'databases) (require 'printf) (define browse:db #f) - +;@ (define (browse . args) (define table-name #f) (cond ((null? args)) @@ -48,8 +48,8 @@ (define (browse:display-dir table-name table) (printf "%s Tables:\\n" table-name) - ((table 'for-each-row) - (lambda (row) (printf "\\t%s\\n" (car row))))) + ((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) @@ -73,7 +73,7 @@ (newline) (for-each (lambda (type) (case type - ((integer number uint base-id) + ((integer number ordinal base-id uint) (set! form (string-append form dw-integer))) ((boolean domain expression atom) (set! form (string-append form dwp-any))) @@ -87,6 +87,6 @@ (for-each (lambda (domain) (printf underline)) (table 'column-domains)) (newline) - ((table 'for-each-row) + ((or (table 'for-each-row-in-order) (table 'for-each-row)) (lambda (row) (apply printf form row))))) diff --git a/dbsyn.scm b/dbsyn.scm new file mode 100644 index 0000000..1bc1319 --- /dev/null +++ b/dbsyn.scm @@ -0,0 +1,54 @@ +;;;; "dbsyn.scm" -- Syntactic extensions for RDMS (within-database) +;;; Copyright (C) 2002 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. + +(require 'relational-database) +(require 'database-commands) +(require 'databases) +;@ +(define-syntax within-database + (syntax-rules (define-table define-command) + + ((within-database database) + database) + + ((within-database database + (define-table (name primary columns) row ...) + rest ...) + (begin (define-tables database '(name primary columns (row ...))) + (within-database database rest ...))) + + ((within-database database + (define-command template arg-1 arg-2 ...) + rest ...) + (begin (define-*commands* database '(template arg-1 arg-2 ...)) + (within-database database rest ...))))) diff --git a/dbutil.scm b/dbutil.scm index 248ec1d..5e5c86d 100644 --- a/dbutil.scm +++ b/dbutil.scm @@ -1,5 +1,5 @@ ;;; "dbutil.scm" relational-database-utilities -; Copyright 1994, 1995, 1997, 2000, 2001 Aubrey Jaffer +; 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 @@ -8,7 +8,7 @@ ;1. Any copy made of this software must include this copyright notice ;in full. ; -;2. I have made no warrantee or representation that the operation of +;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. ; @@ -17,226 +17,418 @@ ;promotional, or sales literature without prior written consent in ;each case. +(require 'common-list-functions) ;for nthcdr and butnthcdr (require 'relational-database) -(require 'common-list-functions) - -(define (db:base-type path) - 'alist-table) ; currently the only one. - -(define (dbutil:wrap-command-interface rdb) - (and 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))) - (cond (com ((slib:eval com) wdb)) - (else (rdb command))))))) - (let ((init (wdb '*initialize*))) - (if (procedure? init) init wdb))))))) - -(define (dbutil:open-database! path . arg) - (let ((type (if (null? arg) (db:base-type path) (car arg)))) - (require type) - (dbutil:wrap-command-interface - (((make-relational-system (slib:eval type)) 'open-database) - path #t)))) - -(define (dbutil:open-database path . arg) - (let ((type (if (null? arg) (db:base-type path) (car arg)))) - (require type) - (dbutil:wrap-command-interface - (((make-relational-system (slib:eval type)) 'open-database) - path #f)))) - -(define (dbutil: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 (dbutil:create-database path type) +(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*))) + ((memq 'alist-table *base-table-implementations*) #f) + ((let () + (require 'alist-table) + (loop (list (car *base-table-implementations*))))) + (else #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?)))) + (and ndb (list ndb 1 type certificate)))))) + +;;@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 ((rdb (((make-relational-system (slib:eval type)) 'create-database) - path))) - (dbutil: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))) - (dbutil:define-tables - rdb - '(*parameter-columns* - *columns* - *columns* - ((1 #t index #f uint) - (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 uint)) - ()) - '(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 uint)) ;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 uint)) ;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 - dbutil: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))) - (set-car! (cdr row) 'type) - ((tab 'row:update) row)) - (dbutil:wrap-command-interface rdb))) - -(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))))) - -(define (get-foreign-choices tab) - (define dlst ((tab 'get* 1))) - (do ((dlst dlst (cdr dlst)) - (vlst (if (memq 'visible-name (tab 'column-names)) - ((tab 'get* 'visible-name)) - dlst) - (cdr vlst)) - (out '() (if (member (car dlst) (cdr dlst)) - out - (cons (list (car dlst) (car vlst)) out)))) - ((null? dlst) out))) - -(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 (rdb 'domain-checker) 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))))) - -(define (dbutil:define-tables rdb . spec-list) + (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 (or (and entry (cadddr entry)) + (and (rdb 'filename) + (file-lock! (rdb 'filename)))))) + (cond ((and entry (not (eqv? 1 (cadr entry)))) + (set-car! (cdr entry) (+ -1 (cadr entry))) + #f) + ((or (not certificate) (not (procedure? rdb))) + #f) + (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)) @@ -245,26 +437,25 @@ (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))) + (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)) - (row:update (tab 'row:update))) - (for-each row:update data))) + (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)) - (row:insert (tab 'row:insert))) - (for-each row:insert data) + (let ((tab (create-table name slots))) + ((tab 'row:insert*) data) ((tab 'close-table)))) (else (let* ((descname @@ -289,12 +480,22 @@ slots) ((tab 'close-table)) (set! tab (create-table name descname)) - (set! row:insert (tab 'row:insert)) - (for-each row:insert data) + ((tab 'row:insert*) data) ((tab 'close-table)))))) (for-each (lambda (spec) (apply define-table spec)) spec-list)) -(define (dbutil:list-table-definition rdb table-name) + +;;@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)) @@ -306,9 +507,4 @@ (nthcdr prilimit coldefs) ((table 'row:retrieve*))))) (else #f))) - -(define create-database dbutil:create-database) -(define open-database! dbutil:open-database!) -(define open-database dbutil:open-database) -(define define-tables dbutil:define-tables) -(define list-table-definition dbutil:list-table-definition) +;;(trace-all "/home/jaffer/slib/dbutil.scm") (untrace define-tables) diff --git a/dbutil.txi b/dbutil.txi new file mode 100644 index 0000000..cc198f3 --- /dev/null +++ b/dbutil.txi @@ -0,0 +1,219 @@ +@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 diff --git a/debug.scm b/debug.scm index 0a913b4..73acc0b 100644 --- a/debug.scm +++ b/debug.scm @@ -8,7 +8,7 @@ ;1. Any copy made of this software must include this copyright notice ;in full. ; -;2. I have made no warrantee or representation that the operation of +;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. ; @@ -62,7 +62,7 @@ (let ((sym (get-defined-symbol (cadr form)))) (cond ((procedure? (slib:eval sym)) (proc sym))))))))) - +;@ (define (trace-all file . ...) (for-each (lambda (file) @@ -87,7 +87,7 @@ (lambda (sym) (slib:eval `(set! ,sym (trace:trace-procedure 'stack ,sym ',sym)))))) (cons file ...))) - +;@ (define (break-all file . ...) (for-each (lambda (file) diff --git a/defmacex.scm b/defmacex.scm index 5863c94..71d7b6c 100644 --- a/defmacex.scm +++ b/defmacex.scm @@ -8,7 +8,7 @@ ;1. Any copy made of this software must include this copyright notice ;in full. ; -;2. I have made no warrantee or representation that the operation of +;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. ; @@ -38,7 +38,7 @@ (else (map1 (lambda (e) (iqq e depth)) e))) e)))) (iqq e depth))) - +;@ (define (defmacro:expand* e) (if (pair? e) (let* ((c (macroexpand-1 e))) diff --git a/determ.scm b/determ.scm index 4b53e5f..1078750 100644 --- a/determ.scm +++ b/determ.scm @@ -1,14 +1,147 @@ -;"determ.scm" Determinant +;;; "determ.scm" Matrix Algebra +;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. -(define (determinant m) +(require 'array) + +;;@code{(require 'determinant)} +;;@ftindex determinant + +;;@noindent +;;A Matrix can be either a list of lists (rows) or an array. +;;As with linear-algebra texts, this package uses 1-based coordinates. + +;;; Internal conversion routines +(define (matrix2array matrix prototype) + (let* ((shp (list (list 1 (length matrix)) + (list 1 (length (car matrix))))) + (mat (apply create-array '#() shp))) + (do ((idx 1 (+ 1 idx)) + (rows matrix (cdr rows))) + ((> idx (cadar shp)) rows) + (do ((jdx 1 (+ 1 jdx)) + (row (car rows) (cdr row))) + ((> jdx (cadadr shp))) + (array-set! mat (car row) idx jdx))) + mat)) +(define (matrix2lists matrix) + (let ((shp (array-shape matrix))) + (do ((idx (cadar shp) (+ -1 idx)) + (rows '() + (cons (do ((jdx (cadadr shp) (+ -1 jdx)) + (row '() (cons (array-ref matrix idx jdx) row))) + ((< jdx (caadr shp)) row)) + rows))) + ((< idx (caar shp)) 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 (ones-based) 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 (zero? n) (cdr lst) (cons (car lst) (butnth (+ -1 n) (cdr lst))))) - (define (minor m i j) - (map (lambda (x) (butnth j x)) (butnth i m))) - (define (cofactor m i j) - (* (if (odd? (+ i j)) -1 1) (determinant (minor m i j)))) - (define n (length m)) - (if (eqv? 1 n) (caar m) - (do ((j (+ -1 n) (+ -1 j)) - (ans 0 (+ ans (* (list-ref (car m) j) (cofactor m 0 j))))) - ((negative? j) ans)))) + (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 product of matrices @1 and @2. +(define (matrix:product m1 m2) + (define mat1 (matrix->lists m1)) + (define 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 singlar, 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)))))) diff --git a/determ.txi b/determ.txi new file mode 100644 index 0000000..30eef3d --- /dev/null +++ b/determ.txi @@ -0,0 +1,47 @@ +@code{(require 'determinant)} +@ftindex determinant + +@noindent +A Matrix can be either a list of lists (rows) or an array. +As with linear-algebra texts, this package uses 1-based coordinates. + + +@defun matrix->lists matrix + +Returns the list-of-lists form of @var{matrix}. +@end defun + +@defun matrix->array matrix + +Returns the (ones-based) 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:product m1 m2 + +Returns the product of matrices @var{m1} and @var{m2}. +@end defun + +@defun matrix:inverse matrix + +@var{matrix} must be a square matrix. +If @var{matrix} is singlar, then @code{matrix:inverse} returns #f; otherwise @code{matrix:inverse} returns the +@code{matrix:product} inverse of @var{matrix}. +@end defun diff --git a/differ.scm b/differ.scm index 53e0eaf..23b0e91 100644 --- a/differ.scm +++ b/differ.scm @@ -1,5 +1,5 @@ ;;;; "differ.scm" O(NP) Sequence Comparison Algorithm. -;;; Copyright (C) 2001 Aubrey Jaffer +;;; Copyright (C) 2001, 2002, 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 @@ -8,7 +8,7 @@ ;1. Any copy made of this software must include this copyright notice ;in full. ; -;2. I have made no warrantee or representation that the operation of +;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. ; @@ -18,7 +18,7 @@ ;each case. ;;@noindent -;;This package implements the algorithm: +;;@code{diff:edit-length} implements the algorithm: ;; ;;@ifinfo ;;@example @@ -37,186 +37,403 @@ ;;@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. -;; -;;@noindent ;;The values returned by @code{diff:edit-length} can be used to gauge ;;the degree of match between two sequences. ;; ;;@noindent -;;I believe that this algorithm is currently the fastest for these -;;tasks, but genome sequencing applications fuel extensive research in -;;this area. +;;Surprisingly, "An O(NP) Sequence Comparison Algorithm" does not +;;derive the edit sequence; only the sequence length. Developing this +;;linear-space sub-quadratic-time algorithm for computing the edit +;;sequence required hundreds of hours of work. I have submitted a +;;paper describing the algorithm to the Journal of Computational +;;Biology. +;; +;;@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) +(require 'sort) -(define (fp:compare fp Delta snake len2) +;;; 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 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 (+ -1 Delta))) - (array-set! fp (snake k (max (+ 1 (array-ref fp (+ -1 k))) - (array-ref fp (+ 1 k)))) - k)) + ((>= k Delta)) + (fp:run fp k A M B N =? CC p)) (do ((k (+ Delta p) (+ -1 k))) - ((< k (+ 1 Delta))) - (array-set! fp (snake k (max (+ 1 (array-ref fp (+ -1 k))) - (array-ref fp (+ 1 k)))) - k)) - (array-set! fp (snake Delta (max (+ 1 (array-ref fp (+ -1 Delta))) - (array-ref fp (+ 1 Delta)))) - Delta) - (if (= (array-ref fp Delta) len2) - (+ Delta (* 2 p)) - (loop (+ 1 p))))) - -(define (fp->edits fp Delta) - (let loop ((idx (+ -1 Delta)) - (ddx (+ 1 Delta)) - (edits '())) - (define ivl (array-ref fp idx)) - (define dvl (array-ref fp ddx)) - (if (not (= -1 dvl)) (set! dvl (- dvl ddx))) - ;;(print idx '-> ivl ddx '-> dvl) - (cond ((= ivl -1) edits) - ((= dvl -1) (loop (+ -1 idx) ddx (cons (list ivl 'insert) edits))) - ((> dvl ivl) (loop idx (+ 1 ddx) (cons (list dvl 'delete) edits))) - (else (loop (+ -1 idx) ddx (cons (list ivl 'insert) edits)))))) - -(define (fp->lcs fp Delta array1 len) - (define len1 (car (array-dimensions array1))) - (define lcs (make-array #f len)) - (define (subarray-copy! array1 start1 end1 array2 start2) - (do ((i start1 (+ i 1)) - (j start2 (+ j 1)) - (l (- end1 start1) (- l 1))) - ((<= l 0)) - (array-set! array2 (array-ref array1 i) j))) - (let loop ((ddx (+ 1 Delta)) - (pos len1) - (dpos len)) - (let* ((dvl (array-ref fp ddx)) - (sublen (- pos (- dvl ddx -1)))) - (cond ((= dvl -1) - (subarray-copy! array1 0 pos lcs 0) - lcs) + ((<= k Delta)) + (fp:run fp k A M B N =? CC p)) + (let ((fpval (fp:run fp 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 k A M B N =? CC p) + (define y (max (+ 1 (array-ref fp (+ -1 k))) (array-ref fp (+ 1 k)))) + (define cost (+ k p p)) + (let snloop ((x (- y k)) + (y y)) + (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) + (=? (array-ref A x) (array-ref B y))) + (snloop (+ 1 x) (+ 1 y))) + (else (array-set! fp y 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 M N RR CC cost) + (define b-splt N) ;Default + (define bestrun 0) + (define thisrun 0) + ;; 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 (- start 1 idx))) n-len) + (make-shared-array RA (lambda (idx) (list (+ start idx))) n-len))) + +(define (fp:init! fp fill mindx maxdx) + (do ((idx maxdx (+ -1 idx))) + ((< idx mindx)) + (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 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 (+ len-a len-b) 0 len-b) + (fp:init! fp -1 (- (+ 1 p-lim)) (+ 1 p-lim (- len-b M1))) + (fp:compare fp 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 (+ len-a len-b) 0 len-b) + (fp:init! fp -1 (- (+ 1 p-lim)) (+ 1 p-lim (- len-b M2))) + (fp:compare fp 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-a len-b RR CC tcst))) + (define est-c (array-ref CC b-splt)) + (define est-r (array-ref RR (- len-b b-splt))) + ;;(set! splts (cons (/ b-splt (max .1 len-b)) splts)) + ;;(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 (+ 7 (* 2 b-splt)) #\-) '^ (list b-splt)) + (check-cost! 'CC est-c + (diff2et fp 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 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 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) + (=? (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) + (=? (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 CCRR B bsx (+ 1 bdx) A asx (+ 1 adx) + edits edx (- epo) =? (+ delta p-lim)) + (diff2ez fp 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 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))) + ((=? (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)) + (edx edx (+ 1 edx))) + ((>= idx end-a) + (do ((jdx start-b (+ 1 jdx)) + (edx edx (+ 1 edx))) + ((>= jdx end-b)) + (array-set! edits (* epo (+ 1 jdx)) edx))) + (array-set! edits (* epo (- -1 idx)) edx)) + (+ len-a len-b)) + (else (diff:divide-and-conquer + fp CCRR A start-a end-a B start-b end-b + edits edx epo =? p-lim)))) + +;;;Return new vector of edits in correct sequence +(define (diff:order-edits edits cost sign) + (if (negative? sign) + (do ((idx (+ -1 cost) (+ -1 idx))) + ((negative? idx)) + (array-set! edits (- (array-ref edits idx)) idx))) + (if (zero? cost) + edits + (let ((sedits (sort! edits <)) + (nedits (create-array (As32) cost))) + ;; Find -/+ boundary + (define len-a (max 0 (- (array-ref sedits 0)))) + (define len-b (array-ref sedits (+ -1 cost))) + (do ((idx 0 (+ 1 idx))) + ((or (>= idx cost) (positive? (array-ref sedits idx))) + (let loop ((ddx (+ -1 idx)) + (idx idx) + (ndx 0) + (adx 0) + (bdx 0)) + (define del (if (negative? ddx) 0 (array-ref sedits ddx))) + (define ins (if (>= idx cost) 0 (array-ref sedits idx))) + (cond ((and (>= bdx len-b) (>= adx len-a)) nedits) + ((and (negative? del) (>= adx (- -1 del)) + (positive? ins) (>= bdx (+ -1 ins))) + (array-set! nedits del ndx) + (array-set! nedits ins (+ 1 ndx)) + (loop (+ -1 ddx) (+ 1 idx) (+ 2 ndx) + (+ 1 adx) (+ 1 bdx))) + ((and (negative? del) (>= adx (- -1 del))) + (array-set! nedits del ndx) + (loop (+ -1 ddx) idx (+ 1 ndx) (+ 1 adx) bdx)) + ((and (positive? ins) (>= bdx (+ -1 ins))) + (array-set! nedits ins ndx) + (loop ddx (+ 1 idx) (+ 1 ndx) adx (+ 1 bdx))) + (else + (loop ddx idx ndx (+ 1 adx) (+ 1 bdx)))))))))) + +;;; len-a < len-b +(define (edits2lcs lcs edits cost A len-a len-b) + (let loop ((edx 0) + (sdx 0) + (adx 0)) + (let ((edit (if (< edx cost) + (array-ref edits edx) + 0))) + (cond ((>= adx len-a) lcs) + ((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 - (subarray-copy! array1 (- dvl ddx -1) pos lcs (- dpos sublen)) - (loop (+ 1 ddx) (- dvl ddx) (- dpos sublen))))))) + (array-set! lcs (array-ref A adx) sdx) + (loop edx (+ 1 sdx) (+ 1 adx))))))) + +;; A not longer than B (M <= N) +(define (diff2edits A M B N =? p-lim) + (define maxdx (if (negative? p-lim) (+ 2 N) (+ 1 p-lim (- N M)))) + (define mindx (if (negative? p-lim) (- (+ 1 M)) (- (+ 1 p-lim)))) + ;;(if (> M N) (slib:error 'diff2edits M '> N)) + (let ((fp (create-array (As32) (list mindx maxdx))) + (CCRR (create-array (As32) (* 2 (+ N 1))))) + (fp:init! fp -1 mindx maxdx) + (let ((est (fp:compare fp #f A M B N =? p-lim))) + (and est + (let ((edits (create-array (As32) est))) + (check-cost! 'diff2edits + est + (diff2et fp CCRR A 0 M B 0 N edits 0 1 =? + (quotient (- est (- N M)) 2))) + edits))))) +;; A not longer than B (M <= N) +(define (diff2editlen A M B N =? p-lim) + (define maxdx (if (negative? p-lim) (+ 1 N) (+ 1 p-lim (- N M)))) + (define mindx (if (negative? p-lim) (- (+ 1 M)) (- (+ 1 p-lim)))) + (let ((fp (create-array (As32) (list mindx maxdx)))) + (fp:init! fp -1 mindx maxdx) + (fp:compare fp #f A M B N =? p-lim))) + +(define (check-cost! name est cost) + (if (not (eqv? est cost)) + (slib:warn "%s: cost check failed %d != %d\\n" name est cost))) + +;;@args array1 array2 =? p-lim ;;@args array1 array2 =? -;;@args array1 array2 ;;@1 and @2 are one-dimensional arrays. The procedure @3 is used -;;to compare sequence tokens for equality. @3 defaults to @code{eqv?}. +;;to compare sequence tokens for equality. +;; +;;The non-negative integer @4, 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) (fp:edit-length @1 @2)) 2)} holding the longest sequence +;;len1 len2) (diff:edit-length @1 @2)) 2)} holding the longest sequence ;;common to both @var{array}s. -(define (diff:longest-common-subsequence array1 array2 . =?) - (define len1 (car (array-dimensions array1))) - (define len2 (car (array-dimensions array2))) - (define (snake k y) - (let snloop ((x (- y k)) - (y y)) - (if (and (< x len1) (< y len2) (=? (array-ref array1 x) - (array-ref array2 y))) - (snloop (+ 1 x) (+ 1 y)) - y))) - (set! =? (if (null? =?) eqv? (car =?))) - (if (> len1 len2) - (diff:longest-common-subsequence array2 array1) - (let ((Delta (- len2 len1)) - (fp (make-array -1 (list (- (+ 1 len1)) (+ 1 len2))))) - (fp->lcs fp Delta array1 - (quotient (- (+ len1 len2) (fp:compare fp Delta snake len2)) - 2))))) +(define (diff:longest-common-subsequence A B =? . p-lim) + (define len-a (car (array-dimensions a))) + (define len-b (car (array-dimensions b))) + (set! p-lim (if (null? p-lim) -1 (car p-lim))) + (let ((edits (if (< len-b len-a) + (diff2edits B len-b A len-a =? p-lim) + (diff2edits A len-a B len-b =? p-lim)))) + (and edits + (let* ((cost (car (array-dimensions edits))) + (sedit (diff:order-edits edits cost (if (< len-b len-a) -1 1))) + (lcs (create-array A (/ (- (+ len-b len-a) cost) 2)))) + (if (< len-b len-a) + (edits2lcs lcs sedit cost B len-b len-a) + (edits2lcs lcs sedit cost A len-a len-b)))))) +;;@args array1 array2 =? p-lim ;;@args array1 array2 =? -;;@args array1 array2 ;;@1 and @2 are one-dimensional arrays. The procedure @3 is used -;;to compare sequence tokens for equality. @3 defaults to @code{eqv?}. -;;@0 returns a list of length @code{(fp:edit-length @1 @2)} composed of -;;a shortest sequence of edits transformaing @1 to @2. +;;to compare sequence tokens for equality. ;; -;;Each edit is a list of an integer and a symbol: +;;The non-negative integer @4, 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{j} insert) -;;Inserts @code{(array-ref @1 @var{j})} into the sequence. -;;@item (@var{k} delete) -;;Deletes @code{(array-ref @2 @var{k})} from the sequence. +;;@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 array1 array2 . =?) - (define len1 (car (array-dimensions array1))) - (define len2 (car (array-dimensions array2))) - (define (snake k y) - (let snloop ((x (- y k)) - (y y)) - (if (and (< x len1) (< y len2) (=? (array-ref array1 x) - (array-ref array2 y))) - (snloop (+ 1 x) (+ 1 y)) y))) - (set! =? (if (null? =?) eqv? (car =?))) - (if (> len1 len2) - (diff:reverse-edits (diff:edits array2 array1)) - (let ((Delta (- len2 len1)) - (fp (make-array -1 (list (- (+ 1 len1)) (+ 1 len2))))) - (fp:compare fp Delta snake len2) - ;;(do ((idx (- -1 len1) (+ 1 idx))) ((>= idx (+ 1 len2)) (newline)) (printf "%3d" idx)) - ;;(do ((idx (- -1 len1) (+ 1 idx))) ((>= idx (+ 1 len2)) (newline)) (printf "%3d" (array-ref fp idx))) - (fp->edits fp Delta)))) - -(define (diff:reverse-edits edits) - (map (lambda (edit) - (list (car edit) - (case (cadr edit) - ((delete) 'insert) - ((insert) 'delete)))) - edits)) +(define (diff:edits A B =? . p-lim) + (define len-a (car (array-dimensions a))) + (define len-b (car (array-dimensions b))) + (set! p-lim (if (null? p-lim) -1 (car p-lim))) + (let ((edits (if (< len-b len-a) + (diff2edits B len-b A len-a =? p-lim) + (diff2edits A len-a B len-b =? p-lim)))) + (and edits (diff:order-edits edits (car (array-dimensions edits)) + (if (< len-b len-a) -1 1))))) +;;@args array1 array2 =? p-lim ;;@args array1 array2 =? -;;@args array1 array2 ;;@1 and @2 are one-dimensional arrays. The procedure @3 is used -;;to compare sequence tokens for equality. @3 defaults to @code{eqv?}. +;;to compare sequence tokens for equality. +;; +;;The non-negative integer @4, 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 array1 array2 . =?) - (define len1 (car (array-dimensions array1))) - (define len2 (car (array-dimensions array2))) - (define (snake k y) - (let snloop ((x (- y k)) - (y y)) - (if (and (< x len1) (< y len2) (=? (array-ref array1 x) - (array-ref array2 y))) - (snloop (+ 1 x) (+ 1 y)) - y))) - (set! =? (if (null? =?) eqv? (car =?))) - (if (> len1 len2) - (diff:edit-length array2 array1) - (let ((Delta (- len2 len1)) - (fp (make-array -1 (list (- (+ 1 len1)) (+ 1 len2))))) - (fp:compare fp Delta snake len2)))) +(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))) + (if (< N M) + (diff2editlen B N A M =? p-lim) + (diff2editlen A M B N =? p-lim))) ;;@example -;;(diff:longest-common-subsequence '#(f g h i e j c k l m) -;; '#(f g e h i j k p q r l m)) -;; @result{} #(f g h i j k l m) +;;(diff:longest-common-subsequence "fghiejcklm" "fgehijkpqrlm" eqv?) +;;@result{} "fghijklm" ;; -;;(diff:edit-length '#(f g h i e j c k l m) -;; '#(f g e h i j k p q r l m)) +;;(diff:edit-length "fghiejcklm" "fgehijkpqrlm" eqv?) ;;@result{} 6 ;; -;;(pretty-print (diff:edits '#(f g h i e j c k l m) -;; '#(f g e h i j k p q r l m))) -;;@print{} -;;((3 insert) ; e -;; (4 delete) ; c -;; (6 delete) ; h -;; (7 insert) ; p -;; (8 insert) ; q -;; (9 insert)) ; r +;;(diff:edits "fghiejcklm" "fgehijkpqrlm" eqv?) +;;@result{} #As32(3 -5 -7 8 9 10) +;; ; e c h p q r ;;@end example -;; 12 - 10 = 2 -;; -11-10 -9 -8 -7 -6 -5 -4 -3 -2 -1 0 1 2 3 4 5 6 7 8 9 10 11 12 -;; -1 -1 -1 -1 -1 -1 -1 -1 -1 3 7 8 9 12 9 8 -1 -1 -1 -1 -1 -1 -1 -1 -;; edit-distance = 6 +;;(trace-all "/home/jaffer/slib/differ.scm")(set! *qp-width* 333)(untrace fp:run fp:subarray) diff --git a/differ.txi b/differ.txi new file mode 100644 index 0000000..c46fc2a --- /dev/null +++ b/differ.txi @@ -0,0 +1,105 @@ +@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/vita.html} +@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 +Surprisingly, "An O(NP) Sequence Comparison Algorithm" does not +derive the edit sequence; only the sequence length. Developing this +linear-space sub-quadratic-time algorithm for computing the edit +sequence required hundreds of hours of work. I have submitted a +paper describing the algorithm to the Journal of Computational +Biology. + +@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 procedure @var{=?} is used +to compare sequence tokens for equality. + +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 procedure @var{=?} is used +to compare sequence tokens for equality. + +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 procedure @var{=?} is used +to compare sequence tokens for equality. + +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" eqv?) +@result{} "fghijklm" + +(diff:edit-length "fghiejcklm" "fgehijkpqrlm" eqv?) +@result{} 6 + +(diff:edits "fghiejcklm" "fgehijkpqrlm" eqv?) +@result{} #As32(3 -5 -7 8 9 10) + ; e c h p q r +@end example + diff --git a/dirs.scm b/dirs.scm new file mode 100644 index 0000000..0592021 --- /dev/null +++ b/dirs.scm @@ -0,0 +1,98 @@ +;;; "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 'glob) + +;;@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))))))))) diff --git a/dirs.txi b/dirs.txi new file mode 100644 index 0000000..65d8b24 --- /dev/null +++ b/dirs.txi @@ -0,0 +1,46 @@ +@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 diff --git a/dwindtst.scm b/dwindtst.scm index 868901e..94b5827 100644 --- a/dwindtst.scm +++ b/dwindtst.scm @@ -8,7 +8,7 @@ ;1. Any copy made of this software must include this copyright notice ;in full. ; -;2. I have made no warrantee or representation that the operation of +;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. ; diff --git a/dynamic.scm b/dynamic.scm index 937f93e..3bdd037 100644 --- a/dynamic.scm +++ b/dynamic.scm @@ -26,21 +26,23 @@ *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*)) @@ -50,7 +52,7 @@ (dynamic-environment:value env)) (else (loop (dynamic-environment:parent env)))))) - +;@ (define (dynamic-set! dynamic obj) (guarantee-dynamic dynamic) (let loop ((env *current-dynamic-environment*)) @@ -60,7 +62,7 @@ (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 diff --git a/dynwind.scm b/dynwind.scm index c9bdb95..a6a80ab 100644 --- a/dynwind.scm +++ b/dynwind.scm @@ -8,7 +8,7 @@ ;1. Any copy made of this software must include this copyright notice ;in full. ; -;2. I have made no warrantee or representation that the operation of +;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. ; @@ -41,7 +41,7 @@ ;;;time of the error or interrupt. (define dynamic:winds '()) - +;@ (define (dynamic-wind ) () (set! dynamic:winds (cons (cons ) dynamic:winds)) @@ -49,7 +49,7 @@ (set! dynamic:winds (cdr dynamic:winds)) () ans)) - +;@ (define call-with-current-continuation (let ((oldcc call-with-current-continuation)) (lambda (proc) diff --git a/elk.init b/elk.init index 598b935..13fde42 100644 --- a/elk.init +++ b/elk.init @@ -1,4 +1,4 @@ -;;;"elk.init" Initialisation file for SLIB for ELK 2.1 -*- Scheme -*- +;;;"elk.init" Initialisation file for SLIB for ELK 3.0 -*- Scheme -*- ;;; Author: Aubrey Jaffer ;;; ;;; This code is in the public domain. @@ -16,39 +16,33 @@ ;;; (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) (case (software-type) - ((UNIX) "/usr/local/lib/elk-2.1/scm/") + ((UNIX) "/usr/local/lib/elk/runtime/scm/") ((VMS) "scheme$src:") ((MS-DOS) "C:\\scheme\\"))) ;;; (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) @@ -67,14 +61,18 @@ ;;; (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-path (getenv "HOME"))) - (lambda () home-path))) +(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))))) ;;; *features* should be set to a list of symbols describing features ;;; of this implementation. Suggestions for features are: - (define *features* '( source ;can load scheme source files @@ -84,7 +82,7 @@ ;; Scheme report features -; rev5-report ;conforms to +; r5rs ;conforms to ; eval ;R5RS two-argument eval ; values ;R5RS multiple values ; dynamic-wind ;R5RS dynamic-wind @@ -98,11 +96,11 @@ ;STRING-FILL!, LIST->VECTOR, ;VECTOR->LIST, and VECTOR-FILL! - rev4-report ;conforms to + r4rs ;conforms to ieee-p1178 ;conforms to -; rev3-report ;conforms to +; r3rs ;conforms to rev2-procedures ;SUBSTRING-MOVE-LEFT!, ;SUBSTRING-MOVE-RIGHT!, @@ -113,7 +111,7 @@ multiarg/and- ;/ and - can take more than 2 args. ; with-file ;has WITH-INPUT-FROM-FILE and - ;WITH-OUTPUT-FROM-FILE + ;WITH-OUTPUT-TO-FILE transcript ;TRANSCRIPT-ON and TRANSCRIPT-OFF ; ieee-floating-point ;conforms to IEEE Standard 754-1985 ;IEEE Standard for Binary @@ -152,7 +150,6 @@ ; 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) @@ -202,6 +199,37 @@ (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) @@ -268,7 +296,7 @@ (let ((cep (current-error-port))) (if (provided? 'trace) (print-call-stack cep)) (display "Warn: " cep) - (for-each (lambda (x) (display x cep)) args)))) + (for-each (lambda (x) (display #\ cep) (write x cep)) args)))) ;;; define an error procedure for the library (define slib:error @@ -323,7 +351,6 @@ ; _(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) @@ -333,14 +360,12 @@ ;;; (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 (slib:load (in-vicinity (library-vicinity) "require")) diff --git a/eval.scm b/eval.scm index a5e7e19..ae716f6 100644 --- a/eval.scm +++ b/eval.scm @@ -8,7 +8,7 @@ ;1. Any copy made of this software must include this copyright notice ;in full. ; -;2. I have made no warrantee or representation that the operation of +;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. ; @@ -45,15 +45,15 @@ (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 +;;;@ 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 @@ -111,7 +111,7 @@ null-environment scheme-report-environment values) r4rs-procedures)) (r4rs-environment (eval:make-environment r4rs-procedures)) - (r5rs-environment (eval:make-environment r4rs-procedures))) + (r5rs-environment (eval:make-environment r5rs-procedures))) (let ((car car)) (lambda (version) (cond ((car r5rs-environment)) @@ -125,7 +125,7 @@ ((4) r4rs-environment) ((5) r5rs-environment) (else (slib:error 'eval 'version version 'not 'available))))))) - +;@ (define eval (let ((eval-1 slib:eval) (apply apply) diff --git a/factor.scm b/factor.scm index 3b9fb5e..c445004 100644 --- a/factor.scm +++ b/factor.scm @@ -8,7 +8,7 @@ ;1. Any copy made of this software must include this copyright notice ;in full. ; -;2. I have made no warrantee or representation that the operation of +;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. ; @@ -17,7 +17,6 @@ ;promotional, or sales literature without prior written consent in ;each case. -(require 'common-list-functions) (require 'modular) (require 'random) (require 'byte) @@ -82,8 +81,10 @@ (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) - (comlist:notevery (lambda (prd) (= 1 (gcd n prd))) 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)) @@ -122,40 +123,37 @@ ;;There is a slight chance @code{(expt 2 (- prime:trials))} that a ;;composite will return @code{#t}. (define prime? prime:prime?) -(define probably-prime? prime:prime?) ;legacy (define (prime:prime< start) (do ((nbr (+ -1 start) (+ -1 nbr))) ((or (negative? nbr) (prime:prime? nbr)) (if (negative? nbr) #f nbr)))) -(define (prime:primes< start count) +;;@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)))) -;;@args start count -;;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< prime:primes<) (define (prime:prime> start) (do ((nbr (+ 1 start) (+ 1 nbr))) ((prime:prime? nbr) nbr))) -(define (prime:primes> start count) +;;@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))))) -;;@args start count -;;Returns a list of the first @2 prime numbers greater than @1. -(define primes> prime:primes>) ;;;;Lankinen's recursive factoring algorithm: ;From: ld231782@longs.LANCE.ColoState.EDU (L. Detweiler) @@ -232,14 +230,13 @@ '() (prime:fo m)))) -(define (prime:factor k) +;;@body +;;Returns a list of the prime factors of @1. The order of the +;;factors is unspecified. In order to obtain a sorted list do +;;@code{(sort! (factor @var{k}) <)}. +(define (factor k) (case k ((-1 0 1) (list k)) (else (if (negative? k) (cons -1 (prime:fe (- k))) (prime:fe k))))) -;;@args k -;;Returns a list of the prime factors of @1. The order of the -;;factors is unspecified. In order to obtain a sorted list do -;;@code{(sort! (factor @var{k}) <)}. -(define factor prime:factor) diff --git a/fft.scm b/fft.scm index 9537e9c..2257e30 100644 --- a/fft.scm +++ b/fft.scm @@ -1,5 +1,5 @@ ;;;"fft.scm" Fast Fourier Transform -;Copyright (C) 1999 Aubrey Jaffer +;Copyright (C) 1999, 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 @@ -8,7 +8,7 @@ ;1. Any copy made of this software must include this copyright notice ;in full. ; -;2. I have made no warrantee or representation that the operation of +;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. ; @@ -28,14 +28,13 @@ ;;; differs in the direction of rotation of the complex unit vectors. (require 'array) +(require 'logical) -(define (fft:shuffled&scaled ara n scale) +;;@code{(require 'fft)} +;;@ftindex fft + +(define (fft:shuffle&scale new ara n scale) (define lgn (integer-length (+ -1 n))) - (define new (apply make-array 0 (array-dimensions ara))) - (define bit-reverse (lambda (width in) - (if (zero? width) 0 - (+ (bit-reverse (+ -1 width) (quotient in 2)) - (ash (modulo in 2) (+ -1 width)))))) (if (not (eqv? n (expt 2 lgn))) (slib:error 'fft "array length not power of 2" n)) (do ((k 0 (+ 1 k))) @@ -61,10 +60,35 @@ (array-set! ara (+ u t) k) (array-set! ara (- u t) k+m/2))))))) +;;@args array +;;@var{array} is an array of @code{(expt 2 n)} numbers. @code{fft} +;;returns an array of complex numbers comprising the +;;@dfn{Discrete Fourier Transform} of @var{array}. (define (fft ara) (define n (car (array-dimensions ara))) - (dft! (fft:shuffled&scaled ara n 1) n 1)) + (define new (apply create-array ara (array-dimensions ara))) + (dft! (fft:shuffle&scale new ara n 1) n 1)) +;;@args array +;;@code{fft-1} returns an array of complex numbers comprising the +;;inverse Discrete Fourier Transform of @var{array}. (define (fft-1 ara) (define n (car (array-dimensions ara))) - (dft! (fft:shuffled&scaled ara n (/ n)) n -1)) + (define new (apply create-array ara (array-dimensions ara))) + (dft! (fft:shuffle&scale new ara n (/ n)) n -1)) + +;;@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 diff --git a/fft.txi b/fft.txi new file mode 100644 index 0000000..c73f103 --- /dev/null +++ b/fft.txi @@ -0,0 +1,32 @@ +@code{(require 'fft)} +@ftindex fft + + +@defun fft array + +@var{array} is an array of @code{(expt 2 n)} numbers. @code{fft} +returns an array of complex numbers comprising the +@dfn{Discrete Fourier Transform} of @var{array}. +@cindex Discrete Fourier Transform +@end defun + +@defun fft-1 array + +@code{fft-1} returns an 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 diff --git a/fluidlet.scm b/fluidlet.scm index 983bfdb..06d4630 100644 --- a/fluidlet.scm +++ b/fluidlet.scm @@ -1,5 +1,5 @@ ; "fluidlet.scm", FLUID-LET for Scheme -; Copyright (c) 1998, Aubrey Jaffer +; 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 @@ -8,7 +8,7 @@ ;1. Any copy made of this software must include this copyright notice ;in full. ; -;2. I have made no warrantee or representation that the operation of +;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. ; @@ -18,14 +18,13 @@ ;each case. (require 'dynamic-wind) -(require 'common-list-functions) ;MAKE-LIST - +;@ (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 (make-list (length clauses) #f))) + ,@(map list old-tmps (map (lambda (x) #f) clauses))) (dynamic-wind (lambda () ,@(map (lambda (ot id) `(set! ,ot ,id)) diff --git a/fmtdoc.txi b/fmtdoc.txi deleted file mode 100644 index 3e2adb7..0000000 --- a/fmtdoc.txi +++ /dev/null @@ -1,434 +0,0 @@ - -@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.0) - -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)). -@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}) - -@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 diff --git a/format.scm b/format.scm deleted file mode 100644 index 709acf7..0000000 --- a/format.scm +++ /dev/null @@ -1,1676 +0,0 @@ -;;; "format.scm" Common LISP text output formatter for SLIB -; Written 1992-1994 by Dirk Lutzebaeck (lutzeb@cs.tu-berlin.de) -; -; 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 - -(provide 'format) -(require 'string-case) -(require 'string-port) -(require 'multiarg/and-) -(require 'rev4-optional-procedures) - -;;; 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: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")) - -;;; End of configuration ---------------------------------------------------- - -(define format:version "3.0") -(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:error-continuation #f) -(define format:args #f) -(define format:pos 0) ; curr. format string parsing position -(define format:arg-pos 0) ; curr. format argument position - ; this is global for error presentation - -; 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))) - -; format's user error handler - -(define (format:error . args) ; never returns! - (let ((error-continuation format:error-continuation) - (format-args format:args) - (port (current-error-port))) - (set! format:error format:intern-error) - (if (and (>= (length format:args) 2) - (string? (cadr format:args))) - (let ((format-string (cadr format-args))) - (if (not (zero? format:arg-pos)) - (set! format:arg-pos (- format:arg-pos 1))) - (format port "~%FORMAT: error with call: (format ~a \"~a<===~a\" ~ - ~{~a ~}===>~{~a ~})~% " - (car format:args) - (substring format-string 0 format:pos) - (substring format-string format:pos - (string-length format-string)) - (format:list-head (cddr format:args) format:arg-pos) - (list-tail (cddr format:args) format:arg-pos))) - (format port - "~%FORMAT: error with call: (format~{ ~a~})~% " - format:args)) - (apply format port args) - (newline port) - (set! format:error format:error-save) - (set! format:error-continuation error-continuation) - (format:abort) - (format:intern-error "format:abort does not jump to toplevel!"))) - -(define format:error-save format:error) - -(define (format:intern-error . args) ;if something goes wrong in format:error - (display "FORMAT: INTERNAL ERROR IN FORMAT:ERROR!") (newline) - (display " format args: ") (write format:args) (newline) - (display " error args: ") (write args) (newline) - (set! format:error format:error-save) - (format:abort)) - -(define (format:format . args) ; the formatter entry - (set! format:args args) - (set! format:arg-pos 0) - (set! format:pos 0) - (if (< (length args) 1) - (format:error "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))) - ;; Use this canonicalized version when reporting errors. - (set! format:args args) - - (let ((destination (car args)) - (arglist (cdr args))) - (cond - ((or (and (boolean? destination) ; port output - destination) - (output-port? destination) - (number? destination)) - (format:out (cond - ((boolean? destination) (current-output-port)) - ((output-port? destination) destination) - ((number? destination) (current-error-port))) - (car arglist) (cdr arglist))) - ((and (boolean? destination) ; string output - (not destination)) - (call-with-output-string - (lambda (port) (format:out port (car arglist) (cdr arglist))))) - (else - (format:error "illegal destination `~a'" destination)))))) - -(define (format:out port fmt args) ; the output handler for a port - (set! format:port port) ; global port for output routines - (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:arg-pos (+ arg-pos 1)) - (set! format:pos (string-length fmt)) - (format:error "~a superfluous argument~:p" (- arg-len arg-pos))) - ((> arg-pos arg-len) - (set! format:arg-pos (+ arg-len 1)) - (display format:arg-pos) - (format:error "~a missing argument~:p" (- arg-pos arg-len))) - (else - (if format:flush-output (force-output port)) - #t)))) - -(define format:parameter-characters - '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\- #\+ #\v #\# #\')) - -(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) - (format:error "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 (format:error "one positive integer parameter expected"))))) - - (next-arg - (lambda () - (if (>= arg-pos arg-len) - (begin - (set! format:arg-pos (+ arg-len 1)) - (format:error "missing argument(s)"))) - (add-arg-pos 1) - (list-ref arglist (- arg-pos 1)))) - - (prev-arg - (lambda () - (add-arg-pos -1) - (if (negative? arg-pos) - (format:error "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)) - (set! format:arg-pos 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 - (set! format:read-proof (memq modifier '(colon colon-at))) - (format:out-obj-padded (memq modifier '(at colon-at)) - (next-arg) #f params) - (anychar-dispatch)) - ((#\S) ; Slashified -- for parsers - (set! format:read-proof (memq modifier '(colon colon-at))) - (format:out-obj-padded (memq modifier '(at colon-at)) - (next-arg) #t params) - (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) - (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) - (format:error - "complex numbers not supported by this scheme system")) - (let ((z (next-arg))) - (if (not (complex? z)) - (format:error "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)) (format:error "~~c expects a character")) - (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)) - (format:error "~~p expects a number argument")) - (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)) - (format:error "illegal modifier in ~~?")) - ((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) - (format:error "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) - (format:error "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) (format:error "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) - (format:error "~~; not in ~~[~~] conditional")) - (if (not (null? params)) - (format:error "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)) - (format:error "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) (format:error "missing ~~[")) - (set! conditional-nest (- conditional-nest 1)) - (if modifier - (format:error "no modifier allowed in ~~]")) - (if (not (null? params)) - (format:error "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)) - (format:error "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) (format:error "missing ~~{")) - (set! iteration-nest (- iteration-nest 1)) - (case modifier - ((colon) - (if (not max-iterations) (set! max-iterations 1))) - ((colon-at at) (format:error "illegal modifier")) - (else (if (not max-iterations) (set! max-iterations 100)))) - (if (not (null? params)) - (format:error "no parameters allowed in ~~}")) - (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)) - (format:error "expected a list argument")) - (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) - (>= i max-iterations)))))) - ((sublists) - (let ((args (next-arg)) - (args-len 0)) - (if (not (list? args)) - (format:error "expected a list argument")) - (set! args-len (length args)) - (do ((arg-pos 0 (+ arg-pos 1))) - ((or (>= arg-pos args-len) - (>= arg-pos max-iterations))) - (let ((sublist (list-ref args arg-pos))) - (if (not (list? sublist)) - (format:error - "expected a list of lists argument")) - (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) - (>= 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) - (>= arg-pos max-iterations)) - arg-pos) - (let ((sublist (list-ref args arg-pos))) - (if (not (list? sublist)) - (format:error "expected list arguments")) - (format:format-work iteration-str sublist))))) - (add-arg-pos usedup-args))) - (else (format:error "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 (format:error "too much 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)) - (format:error "double `@' modifier")) - (set! modifier (if (eq? modifier 'colon) 'colon-at 'at)) - (tilde-dispatch)) - ((#\:) ; `:' modifier - (if (memq modifier '(colon colon-at)) - (format:error "double `:' modifier")) - (set! modifier (if (eq? modifier 'at) 'colon-at 'colon)) - (tilde-dispatch)) - ((#\') ; Character parameter - (if modifier (format:error "misplaced 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 (format:error "misplaced 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 (format:error "misplaced modifier")) - (set! params (append params (list (next-arg)))) - (set! param-value-found #t) - (tilde-dispatch)) - ((#\#) ; Parameter is number of remaining args - (if modifier (format:error "misplaced modifier")) - (set! params (append params (list (length (rest-args))))) - (set! param-value-found #t) - (tilde-dispatch)) - ((#\,) ; Parameter separators - (if modifier (format:error "misplaced 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 - " (C) copyright 1992-1994 by Dirk Lutzebaeck" nl - " please send bug reports to `lutzeb@cs.tu-berlin.de'" - nl)))) - (anychar-dispatch)) - (else ; Unknown tilde directive - (format:error "unknown control character `~c'" - (string-ref format-string (- format:pos 1)))))) - (else (anychar-dispatch)))))) ; in case of conditional - - (set! format:pos 0) - (set! format:arg-pos 0) - (anychar-dispatch) ; start the formatting - (set! format:pos recursive-pos-save) - arg-pos)) ; return the position in the arg. list - -;; 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) - -(define (format:obj->str obj slashify) - (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)) - - ((output-port? obj) - (format:iobj->str obj)) - - ((list? obj) - (string-append "(" - (let loop ((obj-list obj)) - (if (null? (cdr obj-list)) - (format:obj->str (car obj-list) #t) - (string-append - (format:obj->str (car obj-list) #t) - " " - (loop (cdr obj-list))))) - ")")) - - ((pair? obj) - (string-append "(" - (format:obj->str (car obj) #t) - " . " - (format:obj->str (cdr obj) #t) - ")")) - - ((vector? obj) - (string-append "#" (format:obj->str (vector->list obj) #t))) - - (else ; only objects with an #<...> - (format:iobj->str obj)))) ; 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:read-proof #f) - -(define (format:iobj->str iobj) - (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))))) - - -;; 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)))))) - -(define format:space-ch (char->integer #\space)) -(define format:zero-ch (char->integer #\0)) - -(define (format:par pars length index default name) - (if (> length index) - (let ((par (list-ref pars index))) - (if par - (if name - (if (< par 0) - (format:error - "~s parameter must be a positive integer" name) - par) - par) - default)) - default)) - -(define (format:out-obj-padded pad-left obj slashify pars) - (if (null? pars) - (format:out-str (format:obj->str obj slashify)) - (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))) - (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)) (format:error "argument not an integer")) - (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) - (format:error "unsupported modifier for ~~t")) - ((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)))))) - - -;; 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: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)))))) - (format:error "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))))))) - (format:error "only positive integers can be romanized")))) - -;; cardinals & ordinals (from dorai@cs.rice.edu) - -(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: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: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:num->cardinal - (lambda (n) - (cond ((not (integer? n)) - (format:error - "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: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")) - -(define format:num->ordinal - (lambda (n) - (cond ((not (integer? n)) - (format:error - "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))) - (format:error "argument is not a number or a number string")) - - (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))) - (format:error "argument is not a 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))) - (format:error "argument is not a number or a number string")) - - (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))) - (format:error "argument is not a number or a number string")) - - (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-max 200) ; max. number of number digits -(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-max 10) ; max. number of exponent digits -(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 - (format:error "illegal character `~c' 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 - (format:error "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) - (format:error "internal error in format:fn-shiftleft (~d,~d)" - 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)))) - - -;;; 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))))))))) - -(define (format:list-head l k) - (if (= k 0) - '() - (cons (car l) (format:list-head (cdr l) (- k 1))))) - - -;; Aborts the program when a formatting error occures. This is a null -;; argument closure to jump to the interpreters toplevel continuation. - -(define format:abort (lambda () (slib:error "error in format"))) - -(define format format:format) - -;; If this is not possible then a continuation is used to recover -;; properly from a format error. In this case format returns #f. - -;(define format:abort -; (lambda () (format:error-continuation #f))) - -;(define format -; (lambda args ; wraps format:format with an error -; (call-with-current-continuation ; continuation -; (lambda (cont) -; (set! format:error-continuation cont) -; (apply format:format args))))) - -;eof diff --git a/formatst.scm b/formatst.scm deleted file mode 100644 index 3f19130..0000000 --- a/formatst.scm +++ /dev/null @@ -1,647 +0,0 @@ -;; "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.0")) - (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:read-proof #f) - -(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)) -(test `("~a" ,(current-input-port)) (format:iobj->str (current-input-port))) -(test `("~a" ,(current-output-port)) (format:iobj->str (current-output-port))) - -; # 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) - (begin - (set! format:read-proof #t) - (format:iobj->str display))) -(test `("~:a" ,display) - (begin - (set! format:read-proof #t) - (format:iobj->str display))) -(test `("~:a" (1 2 ,display)) - (begin - (set! format:read-proof #t) - (string-append "(1 2 " (format:iobj->str display) ")"))) -(test '("~:a" "abc") "abc") -(set! format:read-proof #f) - -; internal object case type force test - -(set! format:iobj-case-conv string-upcase) -(test `("~a" ,display) (string-upcase (format:iobj->str display))) -(set! format:iobj-case-conv string-downcase) -(test `("~s" ,display) (string-downcase (format:iobj->str display))) -(set! format:iobj-case-conv string-capitalize) -(test `("~s" ,display) (string-capitalize (format:iobj->str display))) -(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))) -(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") - -; 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) - -; eof diff --git a/gambit.init b/gambit.init index 538fb47..2e8a10d 100644 --- a/gambit.init +++ b/gambit.init @@ -11,7 +11,6 @@ ;;; 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 - (define (software-type) 'MACOS) ; for MacGambit. (define (software-type) 'UNIX) ; for Unix platforms. @@ -20,7 +19,6 @@ ;;; (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") @@ -35,10 +33,9 @@ ;;; (implementation-vicinity) should be defined to be the pathname of ;;; the directory where any auxillary files to your Scheme ;;; implementation reside. - (define implementation-vicinity (case (software-type) - ((UNIX) (lambda () "/usr/local/src/scheme/")) + ((UNIX) (lambda () "/usr/local/share/gambc/")) ((VMS) (lambda () "scheme$src:")) ((MS-DOS) (lambda () "C:\\scheme\\")) ((WINDOWS) (lambda () "c:/scheme/")) @@ -53,10 +50,9 @@ ;;; (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 (case (software-type) @@ -71,20 +67,24 @@ ;;; (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) #f) +(define home-vicinity + (case (software-type) + ((UNIX) (lambda () "~/")) + ((VMS) (lambda () "~:")) + ((MS-DOS) (lambda () "~\\")) + ((WINDOWS) (lambda () "~/")) + ((MACOS) (lambda () "~:")))) ;;; *FEATURES* should be set to a list of symbols describing features ;;; of this implementation. Suggestions for features are: - (define *features* '( source ;can load scheme source files ;(slib:load-source "filename") compiled ;can load compiled files ;(slib:load-compiled "filename") - rev4-report ;conforms to -; rev3-report ;conforms to + r4rs ;conforms to +; r3rs ;conforms to ieee-p1178 ;conforms to ; srfi ;srfi-0, COND-EXPAND finds all srfi-* sicp ;runs code from Structure and @@ -104,7 +104,7 @@ rationalize delay ;has DELAY and FORCE with-file ;has WITH-INPUT-FROM-FILE and - ;WITH-OUTPUT-FROM-FILE + ;WITH-OUTPUT-TO-FILE string-port ;has CALL-WITH-INPUT-STRING and ;CALL-WITH-OUTPUT-STRING transcript ;TRANSCRIPT-ON and TRANSCRIPT-OFF @@ -123,6 +123,7 @@ ; object->string ; format trace ;has macros: TRACE and UNTRACE + break ; compiler ;has (COMPILER) ; ed ;(ED) is editor system ;posix (system ) @@ -163,6 +164,37 @@ ;;; 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 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) (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))) @@ -190,10 +222,6 @@ ;(define macro:eval slib:eval) ;(define macro:load load) -; Set up defmacro in terms of gambit's define-macro -(define-macro (defmacro name args . body) - `(define-macro (,name ,@args) ,@body)) - (define *defmacros* (list (cons 'defmacro (lambda (name parms . body) @@ -241,12 +269,14 @@ (evl o)) (set! *load-pathname* old-load-pathname))))) +(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 x cep)) args)))) + (for-each (lambda (x) (display #\ cep) (write x cep)) args)))) ;; define an error procedure for the library (define (slib:error . args) @@ -264,7 +294,6 @@ ;;; 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+) @@ -284,17 +313,19 @@ ;;; (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) +(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")) diff --git a/genwrite.scm b/genwrite.scm index 2e4bf60..4f9105f 100644 --- a/genwrite.scm +++ b/genwrite.scm @@ -4,7 +4,7 @@ ;; Distribution restrictions: none (define genwrite:newline-str (make-string 1 #\newline)) - +;@ (define (generic-write obj display? width output) (define (read-macro? l) @@ -247,7 +247,7 @@ (wr obj 0))) ; (reverse-string-append l) = (apply string-append (reverse l)) - +;@ (define (reverse-string-append l) (define (rev-string-append l i) diff --git a/getopt.scm b/getopt.scm index bb0b8a8..7b73b58 100644 --- a/getopt.scm +++ b/getopt.scm @@ -1,5 +1,5 @@ ;;; "getopt.scm" POSIX command argument processing -;Copyright (C) 1993, 1994 Aubrey Jaffer +;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 @@ -8,7 +8,7 @@ ;1. Any copy made of this software must include this copyright notice ;in full. ; -;2. I have made no warrantee or representation that the operation of +;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. ; @@ -19,19 +19,21 @@ (define getopt:scan #f) (define getopt:char #\-) +;@ (define getopt:opt #f) +(define *argv* *argv*) (define *optind* 1) (define *optarg* 0) - -(define (getopt argc argv optstring) +;@ +(define (getopt optstring) (let ((opts (string->list optstring)) (place #f) (arg #f) - (argref (lambda () ((if (vector? argv) vector-ref list-ref) - argv *optind*)))) + (argref (lambda () ((if (vector? *argv*) vector-ref list-ref) + *argv* *optind*)))) (and (cond ((and getopt:scan (not (string=? "" getopt:scan))) #t) - ((>= *optind* argc) #f) + ((>= *optind* (length *argv*)) #f) (else (set! arg (argref)) (cond ((or (<= (string-length arg) 1) @@ -42,8 +44,7 @@ (set! *optind* (+ *optind* 1)) #f) (else - (set! getopt:scan - (substring arg 1 (string-length arg))) + (set! getopt:scan (substring arg 1 (string-length arg))) #t)))) (begin (set! getopt:opt (string-ref getopt:scan 0)) @@ -59,22 +60,21 @@ (set! *optind* (+ *optind* 1)) (set! getopt:scan #f) getopt:opt) - ((< *optind* argc) + ((< *optind* (length *argv*)) (set! *optarg* (argref)) (set! *optind* (+ *optind* 1)) getopt:opt) ((and (not (null? opts)) (char=? #\: (car opts))) #\:) (else #\?)))))) - -(define (getopt-- argc argv optstring) - (let* ((opt (getopt argc argv (string-append optstring "-:"))) +;@ +(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)))))) + (cond ((>= i l) (set! *optarg* #f) optarg) + (else (set! *optarg* (substring optarg (+ 1 i) l)) + (substring optarg 0 i)))))) (else opt)))) diff --git a/getparam.scm b/getparam.scm index 3e2d7f1..1e7b7c0 100644 --- a/getparam.scm +++ b/getparam.scm @@ -8,7 +8,7 @@ ;1. Any copy made of this software must include this copyright notice ;in full. ; -;2. I have made no warrantee or representation that the operation of +;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. ; @@ -19,12 +19,41 @@ (require 'getopt) (require 'coerce) +(require 'parameters) +(require-if 'compiling 'printf) +(require-if 'compiling 'common-list-functions) -(define (getopt->parameter-list argc argv optnames arities types aliases - . description) +;;@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*))) + (let ((progname (list-ref *argv* (+ -1 *optind*))) (optlist '()) (long-opt-list '()) (optstring #f) @@ -63,7 +92,8 @@ (for-each (lambda (unc) (adjoin-val unc curopt)) unclaimeds) (set! unclaimeds '())))))) (cond ((not (null? unclaimeds)) - (slib:warn 'getopt->parameter-list 'arguments 'unclaimed unclaimeds) + (getopt-barf "%s: Unclaimed argument '%s'" + progname (car unclaimeds)) (apply parameter-list->getopt-usage progname optnames arities types aliases description)) (else parameter-list))) @@ -94,34 +124,34 @@ aliases) (set! optstring (list->string (cons #\: optlist))) (let loop () - (let ((opt (getopt-- argc argv optstring))) + (let ((opt (getopt-- optstring))) (case opt ((#\: #\?) - (slib:warn 'getopt->parameter-list - (case opt - ((#\:) "argument missing after") - ((#\?) "unrecognized option")) - (string #\- getopt: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* argc) - (string=? "-" (list-ref argv *optind*))) + (cond ((and (< *optind* (length *argv*)) + (string=? "-" (list-ref *argv* *optind*))) (set! *optind* (+ 1 *optind*)) (finish)) - ((< *optind* argc) + ((< *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)) + (cons (list-ref *argv* *optind*) unclaimeds)) (set! *optind* (+ 1 *optind*)) (loop)) ((and (member curopt optnames) - (adjoin-val (list-ref argv *optind*) curopt)) + (adjoin-val (list-ref *argv* *optind*) curopt)) (set! *optind* (+ 1 *optind*)) (loop)) (else (slib:error 'getopt->parameter-list curopt - (list-ref argv *optind*) + (list-ref *argv* *optind*) 'not 'supported))))) (else (finish)))) (else @@ -130,7 +160,7 @@ (if topt (set! topt (cadr topt))) (cond ((not topt) - (slib:warn "Option not recognized -" opt) + (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)) @@ -138,9 +168,15 @@ (loop)) (*optarg* (set! curopt topt) (adjoin-val *optarg* curopt) (loop)) (else -;;; (slib:warn 'getopt->parameter-list "= missing for option--" opt) + ;;(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) @@ -198,11 +234,17 @@ (for-each (lambda (desc) (fprintf cep " %s\\n" desc)) description)) #f) -(define (getopt->arglist argc argv optnames positions +;;@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*))) + (define progname (list-ref *argv* (+ -1 *optind*))) (let* ((params (apply getopt->parameter-list - argc argv optnames arities types aliases description)) + optnames arities types aliases description)) (fparams (and params (fill-empty-parameters defaulters params)))) (cond ((and (list? params) (check-parameters checks fparams) @@ -211,3 +253,49 @@ 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 diff --git a/getparam.txi b/getparam.txi new file mode 100644 index 0000000..3d2594c --- /dev/null +++ b/getparam.txi @@ -0,0 +1,85 @@ +@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 diff --git a/glob.scm b/glob.scm index d6e993b..382bbf3 100644 --- a/glob.scm +++ b/glob.scm @@ -8,7 +8,7 @@ ;1. Any copy made of this software must include this copyright notice ;in full. ; -;2. I have made no warrantee or representation that the operation of +;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. ; @@ -17,6 +17,10 @@ ;promotional, or sales literature without prior written consent in ;each case. +;;@code{(require 'filename)} or @code{(require 'glob)} +;;@ftindex filename +;;@ftindex glob + (define (glob:pattern->tokens pat) (cond ((string? pat) @@ -187,31 +191,87 @@ (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<=?)) -(define (glob:match?? pat) - (glob:make-matcher pat char=? char<=?)) -(define (glob:match-ci?? pat) - (glob:make-matcher pat char-ci=? char-ci<=?)) -(define filename:match?? glob:match??) -(define filename:match-ci?? glob:match-ci??) -(define (glob:substitute?? pat templ) - (cond ((procedure? templ) - (glob:caller-with-matches pat templ char=? char<=?)) - ((string? templ) - (glob:make-substituter pat templ char=? char<=?)) +;;@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 'glob:substitute "bad second argument" templ)))) -(define (glob:substitute-ci?? pat templ) - (cond ((procedure? templ) - (glob:caller-with-matches pat templ char-ci=? char-ci<=?)) - ((string? templ) - (glob:make-substituter pat templ char-ci=? char-ci<=?)) + (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 'glob:substitute "bad second argument" templ)))) -(define filename:substitute?? glob:substitute??) -(define filename:substitute-ci?? glob:substitute-ci??) + (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<=?)) @@ -222,3 +282,37 @@ (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))))) diff --git a/glob.txi b/glob.txi new file mode 100644 index 0000000..d83b66b --- /dev/null +++ b/glob.txi @@ -0,0 +1,100 @@ +@code{(require 'filename)} or @code{(require 'glob)} +@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 diff --git a/grapheps.ps b/grapheps.ps new file mode 100644 index 0000000..87658dd --- /dev/null +++ b/grapheps.ps @@ -0,0 +1,344 @@ +%%EndComments +/plotdict 100 dict def +plotdict begin + +% 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 +/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 currentpoint pop 0 lineto} {}] bind def +/bargraph [{} {exch GR sub exch 0 exch 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 [{} + {2 copy 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 [{} + {2 copy 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 + +/whole-page +{clippath pathbbox 2 index sub exch 3 index sub exch 4 array astore} 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 + +% 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 (-.0123456789) stringwidth pop pointsize 1.2 mul add def + /PLOT-rmargin (-.0123456789) 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 find-tick-scale def + /YSTEP YTSCL 0 get 3 mod 0 eq {6} {8} ifelse 5 mul yuntrans def + /XTSCL plotrect 2 get XRNG aload pop exch sub find-tick-scale def + /XSTEP XTSCL 0 get 3 mod 0 eq {6} {8} ifelse 10 mul xuntrans 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 + +/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 ISIZ le {exit} if /DEN DEN 10 mul def /ISIZ ISIZ 10 mul def} loop + /NUM 1 def + {DLTA 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 + +% Default parameters + +% 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 + diff --git a/grapheps.scm b/grapheps.scm new file mode 100644 index 0000000..0f11a6d --- /dev/null +++ b/grapheps.scm @@ -0,0 +1,617 @@ +;;;; "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://swissnet.ai.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) + (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 (+ 1 (cadadr (array-shape 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 '("gsave pointsize glyphsize") + args + '("/glyphsize exch def /pointsize exch def grestore"))) + +;;@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 "/pointsize " fontheight " def /" name " pointsize 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 +;;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 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-horizontal x-coord text tick-height) + (scheme->ps x-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 (create-array (Ar64) (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) (column-range data 1)) + (outline-rect plotrect) + (x-axis) (y-axis) + (plot-column data 0 1 (if histogram? 'bargraph 'line)) + (rule-vertical leftedge ylabel 10) + (rule-horizontal bottomedge xlabel 10))) + +(define (graph:plot-function tmp func vlo vhi . npts) + (set! npts (if (null? npts) 200 (car npts))) + (let ((dats (create-array (Ar64) 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)) + (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 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) + (if (procedure? (car args)) + (apply graph:plot-function tmp args) + (apply graph:plot tmp args)) + (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 (create-array (Ar64) +;; (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 diff --git a/grapheps.txi b/grapheps.txi new file mode 100644 index 0000000..d587107 --- /dev/null +++ b/grapheps.txi @@ -0,0 +1,465 @@ +@code{(require 'eps-graph)} + +@noindent +This is a graphing package creating encapsulated-PostScript files. +Its motivations and design choice are described in +@url{http://swissnet.ai.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 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 x-coord text tick-height + +Draws a horizontal ruler with X coordinate @var{x-coord} and labeled with +string @var{text}. If @var{tick-height} is positive, then the ticks are @var{tick-height} long on the +right side of @var{x-coord}; and @var{text} and numeric legends are on the left. If @var{tick-height} +is negative, then the ticks are -@var{tick-height} long on the left side of @var{x-coord}; and +@var{text} and numeric legends are on the right. +@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 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 (create-array (Ar64) + (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 diff --git a/guile.init b/guile.init index 897a28a..6b54fea 100644 --- a/guile.init +++ b/guile.init @@ -1,4 +1,418 @@ -;"guile.init" Configuration file for SLIB for GUILE -*-scheme-*- +;"guile.init" Configuration file for SLIB for GUILE -*-scheme-*- +;;; Author: Aubrey Jaffer +;;; +;;; This code is in the public domain. -(use-modules (ice-9 slib)) -(define (slib:load-cadr argv) (slib:load (cadr argv))) +(if (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) 'unix) + +;;; (scheme-implementation-type) should return the name of the scheme +;;; implementation loading this file. +(define (scheme-implementation-type) 'guile) + +;;; (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.gnu.org/software/guile/guile.html") + +;;; (scheme-implementation-version) should return a string describing +;;; the version the scheme implementation loading this file. +(define scheme-implementation-version version) + +(define in-vicinity string-append) + +;;; (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* ((path (or (%search-load-path "slib/require.scm") + (error "Could not find slib/require.scm in " %load-path))) + (vic (substring path 0 (- (string-length path) 16)))) + (lambda () vic))) + +;;; (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")) + ;; Use this path if your scheme does not support GETENV + ;; or if SCHEME_LIBRARY_PATH is not set. + (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 (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))))) + +;;; *FEATURES* should be set to a list of symbols describing features +;;; of this implementation. Suggestions for features are: +(define *features* + (append + '( + source ;can load scheme source files + ;(slib:load-source "filename") +; compiled ;can load compiled files + ;(slib:load-compiled "filename") + + ;; Scheme report 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. +; rationalize + rev4-optional-procedures ;LIST-TAIL, STRING->LIST, + ;LIST->STRING, STRING-COPY, + ;STRING-FILL!, LIST->VECTOR, + ;VECTOR->LIST, and VECTOR-FILL! + +; 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 + + multiarg/and- ;/ and - can take more than 2 args. + with-file ;has WITH-INPUT-FROM-FILE and + ;WITH-OUTPUT-TO-FILE +; transcript ;TRANSCRIPT-ON and TRANSCRIPT-OFF +; ieee-floating-point ;conforms to IEEE Standard 754-1985 + ;IEEE Standard for Binary + ;Floating-Point Arithmetic. + full-continuation ;can return multiple times + + ;; Other common features + +; srfi ;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 + random + ) + + (if (defined? 'getenv) + '(getenv) + '()) + + (if (defined? 'current-time) + '(current-time) + '()) + + (if (defined? 'system) + '(system) + '()) + + (if (defined? 'array?) + '(array) + '()) + + (if (defined? 'char-ready?) + '(char-ready?) + '()) + + (if (defined? 'array-for-each) + '(array-for-each) + '()) + + *features*)) + +;;; (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))))) + +;;; (FILE-EXISTS? ) +;;(define (file-exists? f) #f) + +;;; (DELETE-FILE ) +;;(define (delete-file f) #f) + +;;; 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 (port? obj) (or (input-port? obj) (output-port? obj))) +(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)) + +;;; "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 #x0FFFFFFF) + +;;; Return argument +(define (identity x) x) + +;;; SLIB:EVAL is single argument eval using the top-level (user) environment. +(define slib:eval + (if (string evl) + (if (not (file-exists? )) + (set! (string-append (scheme-file-suffix)))) + (call-with-input-file + (lambda (port) + (let ((old-load-pathname *load-pathname*)) + (set! *load-pathname* ) + (do ((o (read port) (read port))) + ((eof-object? o)) + (evl o)) + (set! *load-pathname* old-load-pathname))))) + +(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)) + +;;; (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 + (let ((load-file (guile:wrap-case-insensitive load))) + (lambda () + (load-file (string-append (scheme-file-suffix)))))) + +(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 '())) + +;;; If your implementation provides R4RS macros: +(define macro:eval slib:eval) +(define macro:load slib:load) + +(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 logical:logand logand) +(define logical:logior logior) +;;(define logical:logxor logxor) +;;(define logical:lognot lognot) +;;(define logical:logtest logtest) +;;(define logical:logbit? logbit?) +(define (copy-bit index to bool) + (if bool + (logical:logior to (logical:ash 1 index)) + (logical:logand to (logical:lognot (logical:ash 1 index))))) +;;(define copy-bit logical:copy-bit) +;;(define logical:ash ash) +;;(define logical:logcount logcount) +;;(define logical:integer-length integer-length) +(define (logical:bit-field n start end) + (logical:logand (- (logical:integer-expt 2 (- end start)) 1) + (logical:ash n (- start)))) +;;(define bit-field logical:bit-field) +(define (bitwise-if mask n0 n1) + (logical:logior (logical:logand mask n0) + (logical:logand (logical:lognot mask) n1))) +(define logical:bitwise-if bitwise-if) +;;(define logical:bit-extract bit-extract) +(define (copy-bit-field to start end from) + (logical:bitwise-if + (logical:ash (- (logical:integer-expt 2 (- end start)) 1) start) + (logical:ash from start) + to)) +;;(define copy-bit-field logical:copy-bit-field) +(define logical:integer-expt integer-expt) +;;(define logical:ipow-by-squaring ipow-by-squaring) + +;;guile> (expt 2 -1) +;;ERROR: In procedure integer-expt: +;;ERROR: Argument out of range: -1 +;;ABORT: (out-of-range) +(define expt + (let ((integer-expt integer-expt)) + (lambda (z1 z2) + (cond ((zero? z1) (if (zero? z2) 1 0)) + ((and (exact? z2) (not (negative? z2))) + (integer-expt z1 z2)) + ((and (real? z2) (real? z1) (>= z1 0)) + ($expt z1 z2)) + (else + (exp (* z2 (log z1)))))))) + +;;; array-for-each +(define (array-indexes ra) + (let ((ra0 (apply create-array '#() (array-shape ra)))) + (array-index-map! ra0 list) + ra0)) +(define (array-copy! source dest) + (array-map! dest identity source)) +(define (array-null? array) + (zero? (apply * (map (lambda (bnd) (- 1 (apply - bnd))) + (array-shape array))))) +(define (create-array 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)))))) +(define (make-uniform-wrapper prot) + (if (string? prot) (set! prot (string->number prot))) + (if prot + (lambda opt (if (null? opt) + (list->uniform-array 1 prot '()) + (list->uniform-array 1 prot 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)) + +;;; {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))) + +;;; 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)) + +;;; Guile has nil and t as self-sets +;;(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+) + +(slib:load (in-vicinity (library-vicinity) "require")) diff --git a/hash.scm b/hash.scm index e53d518..ec2718a 100644 --- a/hash.scm +++ b/hash.scm @@ -1,5 +1,5 @@ ; "hash.scm", hashing functions for Scheme. -; Copyright (c) 1992, 1993, 1995 Aubrey Jaffer +; 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 @@ -8,7 +8,7 @@ ;1. Any copy made of this software must include this copyright notice ;in full. ; -;2. I have made no warrantee or representation that the operation of +;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. ; @@ -17,11 +17,6 @@ ;promotional, or sales literature without prior written consent in ;each case. -(define (hash:hash-char-ci char n) - (modulo (char->integer (char-downcase char)) n)) - -(define hash:hash-char hash:hash-char-ci) - (define (hash:hash-symbol sym n) (hash:hash-string (symbol->string sym) n)) @@ -62,8 +57,8 @@ h))))) (define hash:hash-string hash:hash-string-ci) - -(define (hash:hash obj n) +;@ +(define (hash obj n) (let hs ((d 10) (obj obj)) (cond ((number? obj) (hash:hash-number obj n)) @@ -130,24 +125,23 @@ (else 263)) n))))) -(define hash hash:hash) -(define hashv hash:hash) +(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, ;;; vectors, and records. This also allows us to use it for both ;;; hashq and hashv. - -(if (provided? 'object-hash) - (set! hashv - (if (provided? 'record) - (lambda (obj k) - (if (or (string? obj) (pair? obj) (vector? obj) (record? obj)) - (modulo (object-hash obj) k) - (hash:hash obj k))) - (lambda (obj k) - (if (or (string? obj) (pair? obj) (vector? obj)) - (modulo (object-hash obj) k) - (hash:hash obj k)))))) - +;@ +(define hashv + (if (provided? 'object-hash) + (if (provided? 'record) + (lambda (obj k) + (if (or (string? obj) (pair? obj) (vector? obj) (record? obj)) + (modulo (object-hash obj) k) + (hash:hash obj k))) + (lambda (obj k) + (if (or (string? obj) (pair? obj) (vector? obj)) + (modulo (object-hash obj) k) + (hash:hash obj k)))) + hash)) (define hashq hashv) diff --git a/hashtab.scm b/hashtab.scm index de46d47..6656ca4 100644 --- a/hashtab.scm +++ b/hashtab.scm @@ -1,5 +1,5 @@ ; "hashtab.scm", hash tables for Scheme. -; Copyright (c) 1992, 1993 Aubrey Jaffer +; 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 @@ -8,7 +8,7 @@ ;1. Any copy made of this software must include this copyright notice ;in full. ; -;2. I have made no warrantee or representation that the operation of +;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. ; @@ -20,6 +20,15 @@ (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) @@ -31,22 +40,47 @@ ((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))) @@ -55,7 +89,10 @@ (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))) @@ -64,7 +101,10 @@ (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))) @@ -72,8 +112,32 @@ (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)))) diff --git a/hashtab.txi b/hashtab.txi new file mode 100644 index 0000000..b2a7a0e --- /dev/null +++ b/hashtab.txi @@ -0,0 +1,84 @@ +@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 diff --git a/html4each.scm b/html4each.scm new file mode 100644 index 0000000..02e666e --- /dev/null +++ b/html4each.scm @@ -0,0 +1,240 @@ +;;;; 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? "