diff options
| -rw-r--r-- | ANNOUNCE | 136 | ||||
| -rw-r--r-- | Bev2slib.scm | 2 | ||||
| -rw-r--r-- | COPYING | 2 | ||||
| -rw-r--r-- | ChangeLog | 2079 | ||||
| -rw-r--r-- | DrScheme.init | 61 | ||||
| -rw-r--r-- | FAQ | 23 | ||||
| -rw-r--r-- | Makefile | 309 | ||||
| -rw-r--r-- | README | 88 | ||||
| -rw-r--r-- | RScheme.init | 50 | ||||
| -rw-r--r-- | STk.init | 63 | ||||
| -rw-r--r-- | Template.scm | 146 | ||||
| -rw-r--r-- | alist.scm | 55 | ||||
| -rw-r--r-- | alist.txi | 70 | ||||
| -rw-r--r-- | alistab.scm | 33 | ||||
| -rw-r--r-- | array.scm | 186 | ||||
| -rw-r--r-- | array.txi | 227 | ||||
| -rw-r--r-- | arraymap.scm | 83 | ||||
| -rw-r--r-- | arraymap.txi | 68 | ||||
| -rw-r--r-- | batch.scm | 145 | ||||
| -rw-r--r-- | bigloo.init | 82 | ||||
| -rw-r--r-- | break.scm | 29 | ||||
| -rw-r--r-- | byte.scm | 214 | ||||
| -rw-r--r-- | byte.txi | 179 | ||||
| -rw-r--r-- | bytenumb.scm | 346 | ||||
| -rw-r--r-- | bytenumb.txi | 181 | ||||
| -rw-r--r-- | chap.scm | 47 | ||||
| -rw-r--r-- | chap.txi | 46 | ||||
| -rw-r--r-- | charplot.scm | 380 | ||||
| -rw-r--r-- | chez.init | 75 | ||||
| -rw-r--r-- | cie1931.xyz | 82 | ||||
| -rw-r--r-- | cie1964.xyz | 82 | ||||
| -rw-r--r-- | cltime.scm | 10 | ||||
| -rw-r--r-- | coerce.scm | 2 | ||||
| -rw-r--r-- | collect.scm | 105 | ||||
| -rw-r--r-- | collectx.scm | 247 | ||||
| -rw-r--r-- | color.scm | 674 | ||||
| -rw-r--r-- | color.txi | 345 | ||||
| -rw-r--r-- | colornam.scm | 117 | ||||
| -rw-r--r-- | colornam.txi | 75 | ||||
| -rw-r--r-- | colorspc.scm | 536 | ||||
| -rw-r--r-- | comlist.scm | 317 | ||||
| -rw-r--r-- | comparse.scm | 76 | ||||
| -rw-r--r-- | comparse.txi | 81 | ||||
| -rw-r--r-- | crc.scm | 137 | ||||
| -rw-r--r-- | cring.scm | 30 | ||||
| -rw-r--r-- | cvs.scm | 140 | ||||
| -rw-r--r-- | cvs.txi | 32 | ||||
| -rw-r--r-- | daylight.scm | 356 | ||||
| -rw-r--r-- | daylight.txi | 117 | ||||
| -rw-r--r-- | db2html.scm | 77 | ||||
| -rw-r--r-- | db2html.txi | 13 | ||||
| -rw-r--r-- | dbcom.scm | 215 | ||||
| -rw-r--r-- | dbinterp.scm | 34 | ||||
| -rw-r--r-- | dbrowse.scm | 14 | ||||
| -rw-r--r-- | dbsyn.scm | 54 | ||||
| -rw-r--r-- | dbutil.scm | 674 | ||||
| -rw-r--r-- | dbutil.txi | 219 | ||||
| -rw-r--r-- | debug.scm | 6 | ||||
| -rw-r--r-- | defmacex.scm | 4 | ||||
| -rw-r--r-- | determ.scm | 157 | ||||
| -rw-r--r-- | determ.txi | 47 | ||||
| -rw-r--r-- | differ.scm | 521 | ||||
| -rw-r--r-- | differ.txi | 105 | ||||
| -rw-r--r-- | dirs.scm | 98 | ||||
| -rw-r--r-- | dirs.txi | 46 | ||||
| -rw-r--r-- | dwindtst.scm | 2 | ||||
| -rw-r--r-- | dynamic.scm | 10 | ||||
| -rw-r--r-- | dynwind.scm | 6 | ||||
| -rw-r--r-- | elk.init | 69 | ||||
| -rw-r--r-- | eval.scm | 12 | ||||
| -rw-r--r-- | factor.scm | 39 | ||||
| -rw-r--r-- | fft.scm | 44 | ||||
| -rw-r--r-- | fft.txi | 32 | ||||
| -rw-r--r-- | fluidlet.scm | 9 | ||||
| -rw-r--r-- | fmtdoc.txi | 434 | ||||
| -rw-r--r-- | format.scm | 1676 | ||||
| -rw-r--r-- | formatst.scm | 647 | ||||
| -rw-r--r-- | gambit.init | 73 | ||||
| -rw-r--r-- | genwrite.scm | 4 | ||||
| -rw-r--r-- | getopt.scm | 34 | ||||
| -rw-r--r-- | getparam.scm | 132 | ||||
| -rw-r--r-- | getparam.txi | 85 | ||||
| -rw-r--r-- | glob.scm | 136 | ||||
| -rw-r--r-- | glob.txi | 100 | ||||
| -rw-r--r-- | grapheps.ps | 344 | ||||
| -rw-r--r-- | grapheps.scm | 617 | ||||
| -rw-r--r-- | grapheps.txi | 465 | ||||
| -rw-r--r-- | guile.init | 420 | ||||
| -rw-r--r-- | hash.scm | 42 | ||||
| -rw-r--r-- | hashtab.scm | 78 | ||||
| -rw-r--r-- | hashtab.txi | 84 | ||||
| -rw-r--r-- | html4each.scm | 240 | ||||
| -rw-r--r-- | html4each.txi | 70 | ||||
| -rw-r--r-- | htmlform.scm | 74 | ||||
| -rw-r--r-- | htmlform.txi | 27 | ||||
| -rw-r--r-- | http-cgi.scm | 34 | ||||
| -rw-r--r-- | lineio.scm | 34 | ||||
| -rw-r--r-- | lineio.txi | 19 | ||||
| -rw-r--r-- | logical.scm | 335 | ||||
| -rw-r--r-- | macscheme.init | 47 | ||||
| -rw-r--r-- | macwork.scm | 18 | ||||
| -rw-r--r-- | makcrc.scm | 96 | ||||
| -rw-r--r-- | manifest.scm | 350 | ||||
| -rw-r--r-- | manifest.txi | 145 | ||||
| -rw-r--r-- | matfile.scm | 187 | ||||
| -rw-r--r-- | matfile.txi | 31 | ||||
| -rw-r--r-- | mbe.scm | 72 | ||||
| -rw-r--r-- | minimize.scm | 3 | ||||
| -rw-r--r-- | mitscheme.init | 305 | ||||
| -rw-r--r-- | mkclrnam.scm | 259 | ||||
| -rw-r--r-- | mkclrnam.txi | 54 | ||||
| -rw-r--r-- | mklibcat.scm | 401 | ||||
| -rw-r--r-- | modular.scm | 180 | ||||
| -rw-r--r-- | modular.txi | 114 | ||||
| -rw-r--r-- | mulapply.scm | 22 | ||||
| -rw-r--r-- | mularg.scm | 20 | ||||
| -rw-r--r-- | mwexpand.scm | 40 | ||||
| -rw-r--r-- | mwsynrul.scm | 8 | ||||
| -rw-r--r-- | ncbi-dna.scm | 172 | ||||
| -rw-r--r-- | ncbi-dna.txi | 54 | ||||
| -rw-r--r-- | nclients.scm | 385 | ||||
| -rw-r--r-- | nclients.txi | 103 | ||||
| -rw-r--r-- | null.scm | 1 | ||||
| -rw-r--r-- | obj2str.scm | 3 | ||||
| -rw-r--r-- | object.scm | 18 | ||||
| -rw-r--r-- | object.texi (renamed from objdoc.txi) | 0 | ||||
| -rw-r--r-- | paramlst.scm | 18 | ||||
| -rw-r--r-- | phil-spc.scm | 94 | ||||
| -rw-r--r-- | phil-spc.txi | 38 | ||||
| -rw-r--r-- | plottest.scm | 27 | ||||
| -rw-r--r-- | pnm.scm | 277 | ||||
| -rw-r--r-- | pnm.txi | 66 | ||||
| -rw-r--r-- | pp.scm | 8 | ||||
| -rw-r--r-- | ppfile.scm | 7 | ||||
| -rw-r--r-- | prec.scm | 72 | ||||
| -rw-r--r-- | printf.scm | 21 | ||||
| -rw-r--r-- | priorque.scm | 73 | ||||
| -rw-r--r-- | priorque.txi | 33 | ||||
| -rw-r--r-- | process.scm | 7 | ||||
| -rw-r--r-- | promise.scm | 15 | ||||
| -rw-r--r-- | pscheme.init | 44 | ||||
| -rw-r--r-- | psxtime.scm | 40 | ||||
| -rw-r--r-- | qp.scm | 35 | ||||
| -rw-r--r-- | queue.scm | 77 | ||||
| -rw-r--r-- | queue.txi | 60 | ||||
| -rw-r--r-- | r4rsyn.scm | 2 | ||||
| -rw-r--r-- | randinex.scm | 42 | ||||
| -rw-r--r-- | randinex.txi | 21 | ||||
| -rw-r--r-- | random.scm | 69 | ||||
| -rw-r--r-- | random.txi | 26 | ||||
| -rw-r--r-- | ratize.scm | 43 | ||||
| -rw-r--r-- | ratize.txi | 41 | ||||
| -rw-r--r-- | rdms.scm | 287 | ||||
| -rw-r--r-- | recobj.scm | 11 | ||||
| -rw-r--r-- | record.scm | 27 | ||||
| -rw-r--r-- | repl.scm | 81 | ||||
| -rw-r--r-- | report.scm | 116 | ||||
| -rw-r--r-- | require.scm | 280 | ||||
| -rw-r--r-- | resenecolours.txt | 1410 | ||||
| -rw-r--r-- | root.scm | 14 | ||||
| -rw-r--r-- | s48-0_57.init | 85 | ||||
| -rw-r--r-- | saturate.txt | 39 | ||||
| -rw-r--r-- | sc2.scm | 15 | ||||
| -rw-r--r-- | sc4opt.scm | 17 | ||||
| -rw-r--r-- | sc4sc3.scm | 2 | ||||
| -rw-r--r-- | scainit.scm | 25 | ||||
| -rw-r--r-- | scamacr.scm | 2 | ||||
| -rw-r--r-- | scanf.scm | 514 | ||||
| -rw-r--r-- | scheme2c.init | 70 | ||||
| -rw-r--r-- | scheme48.init | 85 | ||||
| -rw-r--r-- | schmooz.scm | 403 | ||||
| -rw-r--r-- | schmooz.texi | 18 | ||||
| -rw-r--r-- | scm.init | 1 | ||||
| -rw-r--r-- | scmacro.scm | 21 | ||||
| -rw-r--r-- | scsh.init | 63 | ||||
| -rw-r--r-- | selfset.scm | 2 | ||||
| -rw-r--r-- | sierpinski.scm | 2 | ||||
| -rw-r--r-- | simetrix.scm | 5 | ||||
| -rw-r--r-- | slib.info | 10520 | ||||
| -rwxr-xr-x | slib.sh | 119 | ||||
| -rw-r--r-- | slib.spec | 37 | ||||
| -rw-r--r-- | slib.texi | 6464 | ||||
| -rw-r--r-- | solid.scm | 943 | ||||
| -rw-r--r-- | solid.txi | 441 | ||||
| -rw-r--r-- | sort.scm | 251 | ||||
| -rw-r--r-- | soundex.scm | 30 | ||||
| -rw-r--r-- | srfi-1.scm | 230 | ||||
| -rw-r--r-- | srfi-1.txi | 254 | ||||
| -rw-r--r-- | srfi-2.scm | 41 | ||||
| -rw-r--r-- | srfi-2.txi | 8 | ||||
| -rw-r--r-- | srfi-8.scm | 14 | ||||
| -rw-r--r-- | srfi-8.txi | 8 | ||||
| -rw-r--r-- | srfi-9.scm | 16 | ||||
| -rw-r--r-- | srfi.scm | 2 | ||||
| -rw-r--r-- | srfi.txi | 42 | ||||
| -rw-r--r-- | stdio.scm | 5 | ||||
| -rw-r--r-- | strcase.scm | 41 | ||||
| -rw-r--r-- | strport.scm | 6 | ||||
| -rw-r--r-- | strsrch.scm | 164 | ||||
| -rw-r--r-- | structure.scm | 2 | ||||
| -rw-r--r-- | subarray.scm | 172 | ||||
| -rw-r--r-- | subarray.txi | 94 | ||||
| -rw-r--r-- | synchk.scm | 2 | ||||
| -rw-r--r-- | synclo.scm | 12 | ||||
| -rw-r--r-- | synrul.scm | 2 | ||||
| -rw-r--r-- | t3.init | 49 | ||||
| -rw-r--r-- | tek40.scm | 92 | ||||
| -rw-r--r-- | tek41.scm | 147 | ||||
| -rw-r--r-- | timezone.scm | 16 | ||||
| -rw-r--r-- | top-refs.scm | 285 | ||||
| -rw-r--r-- | top-refs.txi | 65 | ||||
| -rw-r--r-- | trace.scm | 24 | ||||
| -rw-r--r-- | transact.scm | 486 | ||||
| -rw-r--r-- | transact.txi | 150 | ||||
| -rw-r--r-- | tree.scm | 69 | ||||
| -rw-r--r-- | tree.txi | 48 | ||||
| -rw-r--r-- | trnscrpt.scm | 18 | ||||
| -rw-r--r-- | tsort.scm | 58 | ||||
| -rw-r--r-- | tsort.txi | 53 | ||||
| -rw-r--r-- | tzfile.scm | 134 | ||||
| -rw-r--r-- | umbscheme.init | 50 | ||||
| -rw-r--r-- | uri.scm | 139 | ||||
| -rw-r--r-- | uri.txi | 87 | ||||
| -rw-r--r-- | values.scm | 4 | ||||
| -rw-r--r-- | version.txi | 4 | ||||
| -rw-r--r-- | vet.scm | 218 | ||||
| -rw-r--r-- | vet.txi | 35 | ||||
| -rw-r--r-- | vscm.init | 66 | ||||
| -rw-r--r-- | withfile.scm | 26 | ||||
| -rw-r--r-- | wttest.scm | 2 | ||||
| -rw-r--r-- | wttree.scm | 6 | ||||
| -rw-r--r-- | yasyn.scm | 253 |
232 files changed, 34336 insertions, 13784 deletions
@@ -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 <jmequin@tif.ti.com> - * gambit.init: (set-case-conversion! #t) - * scheme48.init (defmacro): Defmacro in terms of define-syntax - using defmacro:expand*. - -From Wade Humeniuk <humeniuw@cadvision.com> - * 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. ; @@ -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. ; @@ -1,3 +1,2066 @@ +2003-11-30 Aubrey Jaffer <jaffer@scm.jaffer> + + * require.scm (*SLIB-VERSION*): Bumped from 2d6 to 3a1. + +2003-11-30 Aubrey Jaffer <agj@alum.mit.edu> + + * mklibcat.scm (precedence-parse): defmacro because uses + fluid-let. + +2003-11-29 Aubrey Jaffer <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * array.scm (make-prototype-checker): Added prototype checks. + +2003-11-18 Aubrey Jaffer <agj@alum.mit.edu> + + * charplot.scm: Code cleanup and comments. + +2003-11-17 Aubrey Jaffer <agj@alum.mit.edu> + + * gambit.init (define-macro): Set *defmacros*; macroexpand works! + +2003-11-15 Aubrey Jaffer <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * slib.texi (The Library System): Reorganized. + (Catalog Vicinities): Separated from "Library Catalogs". + +2003-11-08 Aubrey Jaffer <agj@alum.mit.edu> + + * random.scm (seed->random-state): Seed is string, not bytes. + +2003-11-05 Aubrey Jaffer <agj@alum.mit.edu> + + * arraymap.scm (array-map): Added. + +2003-11-02 Aubrey Jaffer <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * rdms.scm (domains:init-data): Simplified. + (slib:error): Replaces alias rdms:error. + +2003-10-31 Aubrey Jaffer <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * slib.texi (Base Table): Description of wb-table and rwb-isam. + + * rdms.scm (isam-prev isam-next): Added. + +2003-10-29 Aubrey Jaffer <agj@alum.mit.edu> + + * slib.texi (Indexed Sequential Access Methods): Added. + (Table Operations): Reorganized subsection into into 6 node tree. + +2003-10-28 Aubrey Jaffer <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * byte.scm (substring-write, substring-read!): Added. + + * random.scm (random:chunk): Changed from using arrays to bytes. + +2003-10-16 Aubrey Jaffer <agj@alum.mit.edu> + + * byte.scm (read-bytes!): Return number of bytes read. + (read-bytes): Shorten returned bytes to number of bytes read. + +2003-10-13 <agj@alum.mit.edu> + + * Makefile (efiles): bytenumb.scm was called out twice. + +2003-10-12 <agj@alum.mit.edu> + + * byte.scm (write-bytes, write-byte, make-bytes): Fixed @args. + +2003-10-09 Aubrey Jaffer <agj@alum.mit.edu> + + * bytenumb.scm (IEEE-byte-decollate!, IEEE-byte-collate!) + (integer-byte-collate!): Return byte-vector. + +2003-10-08 Aubrey Jaffer <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * 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 <ivan@theory.dcn-asu.ru> + + * 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 <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * ncbi-dna.scm (ncbi:read-DNA-sequence): Discard to end of ORIGIN + line (which can have chromosome location). + +2003-09-09 Aubrey Jaffer <agj@alum.mit.edu> + + * matfile.scm (ieee-float->bytes): Added. + + * sort.scm (sort, sort!, sorted?): Generalized to strings. + +2003-08-31 Aubrey Jaffer <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * slib.texi (Relational Infrastructure): Collected internal + details of database operations. + +2003-08-26 Aubrey Jaffer <agj@alum.mit.edu> + + * 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 <inukai.d@jeans.ocn.ne.jp> + + * transact.scm (emacs-lock:certificate): "ls -ld" is more portable + [GNU, FreeBSD, Vine Linux, Debian Linux] than "ls -o". + +2003-08-22 Aubrey Jaffer <agj@alum.mit.edu> + + * dbrowse.scm (browse:display-dir): Keys can be other than strings + or symbols. + +2003-08-18 Aubrey Jaffer <agj@alum.mit.edu> + + * dbutil.scm (create-database): Gracefully return #f when + (not (assq type *base-table-implementations*)). + +2003-08-17 Aubrey Jaffer <agj@alum.mit.edu> + + * pnm.scm (pnm:read+integer): Replaced by READ. + +2003-08-09 Aubrey Jaffer <agj@alum.mit.edu> + + * slib.texi (Basic Operations on Weight-Balanced Trees): wt-tree? + removed because it isn't exported. + +2003-07-25 Aubrey Jaffer <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * slib.texi (Promises): Added delay macro. + +2003-07-17 Aubrey Jaffer <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * require.scm (slib:report-locations): Replace 'implementation + with type and version symbols. + +2003-07-11 Aubrey Jaffer <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * slib.texi (Module Semantics): Added. + +2003-07-06 Aubrey Jaffer <agj@alum.mit.edu> + + * slib.texi (Catalog Creation): Added catalog:read. + + * mklibcat.scm: Use catalog:resolve. + + * require.scm (catalog:resolve, catalog:read): Added. + +2003-07-05 Aubrey Jaffer <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * require.scm (slib:require-if): Added. + (slib:provided?): Accepts expressions with AND, OR, and NOT. + +2003-06-30 Aubrey Jaffer <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * require.scm (*SLIB-VERSION*): Bumped from 2d5 to 2d6. + * array.scm (make-array): Removed legacy procedures. + +2003-06-18 Aubrey Jaffer <agj@alum.mit.edu> + + * differ.scm (diff:order-edits): Interleave inserts and deletes + when adjacent. + +2003-06-16 Aubrey Jaffer <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * differ.scm (diff:mid-split): Replaces diff:best-split. + (diff2ebr): Fixed RR polarity; now works with diff:mid-split. + +2003-06-07 Aubrey Jaffer <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * differ.scm (edits2lcs): Pass in editlen in pursuit of + schlepability. + +2003-05-26 Aubrey Jaffer <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * differ.scm (diff:order-edits): Added; returns correct order. + +2003-05-23 Aubrey Jaffer <agj@alum.mit.edu> + + * differ.scm (edits2lcs): Removed editlen argument. + + * ncbi-dna.scm: Read and manipulate NCBI-format nucleotide + sequences. + +2003-05-12 Aubrey Jaffer <agj@alum.mit.edu> + + * differ.scm (diff2el): Handle all (zero? p-lim) cases. + +2003-05-06 Aubrey Jaffer <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * differ.scm (diff:shave): Removed cdx+1; now cdx. Keep track of + endb in insert loop. + +2003-05-01 Aubrey Jaffer <agj@alum.mit.edu> + + * differ.scm (diff:shave): Also trim matches with decreasing CC + from ends; nets 27% speed. + +2003-04-27 Aubrey Jaffer <agj@alum.mit.edu> + + * guile.init (port?): Had argument name mismatch. + +2003-04-06 Aubrey Jaffer <agj@alum.mit.edu> + + * db2html.scm (command:make-editable-table, command:modify-table): + Improved null-keys treatment to work with multiple primaries. + +2003-04-05 Aubrey Jaffer <agj@alum.mit.edu> + + * qp.scm (qp:qp): Distinguish #f and 0 values for *qp-width*. + +2003-03-30 Aubrey Jaffer <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * differ.scm (fp:compare): Use smaller fp if p-lim supplied. + +2003-03-27 Aubrey Jaffer <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * solid.scm (solid:basrelief): Added VRML ElevationGrid. + (solid:bry): Added "solid FALSE" and missing alternative clause. + +2003-03-23 Aubrey Jaffer <agj@alum.mit.edu> + + * html4each.scm (html-for-each): Rewrote for full quote hair. + Removed require string-search; uses own multi-char version. + +2003-03-16 Aubrey Jaffer <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * slib.texi: Fixed database examples. + + * dbutil.scm (solidify-database): Fixed lock handling. + +2003-03-02 Aubrey Jaffer <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * fhilbert.scm (integer->hilbert-coordinates): Made index + processing symmetrical with hilbert-coordinates->integer. + +2003-01-13 Aubrey Jaffer <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * slib.texi (Plotting): Updated examples. + +2003-01-06 Aubrey Jaffer <agj@alum.mit.edu> + + * fhilbert.scm (hilbert-coordinates->integer) + (integer->hilbert-coordinates): Reference rank now 0 (was 2). + +2003-01-05 Aubrey Jaffer <agj@alum.mit.edu> + + * fhilbert.scm (hilbert-coordinates->integer): Fixed nBits. + (integer->hilbert-coordinates): Simplified. + + * DrScheme.init (defmacro): Restore for mzscheme-202. + +2003-01-05 Ivan Shmakov <ivan@theory.dcn-asu.ru> + + * queue.scm (dequeue-all!): Added. + +2003-01-05 L.J. Buitinck <L.J.Buitinck@student.rug.nl> + + * comlist.scm (comlist:subset?): Added. + +2003-01-04 Aubrey Jaffer <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * batch.scm (*operating-system*): gnu-win32 renamed from cygwin32. + + * slib.texi (String Search): State search order for string-subst. + +2002-12-25 Aubrey Jaffer <agj@alum.mit.edu> + + * 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" <L.J.Buitinck@let.rug.nl> + + * comlist.scm (comlist:union): Make letrec top-level. + +2002-12-17 Aubrey Jaffer <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * batch.scm (*operating-system*): Detect MINGW32 (gcc on MS-DOS) + as CYGWIN. + +2002-12-09 W. Garrett Mitchener <wmitchen@math.princeton.edu> + + * Makefile (catalogs): Make mzscheme new-catalog -g + (case-sensitive) so *SLIB-VERSION* symbol upper-cased. + +2002-12-08 L.J. Buitinck <L.J.Buitinck@let.rug.nl> + + * slib.texi (Destructive list operations): Fixed SOME example. + MAP instead of MAPCAR in nconc example. + +2002-12-06 Aubrey Jaffer <agj@alum.mit.edu> + + * random.scm (random): Streamlined. + (seed->random-state, random:chunk): Replaced BYTE with ARRAY. + +2002-12-05 Aubrey Jaffer <agj@alum.mit.edu> + + * random.scm (random): Don't get extra chunk when modu is integer + multiple of 256. + +2002-12-02 Aubrey Jaffer <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * 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 <jaffer@aubrey.jaffer> + + * require.scm (*SLIB-VERSION*): Bumped from 2d4 to 2d5. + +2002-11-26 dai inukai <inukai.d@jeans.ocn.ne.jp> + + * srfi-1.scm (drop-right, take-right): Were swapped. + +2002-11-26 Aubrey Jaffer <agj@alum.mit.edu> + + * 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 <ivan@theory.dcn-asu.ru> + + * scheme48.init (slib:warn): Match S48-ERROR format. + + * dbsyn.scm (within-database, define-table, define-command): + Added new file. + +2002-11-22 Aubrey Jaffer <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * dirs.scm: Added. + +2002-11-11 Aubrey Jaffer <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * solid.scm (scene:viewpoint): Corrected translation/rotation + order. + +2002-10-14 Aubrey Jaffer <agj@alum.mit.edu> + + * DrScheme.init: Corrected mis-attribution + +2002-10-09 Aubrey Jaffer <ajaffer@r3logic.com> + + * pnm.scm (pnm:read-bit-vector!): Read pbm-raw correctly. + +2002-09-24 Aubrey Jaffer <ajaffer@r3logic.com> + + * pnm.scm (pnm:image-file->array): Correctly handle array type + when max-pixval > 256. + +2002-08-17 Aubrey Jaffer <agj@alum.mit.edu> + + * dbcom.scm (make-command-server): Handle lacking domain-checkers. + +2002-08-14 Aubrey Jaffer <agj@alum.mit.edu> + + * makcrc.scm (make-port-crc): Default based on number-size of + implementation. + +2002-07-22 Aubrey Jaffer <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * differ.scm (diff:divide-and-conquer): Rewrote edit-sequence and + longest common subsequence generation. + +2002-06-28 Aubrey Jaffer <agj@alum.mit.edu> + + * array.scm (create-array): Fixed scales calculation. + +2002-06-23 Aubrey Jaffer <agj@alum.mit.edu> + + * modular.scm (modular:normalize): Test (provided? 'bignum) once. + +2002-06-18 Aubrey Jaffer <agj@alum.mit.edu> + + * differ.scm (fp->lcs): Use argument array type for returned + array. + +2002-06-17 Aubrey Jaffer <agj@alum.mit.edu> + + * slib.texi (Parsing HTML): Added. + +2002-06-09 Aubrey Jaffer <agj@alum.mit.edu> + + * html4each.scm: HTML scan calls procedures for word, tag, + whitespac, and newline. + +2002-05-31 Aubrey Jaffer <agj@alum.mit.edu> + + * nclients.scm (file=?): Added. + +2002-05-30 Aubrey Jaffer <agj@alum.mit.edu> + + * chez.init (*features*): random is not. + +2002-05-28 Aubrey Jaffer <agj@alum.mit.edu> + + * slib.texi (net-clients): Updated. + + * nclients.scm (file-lock-owner, file-lock!, file-unlock!, + system->line): Added. + +2002-05-27 Aubrey Jaffer <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * cvs.scm (cvs:vet): Added CVS structure checker. + +2002-05-09 Aubrey Jaffer <agj@alum.mit.edu> + + * differ.scm (diff:edits): Return array of signed integers. + Broke functions into schlepable chunks; reorganized functions. + +2002-05-08 Aubrey Jaffer <agj@alum.mit.edu> + + * differ.scm (diff:make-differ): Abstracted operations. + +2002-05-06 Aubrey Jaffer <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * htmlform.scm (html:head): Use second argument (backlink) + verbatim if it contains <H1>. + +2002-04-26 Aubrey Jaffer <agj@alum.mit.edu> + + * require.scm (pathname->vicinity): Added. + + * slib.texi (Vicinity): Added pathname->vicinity. + +2002-04-24 Aubrey Jaffer <agj@alum.mit.edu> + + * db2html.scm (db->html-files): Fixed for #f argument DIR. + +2002-04-21 Aubrey Jaffer <agj@alum.mit.edu> + + * mitscheme.init (sort!): Accepts only vectors; set it to SORT. + +2002-04-18 Aubrey Jaffer <agj@alum.mit.edu> + + * http-cgi.scm (make-query-alist-command-server): Don't assume + query-alist is non-false. + +2002-04-18 Chris Hanson <cph@zurich.ai.mit.edu> + + * mitscheme.init (char-code-limit, defmacro, *features*): + Corrected. + +2002-04-17 Aubrey Jaffer <agj@alum.mit.edu> + + * require.scm (software-type): Removed vestigal conversion from + msdos -> ms-dos. + +2002-04-17 Chris Hanson <cph@zurich.ai.mit.edu> + + * mitscheme.init: Updated for versions 7.5 .. 7.7. + +2002-04-14 Aubrey Jaffer <jaffer@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 <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * batch.scm (operating-system): Added plan9. + +2002-03-31 Aubrey Jaffer <agj@alum.mit.edu> + + * colorspc.scm (spectrum->chromaticity, + temperature->chromaticity): Added. + +2002-03-30 Aubrey Jaffer <agj@alum.mit.edu> + + * require.scm (sub-vicinity): Support for PLAN9. + + * nclients.scm (user-email-address, current-directory): PLAN9. + +2002-03-29 Aubrey Jaffer <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * Makefile (docfiles): Added recent schmooz-generated files. + +2002-03-11 Aubrey Jaffer <agj@alum.mit.edu> + + * 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 <Karen.Warman@rpl.co.nz> + + * resenecolours.txt: (Citrine White): Supplied missing value. + (Copyright): Accepted license change to allow modifications. + +2002-03-01 Aubrey Jaffer <agj@alum.mit.edu> + + * db2html.scm (command:make-editable-table): require + database-commands. + + * colornam.scm (load-rgb-txt): Made method names be symbols. + +2002-02-26 Aubrey Jaffer <agj@alum.mit.edu> + + * slib.texi (Lists as sets): Corrected description of MEMBER-IF. + Improved example. + +2002-02-23 Bill Wood <wtw@mathstar.com> + + * 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 <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * 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 <jaffer@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 <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * array.scm (create-array): 1-element fill only. + +2002-01-26 Aubrey Jaffer <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * slib.texi (Input/Output): Open-file MODES argument now symbol. + + * Template.scm, *.init (open-file): Modes argument now symbol. + +2002-01-23 Radey Shouman <Shouman@ne.mediaone.net> + + * subarray.scm (subarray): Trailing indices can now be elided, as + in the rautil.scm version. + +2002-01-22 Aubrey Jaffer <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * 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 <shouman@ne.mediaone.net> + + * 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 <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * colornam.scm (load-rgb-txt): Allows multiple names per color. + Added support for multi-lingual "color_names.txt". + +2002-01-06 Aubrey Jaffer <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * matfile.scm: Added; reads MAT-File Format version 4 (MATLAB). + +2001-12-13 Aubrey Jaffer <agj@alum.mit.edu> + + * scainit.scm (syncase:sanity-check): Had too many ".scm" suffi. + +2001-12-12 Aubrey Jaffer <agj@alum.mit.edu> + + * 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 <ivan@theory.dcn-asu.ru> + + * s48-0_57.init (system): Removed code that set! system to #f. + +2001-12-09 Aubrey Jaffer <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * Makefile ($(dvidir)slib.dvi): Depend on Schmoozed files. + +2001-12-04 Aubrey Jaffer <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * solid.scm (solid:pyramid): Added. + +2001-11-28 Aubrey Jaffer <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * 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 <ivan@theory.dcn-asu.ru> + + * 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 <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * 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<=? + gray-code>? gray-code>=?): Added Gray code functions. + +2001-11-07 Aubrey Jaffer <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * colorspc.scm (XYZ->xyY, xyY->XYZ): Added. + +2001-11-01 Aubrey Jaffer <agj@alum.mit.edu> + + * colorspc.scm (XYZ->chromaticity): Added. + (wavelength->xyz): Added. + +2001-10-31 Aubrey Jaffer <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * cie1931.xyz: Added. + + * color.scm: Reorganized documentation. + + * colorspc.scm (read-ciexyz!, spectrum->xyz): Added. + +2001-10-09 Mikael Djurfeldt <mdj@mdj.nada.kth.se> + + * guile.init (guile:wrap-case-insensitive): Simplified. + +2001-10-07 Aubrey Jaffer <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * strsrch.scm (string-index, string-index-ci, + string-reverse-index, string-reverse-index-ci): Optimized. + +2001-09-23 Aubrey Jaffer <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * array.scm (array-shape): Fixed confusion with array:shape. + +2001-09-12 Aubrey Jaffer <agj@alum.mit.edu> + + * slib.texi (Color Spaces): Documentation for colorspc.scm. + + * tek41.scm, tek40.scm: Removed very old modules not in catalog. + +2001-09-11 Aubrey Jaffer <agj@alum.mit.edu> + + * strcase.scm (StudlyCapsExpand): Added. + +2001-09-09 Aubrey Jaffer <agj@alum.mit.edu> + + * colorspc.scm: Added -- CIE, sRGB, e-sRGB color-space transforms. + + * solid.scm (solid:rotation): Added. + +2001-09-06 Aubrey Jaffer <agj@alum.mit.edu> + + * solid.scm (solid:sphere, solid:spheroid, solid:center-row-of, + solid:center-array-of, solid:center-pile-of): Added. + +2001-09-05 Aubrey Jaffer <agj@alum.mit.edu> + + * solid.scm (solid:color, solid:scale, solid:box): Generalized and + documented. + +2001-09-04 Aubrey Jaffer <agj@alum.mit.edu> + + * 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 <agj@alum.mit.edu> + + * 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 <jaffer@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 <jaffer@ai.mit.edu> 1999-06-05 Radey Shouman <Radey_Shouman@splashtech.com> - * 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 <jaffer@ai.mit.edu> 1999-02-25 Radey Shouman <Radey_Shouman@splashtech.com> * 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 <d93-hyo@nada.kth.se> @@ -913,7 +2976,7 @@ Sun Jan 17 12:33:31 EST 1999 Aubrey Jaffer <jaffer@ai.mit.edu> * 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 <jaffer@jacal.bertronics> Fri Jul 19 11:24:45 1996 Aubrey Jaffer <jaffer@jacal.bertronics> * 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 <jaffer@jacal.bertronics> @@ -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 <frido@q-software-solutions.com> -;; 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 ((string<? (version) "200") + (require-library "init.ss" "slibinit")) + (else + (load (build-path (collection-path "slibinit") "init.ss")) + (eval '(require (lib "defmacro.ss"))) + (slib:provide 'defmacro))) + +;;;The rest corrects mistakes in +;;;/usr/local/lib/plt/collects/slibinit/init.ss: + +(provide 'fluid-let) + +(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 #\ cep) (write x cep)) args)))) + +(define call-with-input-string + (lambda (string thunk) + (parameterize ((current-input-port (open-input-string string))) + (thunk (current-input-port))))) @@ -1,4 +1,4 @@ -FAQ (Frequently Asked Questions and answers) for SLIB Scheme Library (slib2d2). +FAQ (Frequently Asked Questions and answers) for SLIB Scheme Library (slib3a1). Written by Aubrey Jaffer (http://swissnet.ai.mit.edu/~jaffer). INTRODUCTION AND GENERAL INFORMATION @@ -14,9 +14,9 @@ Scheme is a programming language in the Lisp family. [] Which implementations has SLIB been ported to? -SLIB is supported by Bigloo, Chez, DrScheme, ELK, GAMBIT, MacScheme, -MITScheme, PocketScheme, RScheme Scheme->C, 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? @@ -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)" </dev/null; fi + -if type scheme48; then make install48; fi + +MKNMDB = (require 'color-database) (make-slib-color-name-db) (slib:exit) +clrnamdb: clrnamdb.scm +clrnamdb.scm: mkclrnam.scm Makefile + if type scm; then scm -e"$(MKNMDB)";\ + elif type guile; then guile -l guile.init -c\ + "(use-modules (ice-9 slib)) $(MKNMDB)";\ + elif type slib48; then echo -e "$(MKNMDB)\n,exit" | slib48 -h 3000000;\ + elif type umb-scheme; then export SCHEME_INIT=`pwd`/umbscheme.init;\ + echo "$(MKNMDB)" | umb-scheme;\ + elif type mzscheme; then export SCHEME_LIBRARY_PATH=`pwd`/;\ + echo "$(MKNMDB)" | mzscheme -f DrScheme.init;\ + fi slib48: $(IMAGE) $(IMAGE): Makefile scheme48.init export S48_VERSION="`echo ,exit | scheme48 | sed -n 's/Welcome to Scheme 48 //;s/ ([^)]*)[.]//;p;q'`";\ - export S48_VICINITY="$(LIB)/";\ + export S48_VICINITY="$(LIB)";\ export SCHEME_LIBRARY_PATH="`pwd`/";\ scheme48 < scheme48.init install48: $(IMAGE) $(INSTALL_DATA) $(IMAGE) $(LIB) - (echo '#!/bin/sh';\ - echo exec $(RUNNABLE) -i '$(LIB)/$(IMAGE)' \"\$$\@\") \ - > $(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 @@ -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) @@ -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 <port>) +;;@ (OUTPUT-PORT-WIDTH <port>) (define (output-port-width . arg) 79) -;;; (OUTPUT-PORT-HEIGHT <port>) +;;@ (OUTPUT-PORT-HEIGHT <port>) (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? <string>) +;;@ (FILE-EXISTS? <string>) (define (file-exists? f) #f) -;;; (DELETE-FILE <string>) +;;@ (DELETE-FILE <string>) (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 <pathname>) (slib:eval-load <pathname> defmacro:eval)) - +;@ (define (slib:eval-load <pathname> evl) (if (not (file-exists? <pathname>)) (set! <pathname> (string-append <pathname> (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")) @@ -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) @@ -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 @@ -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) @@ -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))) @@ -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{string<?} ordering of big-endian byte-array +;;representations of fixed and IEEE floating-point numbers agrees with +;;the numerical ordering only when those numbers are non-negative. +;; +;;@noindent +;;Straighforward modification of these formats can extend the +;;byte-collating order to work for their entire ranges. This +;;agreement enables the full range of numbers as keys in +;;@dfn{indexed-sequential-access-method} databases. + +;;@body +;;Modifies sign bit of @1 so that @code{string<?} ordering of +;;two's-complement byte-vectors matches numerical order. @0 returns +;;@1 and is its own functional inverse. +(define (integer-byte-collate! byte-vector) + (byte-set! byte-vector 0 (logxor #x80 (byte-ref byte-vector 0))) + byte-vector) + +;;@body +;;Returns copy of @1 with sign bit modified so that @code{string<?} +;;ordering of two's-complement byte-vectors matches numerical order. +;;@0 is its own functional inverse. +(define (integer-byte-collate byte-vector) + (integer-byte-collate! (bytes-copy byte-vector))) + +;;@body +;;Modifies @1 so that @code{string<?} ordering of IEEE floating-point +;;byte-vectors matches numerical order. @0 returns @1. +(define (IEEE-byte-collate! byte-vector) + (cond ((logtest #x80 (byte-ref byte-vector 0)) + (do ((idx (+ -1 (bytes-length byte-vector)) (+ -1 idx))) + ((negative? idx)) + (byte-set! byte-vector idx + (logxor #xFF (byte-ref byte-vector idx))))) + (else + (byte-set! byte-vector 0 (logxor #x80 (byte-ref byte-vector 0))))) + byte-vector) +;;@body +;;Given @1 modified by @code{IEEE-byte-collate!}, reverses the @1 +;;modifications. +(define (IEEE-byte-decollate! byte-vector) + (cond ((not (logtest #x80 (byte-ref byte-vector 0))) + (do ((idx (+ -1 (bytes-length byte-vector)) (+ -1 idx))) + ((negative? idx)) + (byte-set! byte-vector idx + (logxor #xFF (byte-ref byte-vector idx))))) + (else + (byte-set! byte-vector 0 (logxor #x80 (byte-ref byte-vector 0))))) + byte-vector) + +;;@body +;;Returns copy of @1 encoded so that @code{string<?} ordering of IEEE +;;floating-point byte-vectors matches numerical order. +(define (IEEE-byte-collate byte-vector) + (IEEE-byte-collate! (bytes-copy byte-vector))) +;;@body +;;Given @1 returned by @code{IEEE-byte-collate}, reverses the @1 +;;modifications. +(define (IEEE-byte-decollate byte-vector) + (IEEE-byte-decollate! (bytes-copy byte-vector))) diff --git a/bytenumb.txi b/bytenumb.txi new file mode 100644 index 0000000..67c340b --- /dev/null +++ b/bytenumb.txi @@ -0,0 +1,181 @@ +@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. + + +@defun bytes->integer 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<?} ordering of big-endian byte-array +representations of fixed and IEEE floating-point numbers agrees with +the numerical ordering only when those numbers are non-negative. + +@noindent +Straighforward modification of these formats can extend the +byte-collating order to work for their entire ranges. This +agreement enables the full range of numbers as keys in +@dfn{indexed-sequential-access-method} databases. +@cindex indexed-sequential-access-method + + +@deffn {Procedure} integer-byte-collate! byte-vector + +Modifies sign bit of @var{byte-vector} so that @code{string<?} ordering of +two's-complement byte-vectors matches numerical order. @code{integer-byte-collate!} returns +@var{byte-vector} and is its own functional inverse. +@end deffn + +@defun integer-byte-collate byte-vector + +Returns copy of @var{byte-vector} with sign bit modified so that @code{string<?} +ordering of two's-complement byte-vectors matches numerical order. +@code{integer-byte-collate} is its own functional inverse. +@end defun + +@deffn {Procedure} ieee-byte-collate! byte-vector + +Modifies @var{byte-vector} so that @code{string<?} ordering of IEEE floating-point +byte-vectors matches numerical order. @code{ieee-byte-collate!} returns @var{byte-vector}. +@end deffn + +@deffn {Procedure} ieee-byte-decollate! byte-vector + +Given @var{byte-vector} modified by @code{IEEE-byte-collate!}, reverses the @var{byte-vector} +modifications. +@end deffn + +@defun ieee-byte-collate byte-vector + +Returns copy of @var{byte-vector} encoded so that @code{string<?} ordering of IEEE +floating-point byte-vectors matches numerical order. +@end defun + +@defun ieee-byte-decollate byte-vector + +Given @var{byte-vector} returned by @code{IEEE-byte-collate}, reverses the @var{byte-vector} +modifications. +@end defun @@ -1,5 +1,5 @@ ;;;; "chap.scm" Chapter ordering -*-scheme-*- -;;; Copyright 1992, 1993, 1994 Aubrey Jaffer +;;; Copyright 1992, 1993, 1994, 2003 Aubrey Jaffer ; ;Permission to copy this software, to modify it, to redistribute it, ;to distribute modified versions, and to use it for any purpose is @@ -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,6 +22,27 @@ ;;; section of the string consists of consecutive numeric or ;;; consecutive aphabetic characters. + +;;@code{(require 'chapter-order)} +;;@ftindex chapter-order +;; +;;The @samp{chap:} functions deal with strings which are ordered like +;;chapter numbers (or letters) in a book. Each section of the string +;;consists of consecutive numeric or consecutive aphabetic characters of +;;like case. + +;;@args string1 string2 +;;Returns #t if the first non-matching run of alphabetic upper-case or +;;the first non-matching run of alphabetic lower-case or the first +;;non-matching run of numeric characters of @var{string1} is +;;@code{string<?} than the corresponding non-matching run of +;;characters of @var{string2}. +;; +;;@example +;;(chap:string<? "a.9" "a.10") @result{} #t +;;(chap:string<? "4c" "4aa") @result{} #t +;;(chap:string<? "Revised^@{3.99@}" "Revised^@{4@}") @result{} #t +;;@end example (define (chap:string<? s1 s2) (let ((l1 (string-length s1)) (l2 (string-length s2))) @@ -78,6 +99,11 @@ (length-race (+ 1 i) ctype1 (char<? c1 c2))) (else (char<? c1 c2))))))) (delimited 0))) +;;@body +;;Implement the corresponding chapter-order predicates. +(define (chap:string>? string1 string2) (chap:string<? string2 string1)) +(define (chap:string<=? string1 string2) (not (chap:string<? string2 string1))) +(define (chap:string>=? string1 string2) (not (chap:string<? string1 string2))) (define chap:char-incr (- (char->integer #\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<?} than the result. +;; +;;@example +;;(chap:next-string "a.9") @result{} "a.10" +;;(chap:next-string "4c") @result{} "4d" +;;(chap:next-string "4z") @result{} "4aa" +;;(chap:next-string "Revised^@{4@}") @result{} "Revised^@{5@}" +;; +;;@end example (define (chap:next-string s) (do ((i (+ -1 (string-length s)) (+ -1 i))) ((or (negative? i) @@ -144,7 +183,3 @@ ; (display " > ") ; (display s2) ; (newline))))) - -(define (chap:string>? s1 s2) (chap:string<? s2 s1)) -(define (chap:string>=? s1 s2) (not (chap:string<? s1 s2))) -(define (chap:string<=? s1 s2) (not (chap:string<? s2 s1))) diff --git a/chap.txi b/chap.txi new file mode 100644 index 0000000..514decd --- /dev/null +++ b/chap.txi @@ -0,0 +1,46 @@ +@code{(require 'chapter-order)} +@ftindex chapter-order + +The @samp{chap:} functions deal with strings which are ordered like +chapter numbers (or letters) in a book. Each section of the string +consists of consecutive numeric or consecutive aphabetic characters of +like case. + + +@defun chap:string<? string1 string2 + +Returns #t if the first non-matching run of alphabetic upper-case or +the first non-matching run of alphabetic lower-case or the first +non-matching run of numeric characters of @var{string1} is +@code{string<?} than the corresponding non-matching run of +characters of @var{string2}. + +@example +(chap:string<? "a.9" "a.10") @result{} #t +(chap:string<? "4c" "4aa") @result{} #t +(chap:string<? "Revised^@{3.99@}" "Revised^@{4@}") @result{} #t +@end example +@end defun + +@defun chap:string>? string1 string2 +@defunx chap:string<=? string1 string2 +@defunx chap:string>=? string1 string2 + +Implement the corresponding chapter-order predicates. +@end defun + +@defun chap:next-string string + +Returns the next string in the @emph{chapter order}. If @var{string} +has no alphabetic or numeric characters, +@code{(string-append @var{string} "0")} is returnd. The argument to +chap:next-string will always be @code{chap:string<?} than the result. + +@example +(chap:next-string "a.9") @result{} "a.10" +(chap:next-string "4c") @result{} "4d" +(chap:next-string "4z") @result{} "4aa" +(chap:next-string "Revised^@{4@}") @result{} "Revised^@{5@}" + +@end example +@end defun diff --git a/charplot.scm b/charplot.scm index 3e0e019..890fca0 100644 --- a/charplot.scm +++ b/charplot.scm @@ -1,5 +1,5 @@ ;;;; "charplot.scm", plotting on character devices for Scheme -;;; Copyright (C) 1992, 1993 Aubrey Jaffer +;;; Copyright (C) 1992, 1993, 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. ; @@ -17,155 +17,283 @@ ;promotional, or sales literature without prior written consent in ;each case. -(require 'sort) (require 'printf) (require 'array) (require 'array-for-each) +(require 'multiarg/and-) -(define charplot:rows 24) -(define charplot:columns (output-port-width (current-output-port))) +;;;@ These determine final graph size. +(define charplot:dimensions #f) -(define charplot:xborder #\_) -(define charplot:yborder #\|) -(define charplot:xaxchar #\-) -(define charplot:yaxchar #\:) -(define charplot:curve1 #\*) -(define charplot:xtick #\.) +;;; The left margin and legends +(define charplot:left-margin 12) -(define charplot:height (- charplot:rows 5)) -(define charplot:width (- charplot:columns 15)) +(define char:xborder #\_) +(define char:yborder #\|) +(define char:xaxis #\-) +(define char:yaxis #\:) +(define char:xtick #\.) +(define char:bar #\I) +(define char:curves "*+x@#$%&='") -(define (charplot:printn! n char) - (cond ((positive? n) - (write-char char) - (charplot:printn! (+ n -1) char)))) +;;;Converts X to a string whose length is at most MWID. +(define (charplot:number->string 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))) @@ -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 <port>) 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 <port>) 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 @@ -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) @@ -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 <collection>) ;; return element generator +;@ +(define (empty? collection) (zero? (collect:size collection))) +;@ +(define-operation (gen-elts <collection>) ;; return element generator ;; default behavior (cond ;; see utilities, below, for generators ((vector? <collection>) (collect:vector-gen-elts <collection>)) ((list? <collection>) (collect:list-gen-elts <collection>)) ((string? <collection>) (collect:string-gen-elts <collection>)) (else - (slib:error "Operation not supported: GEN-ELTS " (yasos:print obj #f))) + (slib:error 'gen-elts 'operation-not-supported + (collect:print <collection> #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 <proc> . <collections>) - (let ( (max+1 (yasos:size (car <collections>))) +;@ +(define (do-elts <proc> . <collections>) + (let ( (max+1 (collect:size (car <collections>))) (generators (map collect:gen-elts <collections>)) ) (let loop ( (counter 0) ) @@ -56,9 +62,9 @@ (else 'unspecific) ; done ) ) ) ) - -(define (collect:do-keys <proc> . <collections>) - (let ( (max+1 (yasos:size (car <collections>))) +;@ +(define (do-keys <proc> . <collections>) + (let ( (max+1 (collect:size (car <collections>))) (generators (map collect:gen-keys <collections>)) ) (let loop ( (counter 0) ) @@ -70,11 +76,11 @@ (else 'unspecific) ; done ) ) ) ) - -(define (collect:map-elts <proc> . <collections>) - (let ( (max+1 (yasos:size (car <collections>))) +;@ +(define (map-elts <proc> . <collections>) + (let ( (max+1 (collect:size (car <collections>))) (generators (map collect:gen-elts <collections>)) - (vec (make-vector (yasos:size (car <collections>)))) + (vec (make-vector (collect:size (car <collections>)))) ) (let loop ( (index 0) ) (cond @@ -85,11 +91,11 @@ (else vec) ; done ) ) ) ) - -(define (collect:map-keys <proc> . <collections>) - (let ( (max+1 (yasos:size (car <collections>))) +;@ +(define (map-keys <proc> . <collections>) + (let ( (max+1 (collect:size (car <collections>))) (generators (map collect:gen-keys <collections>)) - (vec (make-vector (yasos:size (car <collections>)))) + (vec (make-vector (collect:size (car <collections>)))) ) (let loop ( (index 0) ) (cond @@ -100,18 +106,18 @@ (else vec) ; done ) ) ) ) - -(define-operation (collect:for-each-key <collection> <proc>) +;@ +(define-operation (for-each-key <collection> <proc>) ;; default (collect:do-keys <proc> <collection>) ;; talk about lazy! ) - -(define-operation (collect:for-each-elt <collection> <proc>) +;@ +(define-operation (for-each-elt <collection> <proc>) (collect:do-elts <proc> <collection>) ) - -(define (collect:reduce <proc> <seed> . <collections>) - (let ( (max+1 (yasos:size (car <collections>))) +;@ +(define (reduce <proc> <seed> . <collections>) + (let ( (max+1 (collect:size (car <collections>))) (generators (map collect:gen-elts <collections>)) ) (let loop ( (count 0) ) @@ -127,9 +133,9 @@ -;; pred true for every elt? -(define (collect:every? <pred?> . <collections>) - (let ( (max+1 (yasos:size (car <collections>))) +;;@ pred true for every elt? +(define (every? <pred?> . <collections>) + (let ( (max+1 (collect:size (car <collections>))) (generators (map collect:gen-elts <collections>)) ) (let loop ( (count 0) ) @@ -143,9 +149,9 @@ ) ) ) ) -;; pred true for any elt? -(define (collect:any? <pred?> . <collections>) - (let ( (max+1 (yasos:size (car <collections>))) +;;@ pred true for any elt? +(define (any? <pred?> . <collections>) + (let ( (max+1 (collect:size (car <collections>))) (generators (map collect:gen-elts <collections>)) ) (let loop ( (count 0) ) @@ -191,7 +197,7 @@ (define (collect:list-gen-elts <list>) (lambda () (if (null? <list>) - (slib:error "No more list elements in generator") + (slib:error 'no-more 'list-elements 'in 'generator) (let ( (elt (car <list>)) ) (set! <list> (cdr <list>)) elt)) @@ -200,7 +206,7 @@ ;; generator for vector elements (define (collect:make-vec-gen-elts <accessor>) (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 (<collection>!2) + (cond ((vector? <collection>!2) + (collect:vector-gen-elts <collection>!2)) + ((list? <collection>!2) + (collect:list-gen-elts <collection>!2)) + ((string? <collection>!2) + (collect:string-gen-elts <collection>!2)) + (else + (slib:error + 'gen-elts + 'operation-not-supported + (collect:print <collection>!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 (<proc>!1 . <collections>!1) + (let ((max+1!2 (collect:size (car <collections>!1))) + (generators!2 + (map collect:gen-elts <collections>!1))) + (let loop!4 ((counter!3 0)) + (cond ((< counter!3 max+1!2) + (apply <proc>!1 + (map (lambda (g!5) (g!5)) generators!2)) + (loop!4 (collect:add1 counter!3))) + (else 'unspecific)))))) +;@ +(define do-keys + (lambda (<proc>!1 . <collections>!1) + (let ((max+1!2 (collect:size (car <collections>!1))) + (generators!2 + (map collect:gen-keys <collections>!1))) + (let loop!4 ((counter!3 0)) + (cond ((< counter!3 max+1!2) + (apply <proc>!1 + (map (lambda (g!5) (g!5)) generators!2)) + (loop!4 (collect:add1 counter!3))) + (else 'unspecific)))))) +;@ +(define map-elts + (lambda (<proc>!1 . <collections>!1) + (let ((max+1!2 (collect:size (car <collections>!1))) + (generators!2 + (map collect:gen-elts <collections>!1)) + (vec!2 (make-vector + (collect:size (car <collections>!1))))) + (let loop!4 ((index!3 0)) + (cond ((< index!3 max+1!2) + (vector-set! + vec!2 + index!3 + (apply <proc>!1 + (map (lambda (g!5) (g!5)) generators!2))) + (loop!4 (collect:add1 index!3))) + (else vec!2)))))) +;@ +(define map-keys + (lambda (<proc>!1 . <collections>!1) + (let ((max+1!2 (collect:size (car <collections>!1))) + (generators!2 + (map collect:gen-keys <collections>!1)) + (vec!2 (make-vector + (collect:size (car <collections>!1))))) + (let loop!4 ((index!3 0)) + (cond ((< index!3 max+1!2) + (vector-set! + vec!2 + index!3 + (apply <proc>!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 (<collection>!2 <proc>!2) + (collect:do-keys <proc>!2 <collection>!2)))) +;@ +(define for-each-elt + (make-generic-method + (lambda (<collection>!2 <proc>!2) + (collect:do-elts <proc>!2 <collection>!2)))) +;@ +(define reduce + (lambda (<proc>!1 <seed>!1 . <collections>!1) + (let ((max+1!2 (collect:size (car <collections>!1))) + (generators!2 + (map collect:gen-elts <collections>!1))) + (let loop!4 ((count!3 0)) + (cond ((< count!3 max+1!2) + (set! <seed>!1 + (apply <proc>!1 + <seed>!1 + (map (lambda (g!5) (g!5)) generators!2))) + (loop!4 (collect:add1 count!3))) + (else <seed>!1)))))) + + + +;;@ pred true for every elt? +(define every? + (lambda (<pred?>!1 . <collections>!1) + (let ((max+1!2 (collect:size (car <collections>!1))) + (generators!2 + (map collect:gen-elts <collections>!1))) + (let loop!4 ((count!3 0)) + (cond ((< count!3 max+1!2) + (if (apply <pred?>!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 (<pred?>!1 . <collections>!1) + (let ((max+1!2 (collect:size (car <collections>!1))) + (generators!2 + (map collect:gen-elts <collections>!1))) + (let loop!4 ((count!3 0)) + (cond ((< count!3 max+1!2) + (if (apply <pred?>!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 (<list>!1 <index>!1 <value>!1) + (letrec ((set-loop!3 + (lambda (last!4 this!4 idx!4) + (cond ((zero? idx!4) + (set-cdr! last!4 (cons <value>!1 (cdr this!4))) + <list>!1) + (else + (set-loop!3 + (cdr last!4) + (cdr this!4) + (collect:sub1 idx!4))))))) + (if (zero? <index>!1) + (cons <value>!1 (cdr <list>!1)) + (set-loop!3 + <list>!1 + (cdr <list>!1) + (collect:sub1 <index>!1)))))) + +(add-setter list-ref collect:list-set!) + ; for (setter list-ref) + + +;; generator for list elements +(define collect:list-gen-elts + (lambda (<list>!1) + (lambda () + (if (null? <list>!1) + (slib:error + 'no-more + 'list-elements + 'in + 'generator) + (let ((elt!3 (car <list>!1))) + (begin (set! <list>!1 (cdr <list>!1)) elt!3)))))) + +;; generator for vector elements +(define collect:make-vec-gen-elts + (lambda (<accessor>!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)) + (<accessor>!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{<k>}. +(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{<k>}. +@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 <walters@cis.ohio-state.edu> ;;; 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 @@ -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))))))) @@ -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 @@ -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")) @@ -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 <ivan@theory.dcn-asu.ru> +;; +;; 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 ...))))) @@ -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{<name>} @r{<descriptor-name>} @r{<descriptor-name>} @r{<rows>}) +;;@end lisp +;;or +;;@lisp +;;(@r{<name>} @r{<primary-key-fields>} @r{<other-fields>} @r{<rows>}) +;;@end lisp +;; +;;where @r{<name>} is the table name, @r{<descriptor-name>} is the symbol +;;name of a descriptor table, @r{<primary-key-fields>} and +;;@r{<other-fields>} describe the primary keys and other fields +;;respectively, and @r{<rows>} is a list of data rows to be added to the +;;table. +;; +;;@r{<primary-key-fields>} and @r{<other-fields>} are lists of field +;;descriptors of the form: +;; +;;@lisp +;;(@r{<column-name>} @r{<domain>}) +;;@end lisp +;;or +;;@lisp +;;(@r{<column-name>} @r{<domain>} @r{<column-integrity-rule>}) +;;@end lisp +;; +;;where @r{<column-name>} is the column name, @r{<domain>} is the domain +;;of the column, and @r{<column-integrity-rule>} is an expression whose +;;value is a procedure of one argument (which returns @code{#f} to signal +;;an error). +;; +;;If @r{<domain>} 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{<name>} @r{<descriptor-name>} @r{<descriptor-name>} @r{<rows>}) +@end lisp +or +@lisp +(@r{<name>} @r{<primary-key-fields>} @r{<other-fields>} @r{<rows>}) +@end lisp + +where @r{<name>} is the table name, @r{<descriptor-name>} is the symbol +name of a descriptor table, @r{<primary-key-fields>} and +@r{<other-fields>} describe the primary keys and other fields +respectively, and @r{<rows>} is a list of data rows to be added to the +table. + +@r{<primary-key-fields>} and @r{<other-fields>} are lists of field +descriptors of the form: + +@lisp +(@r{<column-name>} @r{<domain>}) +@end lisp +or +@lisp +(@r{<column-name>} @r{<domain>} @r{<column-integrity-rule>}) +@end lisp + +where @r{<column-name>} is the column name, @r{<domain>} is the domain +of the column, and @r{<column-integrity-rule>} is an expression whose +value is a procedure of one argument (which returns @code{#f} to signal +an error). + +If @r{<domain>} 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 @@ -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))) @@ -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 @@ -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, <A HREF="http://www.cs.arizona.edu/people/gene/vita.html"> +E. Myers,</A> U. Manber, and W. Miller, +<A HREF="http://www.cs.arizona.edu/people/gene/PAPERS/np_diff.ps"> +"An O(NP) Sequence Comparison Algorithm,"</A> +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 <thunk1> <thunk2> <thunk3>) (<thunk1>) (set! dynamic:winds (cons (cons <thunk1> <thunk3>) dynamic:winds)) @@ -49,7 +49,7 @@ (set! dynamic:winds (cdr dynamic:winds)) (<thunk3>) ans)) - +;@ (define call-with-current-continuation (let ((oldcc call-with-current-continuation)) (lambda (proc) @@ -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 (<pathname> . 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 (<pathname> . 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")) @@ -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) @@ -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) @@ -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 @@ -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{~}<newline> -Continuation Line. -@table @asis -@item @code{~:}<newline> -newline is ignored, white space left. -@item @code{~@@}<newline> -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 <c|3>") -(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)) "<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 <b> c <d> e <f> 10") -(test '("~{ ~a ~^<~a>~} ~a" (a b c d e) 10) " a <b> c <d> 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 <string>) @@ -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) @@ -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=<number> +;; -n, --nary=<symbols> ... +;; -N, --nary1=<symbols> ... +;; -s, --single=<string> +;; --Flag +;; -B +;; -a <num2> ... +;; --Abs=<num3> ... +;; +;;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=<number> + -n, --nary=<symbols> ... + -N, --nary1=<symbols> ... + -s, --single=<string> + --Flag + -B + -a <num2> ... + --Abs=<num3> ... + +ERROR: getopt->parameter-list "unrecognized option" "-?" +@end example @@ -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 @@ -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 (string<? (version) "1.6") + (define-module (ice-9 slib))) ; :no-backtrace +(define slib-module (current-module)) +(define (defined? symbol) (module-defined? slib-module symbol)) + +(define base:define define) +(define define + (procedure->memoizing-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 <port>) +(define (output-port-width . arg) 79) + +;;; (OUTPUT-PORT-HEIGHT <port>) +(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? <string>) +;;(define (file-exists? f) #f) + +;;; (DELETE-FILE <string>) +;;(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<? (scheme-implementation-version) "1.5") + eval + (let ((ie (interaction-environment))) + (lambda (expression) + (eval expression ie))))) + +;;; Define SLIB:EXIT to be the implementation procedure to exit or +;;; return if exitting not supported. +(define slib:exit quit) + +;;; Here for backward compatability +;;(define scheme-file-suffix +;; (let ((suffix (case (software-type) +;; ((NOSVE) "_scm") +;; (else ".scm")))) +;; (lambda () suffix))) + +(define (slib:eval-load <pathname> evl) + (if (not (file-exists? <pathname>)) + (set! <pathname> (string-append <pathname> (scheme-file-suffix)))) + (call-with-input-file <pathname> + (lambda (port) + (let ((old-load-pathname *load-pathname*)) + (set! *load-pathname* <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 (<pathname>) + (load-file (string-append <pathname> (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")) @@ -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=? "<!--" (substring line idx (+ 4 idx)))) + "-->" #\>))) + (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? "<title" str) + (set! capturing? #t)) + ((prefix-ci? "</title" str) + (return (and (not (null? text)) + (apply string-append + (reverse (cdr text)))))) + ((or (prefix-ci? "</head" str) + (prefix-ci? "<body" str)) + (return #f)))) + cnt + cnt) + #f)))))) + +(define (prefix-ci? pre str) + (define prelen (string-length pre)) + (and (< prelen (string-length str)) + (string-ci=? pre (substring str 0 prelen)))) + +;;@body +;;@1 is a hypertext markup string. +;; +;;If @1 is a (hypertext) comment, then @0 returns #f. +;;Otherwise @0 returns the hypertext element symbol (created by +;;@code{string-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? "<!--" (substring htm 0 4)))) + (call-with-input-string htm + (lambda (port) + (define element #f) + (define fields '()) + (cond ((not (eqv? 1 (fscanf port "<%s" element))) + (slib:error 'htm-fields 'strange htm))) + (let loop ((chr (peek-char port))) + (define name #f) + (define junk #f) + (define value #t) + (cond + ((eof-object? chr) (slib:warn 'htm-fields 'missing '> htm) + (reverse fields)) + ((eqv? #\> chr) (cons element (reverse fields))) + ((char-whitespace? chr) (read-char port) (loop (peek-char port))) + ((case (fscanf port "%[a-zA-Z0-9]%[=]%[-.a-zA-Z0-9]" name junk value) + ((3 1) #t) + ((2) + (case (peek-char port) + ((#\") (eqv? 1 (fscanf port "\"%[^\"]\"" value))) + ((#\') (eqv? 1 (fscanf port "'%[^']'" value))) + (else #f))) + (else #f)) + (set! fields (cons (cons (string-ci->symbol name) + (or (string->number value) value)) + fields)) + (loop (peek-char port))) + (else (slib:warn 'htm-fields 'bad 'field htm) (reverse fields)))))))) diff --git a/html4each.txi b/html4each.txi new file mode 100644 index 0000000..d331b25 --- /dev/null +++ b/html4each.txi @@ -0,0 +1,70 @@ +@code{(require 'html-for-each)} +@ftindex html-for-each + + +@defun html-for-each file word-proc markup-proc white-proc newline-proc + +@var{file} is an input port or a string naming an existing file containing +HTML text. +@var{word-proc} is a procedure of one argument or #f. +@var{markup-proc} is a procedure of one argument or #f. +@var{white-proc} is a procedure of one argument or #f. +@var{newline-proc} is a procedure of no arguments or #f. + +@code{html-for-each} opens and reads characters from port @var{file} or the file named by +string @var{file}. 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 @var{file}. + +@var{newline-proc} is called with no arguments for end-of-line @emph{not within a +markup or comment}. + +@var{white-proc} is called with strings of non-newline whitespace. + +@var{markup-proc} is called with hypertext markup strings (including @samp{<} and +@samp{>}). + +@var{word-proc} is called with the remaining strings. + +@code{html-for-each} returns an unspecified value. +@end defun + +@defun html:read-title file limit + + +@defunx html:read-title file +@var{file} is an input port or a string naming an existing file containing +HTML text. If supplied, @var{limit} must be an integer. @var{limit} defaults to +1000. + +@code{html:read-title} opens and reads HTML from port @var{file} or the file named by string @var{file}, +until reaching the (mandatory) @samp{TITLE} field. @code{html:read-title} returns the +title string with adjacent whitespaces collapsed to one space. @code{html:read-title} +returns #f if the title field is empty, absent, if the first +character read from @var{file} is not @samp{#\<}, or if the end of title is +not found within the first (approximately) @var{limit} words. +@end defun + +@defun htm-fields htm + +@var{htm} is a hypertext markup string. + +If @var{htm} is a (hypertext) comment, then @code{htm-fields} returns #f. +Otherwise @code{htm-fields} returns the hypertext element symbol (created by +@code{string-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. +@end defun diff --git a/htmlform.scm b/htmlform.scm index 935e006..d659aeb 100644 --- a/htmlform.scm +++ b/htmlform.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,11 +22,12 @@ (require 'parameters) (require 'object->string) (require 'string-search) -(require 'database-utilities) +(require 'databases) (require 'common-list-functions) ;;;;@code{(require 'html-form)} ;;@ftindex html-form + (define html:blank (string->symbol "")) ;;@body Returns a string with character substitutions appropriate to @@ -60,7 +61,7 @@ ;;@samp{author}, @samp{copyright}, @samp{keywords}, @samp{description}, ;;@samp{date}, @samp{robots}, @dots{}. (define (html:meta name content) - (sprintf #f "\n<META NAME=\"%s\" CONTENT=\"%s\">" name (html:atval content))) + (sprintf #f "\\n<META NAME=\"%s\" CONTENT=\"%s\">" name (html:atval content))) ;;@body Returns a tag of HTTP information suitable for passing as the ;;third argument to @code{html:head}. The tag produced is @samp{<META @@ -68,7 +69,7 @@ ;;@samp{Expires}, @samp{PICS-Label}, @samp{Content-Type}, ;;@samp{Refresh}, @dots{}. (define (html:http-equiv name content) - (sprintf #f "\n<META HTTP-EQUIV=\"%s\" CONTENT=\"%s\">" + (sprintf #f "\\n<META HTTP-EQUIV=\"%s\" CONTENT=\"%s\">" name (html:atval content))) ;;@args delay uri @@ -81,8 +82,8 @@ ;;this tag, Netscape or IE browsers will fetch and redisplay this page. (define (html:meta-refresh delay . uri) (if (null? uri) - (sprintf #f "\n<META HTTP-EQUIV=\"Refresh\" CONTENT=\"%d\">" delay) - (sprintf #f "\n<META HTTP-EQUIV=\"Refresh\" CONTENT=\"%d;URL=%s\">" + (sprintf #f "\\n<META HTTP-EQUIV=\"Refresh\" CONTENT=\"%d\">" delay) + (sprintf #f "\\n<META HTTP-EQUIV=\"Refresh\" CONTENT=\"%d;URL=%s\">" delay (car uri)))) ;;@args title backlink tags ... @@ -101,10 +102,12 @@ (sprintf #f "<HTML>\\n") (sprintf #f "%s" (html:comment "HTML by SLIB" - "http://swissnet.ai.mit.edu/~jaffer/SLIB.html")) + "http://swissnet.ai.mit.edu/~jaffer/SLIB")) (sprintf #f " <HEAD>\\n <TITLE>%s</TITLE>\\n %s\\n </HEAD>\\n" (html:plain title) (apply string-append args)) - (sprintf #f "<BODY><H1>%s</H1>\\n" (or backlink (html:plain title))))) + (if (and backlink (substring-ci? "<H1>" backlink)) + backlink + (sprintf #f "<BODY><H1>%s</H1>\\n" (or backlink (html:plain title)))))) ;;@body Returns HTML string to end a page. (define (html:body . body) @@ -217,7 +220,7 @@ (let ((value-list (map car foreign-values)) (visibles (map cadr foreign-values))) (string-append - (sprintf #f "<SELECT NAME=%#a SIZE=%d%s>" + (sprintf #f "<SELECT NAME=%#a SIZE=%d%s>\\n" (html:atval pname) (case arity ((single optional) 1) @@ -227,7 +230,7 @@ (else ""))) (apply string-append (map (lambda (value visible) - (sprintf #f "<OPTION VALUE=%#a%s>%s" + (sprintf #f "<OPTION VALUE=%#a%s>%s\\n" (html:atval value) (if (member value default-list) " SELECTED" "") (html:plain visible))) @@ -297,11 +300,6 @@ ;;@body Returns a string which generates a @dfn{reset} button. (define (form:reset) "<INPUT TYPE=RESET>") -(define (html:delimited-list . rows) - (apply string-append - "<DL>" - (append rows '("</DL>")))) - ;;@body Returns a string which generates an INPUT element for the field ;;named @1. The element appears in the created form with its ;;representation determined by its @2 and domain. For domains which @@ -363,11 +361,33 @@ (remove-if (lambda (s) (= 1 (string-length s))) (cdr aliat))) (set! longname (if (null? longname) #f (car longname))) (if longname - (string-append - "<DT>" (html:strong-doc longname doc) "<DD>" - (form:element pname arity default-list foreign-values)) + (sprintf #f "<DT>%s\\n<DD>%s\\n" + (html:strong-doc longname doc) + (form:element pname arity default-list foreign-values)) "")) +;;@body Wraps its arguments with delimited-list (@samp{DL} command. +(define (html:delimited-list . rows) + (apply string-append + "<DL>" + (append rows '("</DL>")))) + +;;;used by command:make-editable-table in db2html.scm; +;;; and by command->p-specs in htmlform.scm. +;;@body Returns a list of the @samp{visible-name} or first fields of +;;table @1. +(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))) + ;;@body ;; ;;The symbol @2 names a command table in the @1 relational database. @@ -389,16 +409,16 @@ ;; (html:head 'commands) ;; (html:body ;; (sprintf #f "<H2>%s:</H2><BLOCKQUOTE>%s</BLOCKQUOTE>\\n" -;; (html:plain 'build) -;; (html:plain ((comtab 'get 'documentation) 'build))) +;; (html:plain 'build) +;; (html:plain ((comtab 'get 'documentation) 'build))) ;; (html:form -;; 'post -;; (or "http://localhost:8081/buildscm" "/cgi-bin/build.cgi") -;; (apply html:delimited-list -;; (apply map form:delimited -;; (command->p-specs build '*commands* 'build))) -;; (form:submit 'build) -;; (form:reset)))) +;; 'post +;; (or "http://localhost:8081/buildscm" "/cgi-bin/build.cgi") +;; (apply html:delimited-list +;; (apply map form:delimited +;; (command->p-specs build '*commands* 'build))) +;; (form:submit 'build) +;; (form:reset)))) ;; port))) ;;@end example (define (command->p-specs rdb command-table command) diff --git a/htmlform.txi b/htmlform.txi index ffa0665..e960984 100644 --- a/htmlform.txi +++ b/htmlform.txi @@ -168,6 +168,15 @@ delimited list. Apply map @code{form:delimited} to the list returned by @code{command->p-specs}. @end defun +@defun html:delimited-list row @dots{} +Wraps its arguments with delimited-list (@samp{DL} command. +@end defun + +@defun get-foreign-choices tab +Returns a list of the @samp{visible-name} or first fields of +table @var{tab}. +@end defun + @defun command->p-specs rdb command-table command @@ -190,16 +199,16 @@ command. (html:head 'commands) (html:body (sprintf #f "<H2>%s:</H2><BLOCKQUOTE>%s</BLOCKQUOTE>\\n" - (html:plain 'build) - (html:plain ((comtab 'get 'documentation) 'build))) + (html:plain 'build) + (html:plain ((comtab 'get 'documentation) 'build))) (html:form - 'post - (or "http://localhost:8081/buildscm" "/cgi-bin/build.cgi") - (apply html:delimited-list - (apply map form:delimited - (command->p-specs build '*commands* 'build))) - (form:submit 'build) - (form:reset)))) + 'post + (or "http://localhost:8081/buildscm" "/cgi-bin/build.cgi") + (apply html:delimited-list + (apply map form:delimited + (command->p-specs build '*commands* 'build))) + (form:submit 'build) + (form:reset)))) port))) @end example @end defun diff --git a/http-cgi.scm b/http-cgi.scm index 02aade3..517e312 100644 --- a/http-cgi.scm +++ b/http-cgi.scm @@ -1,5 +1,5 @@ ;;; "http-cgi.scm" service HTTP or CGI requests. -*-scheme-*- -; Copyright 1997, 1998, 2000, 2001 Aubrey Jaffer +; Copyright 1997, 1998, 2000, 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. ; @@ -25,6 +25,10 @@ (require 'html-form) (require 'parameters) (require 'string-case) +(require 'string-port) +(require 'string-search) +(require 'database-commands) +(require 'common-list-functions) ; position ;;@code{(require 'http)} or @code{(require 'cgi)} ;;@ftindex http @@ -342,22 +346,20 @@ reply)))) (define (coerce->list str type) - (case type - ((expression) - (slib:warn 'coerce->list 'unsafe 'read) - (do ((tok (read port) (read port)) - (lst '() (cons tok lst))) - ((or (null? tok) (eof-object? tok)) lst))) - ((symbol) - (call-with-input-string str - (lambda (port) + (call-with-input-string str + (lambda (port) + (case type + ((expression) + (slib:warn 'coerce->list 'unsafe 'read) + (do ((tok (read port) (read port)) + (lst '() (cons tok lst))) + ((or (null? tok) (eof-object? tok)) lst))) + ((symbol) (do ((tok (scanf-read-list " %s" port) (scanf-read-list " %s" port)) (lst '() (cons (string-ci->symbol (car tok)) lst))) - ((or (null? tok) (eof-object? tok)) lst))))) - (else - (call-with-input-string str - (lambda (port) + ((or (null? tok) (eof-object? tok)) lst))) + (else (do ((tok (scanf-read-list " %s" port) (scanf-read-list " %s" port)) (lst '() (cons (coerce (car tok) type) lst))) @@ -411,7 +413,7 @@ (define comnam #f) (define find-command? (lambda (cname) - (define tryp (parameter-list-ref query-alist cname)) + (define tryp (and query-alist (parameter-list-ref query-alist cname))) (cond ((not tryp) #f) (comnam (set! query-alist (remove-parameter cname query-alist))) @@ -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,7 @@ ;promotional, or sales literature without prior written consent in ;each case. +(require-if 'compiling 'filename) ;;@args ;;@args port @@ -63,20 +64,25 @@ ;;Writes @1 followed by a newline 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-input-port}.@refill +;;@code{current-input-port}. (define (write-line str . port) (apply display str port) (apply newline port)) -;;@args path -;;@args path port -;;Displays the contents of the file named by @1 to @var{port}. The -;;@var{port} argument may be ommited, in which case it defaults to the -;;value returned by @code{current-output-port}. -(define (display-file path . port) - (set! port (if (null? port) (current-output-port) (car port))) - (call-with-input-file path - (lambda (inport) - (do ((line (read-line inport) (read-line inport))) - ((eof-object? line)) - (write-line line port))))) +;;@args command tmp +;;@args command +;;@1 must be a string. The string @2, if supplied, is a path to use as +;;a temporary file. @0 calls @code{system} with @1 as argument, +;;redirecting stdout to file @2. @0 returns a string containing the +;;first line of output from @2. +(define (system->line command . tmp) + (require 'filename) + (cond ((null? tmp) + (call-with-tmpnam + (lambda (tmp) (system->line command tmp)))) + (else + (set! tmp (car tmp)) + (and (zero? (system (string-append command " > " tmp))) + (file-exists? tmp) + (let ((line (call-with-input-file tmp read-line))) + (if (eof-object? line) "" line)))))) @@ -11,10 +11,10 @@ omitted, in which case it defaults to the value returned by @code{current-input-port}. @end defun -@defun read-line! string +@deffn {Procedure} read-line! string -@defunx read-line! string port +@deffnx {Procedure} read-line! string port Fills @var{string} with characters up to, but not including a newline or end of file, updating the @var{port} to point to the last character read or following the newline if it was read. If no characters are @@ -23,7 +23,7 @@ of file was found, the number of characters read is returned. Otherwise, @code{#f} is returned. The @var{port} argument may be omitted, in which case it defaults to the value returned by @code{current-input-port}. -@end defun +@end deffn @defun write-line string @@ -32,14 +32,15 @@ omitted, in which case it defaults to the value returned by Writes @var{string} followed by a newline 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-input-port}.@refill +@code{current-input-port}. @end defun -@defun display-file path +@defun system->line command tmp -@defunx display-file path port -Displays the contents of the file named by @var{path} to @var{port}. The -@var{port} argument may be ommited, in which case it defaults to the -value returned by @code{current-output-port}. +@defunx system->line command +@var{command} must be a string. The string @var{tmp}, if supplied, is a path to use as +a temporary file. @code{system->line} calls @code{system} with @var{command} as argument, +redirecting stdout to file @var{tmp}. @code{system->line} returns a string containing the +first line of output from @var{tmp}. @end defun diff --git a/logical.scm b/logical.scm index 963202f..90808e6 100644 --- a/logical.scm +++ b/logical.scm @@ -1,5 +1,5 @@ ;;;; "logical.scm", bit access and operations for integers for Scheme -;;; Copyright (C) 1991, 1993 Aubrey Jaffer +;;; Copyright (C) 1991, 1993, 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. ; @@ -17,103 +17,19 @@ ;promotional, or sales literature without prior written consent in ;each case. -(define logical:integer-expt +;@ +(define integer-expt (if (provided? 'inexact) expt (lambda (n k) - (logical:ipow-by-squaring n k 1 *)))) - -(define (logical:ipow-by-squaring x k acc proc) - (cond ((zero? k) acc) - ((= 1 k) (proc acc x)) - (else (logical:ipow-by-squaring (proc x x) - (quotient k 2) - (if (even? k) acc (proc acc x)) - proc)))) - -(define (logical:logand n1 n2) - (cond ((= n1 n2) n1) - ((zero? n1) 0) - ((zero? n2) 0) - (else - (+ (* (logical:logand (logical:ash-4 n1) (logical:ash-4 n2)) 16) - (vector-ref (vector-ref logical:boole-and (modulo n1 16)) - (modulo n2 16)))))) - -(define (logical:logior n1 n2) - (cond ((= n1 n2) n1) - ((zero? n1) n2) - ((zero? n2) n1) - (else - (+ (* (logical:logior (logical:ash-4 n1) (logical:ash-4 n2)) 16) - (- 15 (vector-ref (vector-ref logical:boole-and - (- 15 (modulo n1 16))) - (- 15 (modulo n2 16)))))))) - -(define (logical:logxor n1 n2) - (cond ((= n1 n2) 0) - ((zero? n1) n2) - ((zero? n2) n1) - (else - (+ (* (logical:logxor (logical:ash-4 n1) (logical:ash-4 n2)) 16) - (vector-ref (vector-ref logical:boole-xor (modulo n1 16)) - (modulo n2 16)))))) - -(define (logical:lognot n) (- -1 n)) - -(define (logical:logtest int1 int2) - (not (zero? (logical:logand int1 int2)))) - -(define (logical:logbit? index int) - (logical:logtest (logical:integer-expt 2 index) int)) - -(define (logical:copy-bit index to bool) - (if bool - (logical:logior to (logical:ash 1 index)) - (logical:logand to (logical:lognot (logical:ash 1 index))))) - -(define (logical:bit-field n start end) - (logical:logand (- (logical:integer-expt 2 (- end start)) 1) - (logical:ash n (- start)))) - -(define (logical:bitwise-if mask n0 n1) - (logical:logior (logical:logand mask n0) - (logical:logand (logical:lognot mask) n1))) - -(define (logical: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 (logical:ash int cnt) - (if (negative? cnt) - (let ((n (logical:integer-expt 2 (- cnt)))) - (if (negative? int) - (+ -1 (quotient (+ 1 int) n)) - (quotient int n))) - (* (logical:integer-expt 2 cnt) int))) - -(define (logical:ash-4 x) - (if (negative? x) - (+ -1 (quotient (+ 1 x) 16)) - (quotient x 16))) - -(define (logical:logcount n) - (cond ((zero? n) 0) - ((negative? n) (logical:logcount (logical:lognot n))) - (else - (+ (logical:logcount (logical:ash-4 n)) - (vector-ref '#(0 1 1 2 1 2 2 3 1 2 2 3 2 3 3 4) - (modulo n 16)))))) - -(define (logical:integer-length n) - (case n - ((0 -1) 0) - ((1 -2) 1) - ((2 3 -3 -4) 2) - ((4 5 6 7 -5 -6 -7 -8) 3) - (else (+ 4 (logical:integer-length (logical:ash-4 n)))))) + (do ((x n (* x x)) + (j k (quotient j 2)) + (acc 1 (if (even? j) acc (* x acc)))) + ((<= j 1) + (case j + ((0) acc) + ((1) (* x acc)) + (else (slib:error 'integer-expt n k)))))))) (define logical:boole-xor '#(#(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15) @@ -151,18 +67,215 @@ #(0 0 2 2 4 4 6 6 8 8 10 10 12 12 14 14) #(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15))) -(define logand logical:logand) -(define logior logical:logior) -(define logxor logical:logxor) -(define lognot logical:lognot) -(define logtest logical:logtest) -(define logbit? logical:logbit?) -(define copy-bit logical:copy-bit) -(define ash logical:ash) -(define logcount logical:logcount) -(define integer-length logical:integer-length) -(define bit-field logical:bit-field) -(define bit-extract logical:bit-field) -(define copy-bit-field logical:copy-bit-field) -(define ipow-by-squaring logical:ipow-by-squaring) -(define integer-expt logical:integer-expt) +(define (logical:ash-4 x) + (if (negative? x) + (+ -1 (quotient (+ 1 x) 16)) + (quotient x 16))) +;@ +(define logand + (letrec + ((lgand + (lambda (n2 n1 scl acc) + (cond ((= n1 n2) (+ acc (* scl n1))) + ((zero? n2) acc) + ((zero? n1) acc) + (else (lgand (logical:ash-4 n2) + (logical:ash-4 n1) + (* 16 scl) + (+ (* (vector-ref (vector-ref logical:boole-and + (modulo n1 16)) + (modulo n2 16)) + scl) + acc))))))) + (lambda (n1 n2) (lgand n2 n1 1 0)))) +;@ +(define logior + (letrec + ((lgior + (lambda (n2 n1 scl acc) + (cond ((= n1 n2) (+ acc (* scl n1))) + ((zero? n2) (+ acc (* scl n1))) + ((zero? n1) (+ acc (* scl n2))) + (else (lgior (logical:ash-4 n2) + (logical:ash-4 n1) + (* 16 scl) + (+ (* (- 15 (vector-ref + (vector-ref logical:boole-and + (- 15 (modulo n1 16))) + (- 15 (modulo n2 16)))) + scl) + acc))))))) + (lambda (n1 n2) (lgior n2 n1 1 0)))) +;@ +(define logxor + (letrec + ((lgxor + (lambda (n2 n1 scl acc) + (cond ((= n1 n2) acc) + ((zero? n2) (+ acc (* scl n1))) + ((zero? n1) (+ acc (* scl n2))) + (else (lgxor (logical:ash-4 n2) + (logical:ash-4 n1) + (* 16 scl) + (+ (* (vector-ref (vector-ref logical:boole-xor + (modulo n1 16)) + (modulo n2 16)) + scl) + acc))))))) + (lambda (n1 n2) (lgxor n2 n1 1 0)))) +;@ +(define (lognot n) (- -1 n)) +;@ +(define (logtest n1 n2) + (not (zero? (logical:logand n1 n2)))) +;@ +(define (logbit? index n) + (logical:logtest (logical:integer-expt 2 index) n)) +;@ +(define (copy-bit index to bool) + (if bool + (logical:logior to (logical:ash 1 index)) + (logical:logand to (logical:lognot (logical:ash 1 index))))) + +;;@ This procedure is careful not to use more than DEG bits in +;; computing (- (expt 2 DEG) 1) +(define (logical:ones deg) + (if (zero? deg) 0 (+ (* 2 (+ -1 (logical:integer-expt 2 (- deg 1)))) 1))) +;@ +(define (bit-field n start end) + (logical:logand (logical:ones (- end start)) + (logical:ash n (- start)))) +;@ +(define (bitwise-if mask n0 n1) + (logical:logior (logical:logand mask n0) + (logical:logand (logical:lognot mask) n1))) +;@ +(define (copy-bit-field to start end from) + (logical:bitwise-if (logical:ash (logical:ones (- end start)) start) + (logical:ash from start) + to)) +;@ +(define (ash n count) + (if (negative? count) + (let ((k (logical:integer-expt 2 (- count)))) + (if (negative? n) + (+ -1 (quotient (+ 1 n) k)) + (quotient n k))) + (* (logical:integer-expt 2 count) n))) +;@ +(define integer-length + (letrec ((intlen (lambda (n tot) + (case n + ((0 -1) (+ 0 tot)) + ((1 -2) (+ 1 tot)) + ((2 3 -3 -4) (+ 2 tot)) + ((4 5 6 7 -5 -6 -7 -8) (+ 3 tot)) + (else (intlen (logical:ash-4 n) (+ 4 tot))))))) + (lambda (n) (intlen n 0)))) +;@ +(define logcount + (letrec ((logcnt (lambda (n tot) + (if (zero? n) + tot + (logcnt (quotient n 16) + (+ (vector-ref + '#(0 1 1 2 1 2 2 3 1 2 2 3 2 3 3 4) + (modulo n 16)) + tot)))))) + (lambda (n) + (cond ((negative? n) (logcnt (logical:lognot n) 0)) + ((positive? n) (logcnt n 0)) + (else 0))))) + +;;;; Bit order and lamination +;@ +(define (logical:rotate k count len) + (set! count (modulo count len)) + (logical:logior (logical:logand (ash k count) (logical:ones len)) + (logical:ash k (- count len)))) +;@ +(define (bit-reverse k n) + (do ((m (if (negative? n) (lognot n) n) (ash m -1)) + (k (+ -1 k) (+ -1 k)) + (rvs 0 (logior (ash rvs 1) (logand 1 m)))) + ((negative? k) (if (negative? n) (lognot rvs) rvs)))) +;@ +(define (integer->list k . len) + (if (null? len) + (do ((k k (ash k -1)) + (lst '() (cons (odd? k) lst))) + ((<= k 0) lst)) + (do ((idx (+ -1 (car len)) (+ -1 idx)) + (k k (ash k -1)) + (lst '() (cons (odd? k) lst))) + ((negative? idx) lst)))) +;@ +(define (list->integer bools) + (do ((bs bools (cdr bs)) + (acc 0 (+ acc acc (if (car bs) 1 0)))) + ((null? bs) acc))) +(define (booleans->integer . bools) + (list->integer bools)) +;@ +(define (bitwise:laminate . ks) + (define nks (length ks)) + (define nbs (apply max (map integer-length ks))) + (do ((kdx (+ -1 nbs) (+ -1 kdx)) + (ibs 0 (+ (list->integer (map (lambda (k) (logbit? kdx k)) ks)) + (ash ibs nks)))) + ((negative? kdx) ibs))) +;@ +(define (bitwise:delaminate count k) + (define nbs (* count (+ 1 (quotient (integer-length k) count)))) + (do ((kdx (- nbs count) (- kdx count)) + (lst (vector->list (make-vector count 0)) + (map (lambda (k bool) (+ (if bool 1 0) (ash k 1))) + lst + (integer->list (ash k (- kdx)) count)))) + ((negative? kdx) lst))) + +;;;; Gray-code +;@ +(define (integer->gray-code k) + (logxor k (ash k -1))) +;@ +(define (gray-code->integer k) + (if (negative? k) + (slib:error 'gray-code->integer 'negative? k) + (let ((kln (integer-length k))) + (do ((d 1 (* d 2)) + (ans (logxor k (ash k -1)) ; == (integer->gray-code k) + (logxor ans (ash ans (* d -2))))) + ((>= (* 2 d) kln) ans))))) + +(define (grayter k1 k2) + (define kl1 (integer-length k1)) + (define kl2 (integer-length k2)) + (if (eqv? kl1 kl2) + (> (gray-code->integer k1) (gray-code->integer k2)) + (> kl1 kl2))) +;@ +(define (gray-code<? k1 k2) + (not (or (eqv? k1 k2) (grayter k1 k2)))) +(define (gray-code<=? k1 k2) + (or (eqv? k1 k2) (not (grayter k1 k2)))) +(define (gray-code>? k1 k2) + (and (not (eqv? k1 k2)) (grayter k1 k2))) +(define (gray-code>=? k1 k2) + (or (eqv? k1 k2) (grayter k1 k2))) + +(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 logical:copy-bit copy-bit) +(define logical:ash ash) +;;(define logical:logcount logcount) +;;(define logical:integer-length integer-length) +;;(define logical:bit-field bit-field) +;;(define bit-extract bit-field) +(define logical:bitwise-if bitwise-if) +;;(define logical:copy-bit-field copy-bit-field) +(define logical:integer-expt integer-expt) diff --git a/macscheme.init b/macscheme.init index 72d9259..152d456 100644 --- a/macscheme.init +++ b/macscheme.init @@ -7,45 +7,37 @@ ;;; (software-type) should be set to the generic operating system type. ;;; UNIX, VMS, MACOS, AMIGA and MS-DOS are supported. - (define (software-type) 'MACOS) ;;; (scheme-implementation-type) should return the name of the scheme ;;; implementation loading this file. - (define (scheme-implementation-type) 'MacScheme) ;;; (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 ;;; the version the scheme implementation loading this file. - (define (scheme-implementation-version) "4.2") ;;; (implementation-vicinity) should be defined to be the pathname of ;;; the directory where any auxillary files to your Scheme ;;; implementation reside. - (define (implementation-vicinity) "Macintosh.HD:MacScheme 4.2:") ;;; (library-vicinity) should be defined to be the pathname of the ;;; directory where files of Scheme library functions reside. - (define (library-vicinity) "Macintosh.HD:MacScheme 4.2:slib:") ;;; (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) ;;; *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 @@ -55,7 +47,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 @@ -69,11 +61,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!, @@ -84,7 +76,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 @@ -158,6 +150,33 @@ (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) + (slib:warn "define BROWSE-URL in macscheme.init")) + ;;; "rationalize" adjunct procedures. (define (find-ratio x e) (let ((rat (rationalize x e))) @@ -236,7 +255,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 @@ -279,11 +298,9 @@ ;;; (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:load (in-vicinity (library-vicinity) "require")) diff --git a/macwork.scm b/macwork.scm index 6336ae5..2a6a93d 100644 --- a/macwork.scm +++ b/macwork.scm @@ -10,6 +10,12 @@ ; make to this software so that they may be incorporated within it to ; the benefit of the Scheme community. +(require 'common-list-functions) + +(define mw:every every) +(define mw:union union) +(define mw:remove-if-not remove-if-not) + (slib:load (in-vicinity (program-vicinity) "mwexpand")) ;;;; Miscellaneous routines. @@ -58,8 +64,6 @@ (else -1))) (loop x 0)) -(require 'common-list-functions) - ; Given an association list, copies the association pairs. (define (mw:syntax-copy alist) @@ -103,21 +107,21 @@ ; by the compiler. Any other character that cannot appear as part of an ; identifier may be used instead of the vertical bar. -(define mw:suffix-character #\|) +(define mw:suffix-character #\!) (slib:load (in-vicinity (program-vicinity) "mwdenote")) (slib:load (in-vicinity (program-vicinity) "mwsynrul")) - +;@ (define macro:expand macwork:expand) ;;; Here are EVAL, EVAL! and LOAD which expand macros. You can replace the ;;; implementation's eval and load with them if you like. (define base:eval slib:eval) -(define base:load load) - +;;(define base:load load) +;@ (define (macwork:eval x) (base:eval (macwork:expand x))) (define macro:eval macwork:eval) - +;@ (define (macwork:load <pathname>) (slib:eval-load <pathname> macwork:eval)) (define macro:load macwork:load) diff --git a/makcrc.scm b/makcrc.scm deleted file mode 100644 index debd5c9..0000000 --- a/makcrc.scm +++ /dev/null @@ -1,96 +0,0 @@ -;;;; "makcrc.scm" Compute Cyclic Checksums -;;; Copyright (C) 1995, 1996, 1997, 2001 Aubrey Jaffer -; -;Permission to copy this software, to modify it, to redistribute it, -;to distribute modified versions, and to use it for any purpose is -;granted, subject to the following restrictions and understandings. -; -;1. Any copy made of this software must include this copyright notice -;in full. -; -;2. I have made no warrantee 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 (make-port-crc . margs) - (define (make-mask hibit) - (+ (ash (+ -1 (ash 1 (+ 1 (- hibit 2)))) 1) 1)) - (define chunk-bits (integer-length (+ -1 char-code-limit))) - (define accum-bits #f) - (define generator #f) - (case (length margs) - ((0) #t) - ((1) (if (< (car margs) 128) - (set! accum-bits (car margs)) - (set! generator (car margs)))) - ((2) - (set! accum-bits (car margs)) - (set! generator (cadr margs))) - (else (slib:error 'make-port-crc 'args margs))) - (cond ((not generator) - (case accum-bits - ((#f 32) (set! accum-bits 32) - (set! generator #b00000100110000010001110110110111)) ; CRC-32 - ((16) (set! generator #b0001000000001011)) ; CRC-16 - ;;((16) (set! generator #b0001000000100001)) ; CRC-CCIT - ;;((08) (set! generator #b101011)) - (else (slib:error 'make-port-crc "no default polynomial for" - accum-bits "bits")))) - ((not accum-bits) - (set! accum-bits (+ -1 (integer-length generator))))) - (set! generator (logand generator (lognot (ash 1 accum-bits)))) - (cond ((>= (integer-length generator) accum-bits) - (slib:error 'make-port-crc - "generator longer than" accum-bits "bits"))) - (let* ((chunk-mask (make-mask chunk-bits)) - (crctab (make-vector (+ 1 chunk-mask)))) - (define (accum src) - `(set! - crc - (logxor (ash (logand ,(make-mask (- accum-bits chunk-bits)) crc) - ,chunk-bits) - (vector-ref crctab - (logand ,chunk-mask - (logxor - (ash crc ,(- chunk-bits accum-bits)) - ,src)))))) - (define (make-crc-table) - (letrec ((r (make-vector chunk-bits)) - (remd (lambda (m) - (define rem 0) - (do ((i 0 (+ 1 i))) - ((>= i chunk-bits) rem) - (if (logbit? i m) - (set! rem (logxor rem (vector-ref r i)))))))) - (vector-set! r 0 generator) - (do ((i 1 (+ 1 i))) - ((>= i chunk-bits)) - (let ((r-1 (vector-ref r (+ -1 i))) - (m-1 (make-mask (+ -1 accum-bits)))) - (vector-set! r i (if (logbit? (+ -1 accum-bits) r-1) - (logxor (ash (logand m-1 r-1) 1) generator) - (ash (logand m-1 r-1) 1))))) - (do ((i 0 (+ 1 i))) - ((> i chunk-mask)) - (vector-set! crctab i (remd i))))) - (make-crc-table) - `(lambda (port) - (define crc 0) - (define byte-count 0) - (define crctab ',crctab) - (do ((ci (read-byte port) (read-byte port))) - ((eof-object? ci)) - ,(accum 'ci) - (set! byte-count (+ 1 byte-count))) - (do ((byte-count byte-count (ash byte-count ,(- chunk-bits)))) - ((zero? byte-count)) - ,(accum 'byte-count)) - (logxor ,(make-mask accum-bits) crc)))) diff --git a/manifest.scm b/manifest.scm new file mode 100644 index 0000000..77d6f1b --- /dev/null +++ b/manifest.scm @@ -0,0 +1,350 @@ +;"manifest.scm" List SLIB module requires and exports. +;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 'line-i/o) + +;;@code{(require 'manifest)} +;;@ftindex manifest + +;;@noindent +;;In some of these examples, @var{slib:catalog} is the SLIB part of +;;the catalog; it is free of compiled and implementation-specific +;;entries. It would be defined by: +;; +;;@example +;;(define slib:catalog (cdr (member (assq 'null *catalog*) *catalog*))) +;;@end example + +;;@body +;;Returns a list of the features @code{require}d by @1 assuming the +;;predicate @2 and association-list @3. +(define (file->requires file provided? catalog) + (call-with-input-file file + (lambda (port) + (define requires '()) + (define (add-require feature) + (if (and (not (provided? (cadr feature))) + (not (assq (cadr feature) catalog))) + (slib:warn file 'unknown 'feature feature)) + (if (not (memq (cadr feature) requires)) + (set! requires (cons (cadr feature) requires)))) + (let loop ((sexp (read port))) + (cond ((or (eof-object? sexp) (not (pair? sexp)) (not (list? sexp))) + (reverse requires)) + (else + (case (car sexp) + ((require) + (cond ((not (= 2 (length sexp))) + (slib:warn 'bad 'require sexp)) + (else (add-require (cadr sexp)))) + (loop (read port))) + ((require-if) + (cond ((not (= 3 (length sexp))) + (slib:warn 'bad 'require-if sexp)) + ((not (and (pair? (cadr sexp)) + (list? (cadr sexp)) + (eq? 'quote (caadr sexp)))) + (slib:warn + 'file->requires 'unquoted 'feature)) + ((feature-eval + (cadadr sexp) + (lambda (expression) + (if (provided? expression) #t + (let ((path (cdr (or (assq expression catalog) + '(#f . #f))))) + (cond ((symbol? path) (provided? path)) + (else #f)))))) + (add-require (caddr sexp)))) + (loop (read port))) + (else (reverse requires))))))))) +;;@example +;;(define (provided+? . features) +;; (lambda (feature) +;; (or (memq feature features) (provided? feature)))) +;; +;;(file->requires "obj2str.scm" (provided+? 'compiling) '()) +;; @result{} (string-port generic-write) +;; +;;(file->requires "obj2str.scm" provided? '()) +;; @result{} (string-port) +;;@end example + +;;@body +;;Returns a list of the features @code{require}d by @1 assuming the +;;predicate @2 and association-list @3. +(define (feature->requires feature provided? catalog) + (define (f2r feature) + (define path (cdr (or (assq feature catalog) '(#f . #f)))) + (define (return path) + (file->requires (string-append path (scheme-file-suffix)) + provided? catalog)) + (cond ((not path) #f) + ((string? path) + (return path)) + ((not (pair? path)) + (slib:error feature 'path? path)) + (else (case (car path) + ((source defmacro macro-by-example macro macros-that-work + syntax-case syntactic-closures) + (return (if (pair? (cdr path)) + (cadr path) + (cdr path)))) + ((compiled) (list feature)) + ((aggregate) + (apply append (map f2r (cdr path)))) + (else (slib:error feature 'feature? path)))))) + (f2r feature)) +;;@example +;;(feature->requires 'batch (provided+? 'compiling) *catalog*) +;; @result{} (tree line-i/o databases parameters string-port +;; pretty-print common-list-functions posix-time) +;; +;;(feature->requires 'batch provided? *catalog*) +;; @result{} (tree line-i/o databases parameters string-port +;; pretty-print common-list-functions) +;; +;;(feature->requires 'batch provided? '((batch . "batch"))) +;; @result{} (tree line-i/o databases parameters string-port +;; pretty-print common-list-functions) +;;@end example + +;;@body +;;Returns a list of strings naming existing files loaded (load +;;slib:load slib:load-source macro:load defmacro:load syncase:load +;;synclo:load macwork:load) by @1 or any of the files it loads. +(define (file->loads file) + (define loads '()) + (define (f2l file) + (call-with-input-file file + (lambda (port) + (define (sxp o) + (cond ((eof-object? o)) + ((not (list? o))) + ((< (length o) 2)) + ((memq (car o) '(load slib:load slib:load-source macro:load + defmacro:load syncase:load synclo:load + macwork:load)) + (let ((path (load->path (cadr o)))) + (cond ((not (member path loads)) + (set! loads (cons path loads)) + (f2l path))) + (sxp (read port)))) + ((eq? 'begin (car o)) (for-each sxp (cdr o))) + (else (sxp (read port))))) + (let ((old-load-pathname *load-pathname*)) + (set! *load-pathname* file) + (sxp (read port)) + (set! *load-pathname* old-load-pathname) + loads)))) + (f2l file)) +;;@example +;;(file->loads (in-vicinity (library-vicinity) "scainit.scm")) +;; @result{} ("/usr/local/lib/slib/scaexpp.scm" +;; "/usr/local/lib/slib/scaglob.scm" +;; "/usr/local/lib/slib/scaoutp.scm") +;;@end example + +;;@body +;;Given a @code{(load '<expr>)}, where <expr> is a string or vicinity +;;stuff), @code{(load->path <expr>)} figures a path to the file. +;;@0 returns that path if it names an existing file; otherwise #f. +(define (load->path exp) + (define (cwv vicproc exp) + (let ((a1 (cwp (cadr exp))) + (a2 (cwp (caddr exp)))) + (if (and (string? a1) (string? a2)) (vicproc a1 a2) exp))) + (define (cwp exp) + (cond ((string? exp) exp) + ((not (pair? exp)) ;(slib:warn 'load->path 'strange 'feature exp) + exp) + (else (case (car exp) + ((program-vicinity) (program-vicinity)) + ((library-vicinity) (library-vicinity)) + ((implementation-vicinity) (implementation-vicinity)) + ((user-vicinity) (user-vicinity)) + ((in-vicinity) (cwv in-vicinity exp)) + ((sub-vicinity) (cwv sub-vicinity exp)) + (else (slib:eval exp)))))) + (let ((ans (cwp exp))) + (if (and (string? ans) (file-exists? (string-append ans ".scm"))) + (string-append ans ".scm") + ans))) +;;@example +;;(load->path '(in-vicinity (library-vicinity) "mklibcat")) +;; @result{} "/usr/local/lib/slib/mklibcat.scm" +;;@end example + +;;@body +;;Returns a list of the identifier symbols defined by SLIB (or +;;SLIB-style) file @1. +(define (file->definitions file) + (call-with-input-file file + (lambda (port) + (define defs '()) + (define (sxp o) + (cond ((eof-object? o)) + ((not (list? o))) + ((< (length o) 2)) + ((eq? 'begin (car o)) (for-each sxp (cdr o))) + ((< (length o) 3)) + ((not (memq (car o) + '(define-operation define define-syntax defmacro)))) + ((symbol? (cadr o)) (set! defs (cons (cadr o) defs))) + ((not (pair? (cadr o)))) + ((not (symbol? (caadr o)))) + (else (set! defs (cons (caadr o) defs)))) + (cond ((eof-object? o) defs) + (else (sxp (read port))))) + (let ((old-load-pathname *load-pathname*)) + (set! *load-pathname* file) + (sxp (read port)) + (set! *load-pathname* old-load-pathname) + defs)))) +;;@example +;;(file->definitions "random.scm") +;; @result{} (*random-state* make-random-state +;; seed->random-state copy-random-state random +;; random:chunk) +;;@end example + +;;@body +;;Returns a list of the identifier symbols exported (advertised) by +;;SLIB (or SLIB-style) file @1. +(define (file->exports file) + (call-with-input-file file + (lambda (port) + (define exports '()) + (define seen-at? #f) + (define (top) + (define c (peek-char port)) + (cond ((eof-object? c)) + ((char=? #\newline c) + (read-line port) + (set! seen-at? #f) + (top)) + ((char-whitespace? c) + (read-char port) + (top)) + ((char=? #\; c) + (read-char port) + (cmt)) + (else (sxp (read port)) + (if (char-whitespace? (peek-char port)) (read-char port)) + (top)))) + (define (cmt) + (define c (peek-char port)) + (cond ((eof-object? c)) + ((char=? #\; c) + (read-char port) + (cmt)) + ((char=? #\@ c) + (set! seen-at? #t) + (read-line port) + (top)) + (else + (read-line port) + (top)))) + (define (sxp o) + (cond ((eof-object? o)) + ((not seen-at?)) + ((not (list? o))) + ((< (length o) 2)) + ((eq? 'begin (car o)) (for-each sxp (cdr o))) + ((< (length o) 3)) + ((not (memq (car o) '(define define-syntax defmacro)))) + ((symbol? (cadr o)) (set! exports (cons (cadr o) exports))) + ((not (pair? (cadr o)))) + ((not (symbol? (caadr o)))) + (else (set! exports (cons (caadr o) exports))))) + (let ((old-load-pathname *load-pathname*)) + (set! *load-pathname* file) + (top) + (set! *load-pathname* old-load-pathname) + exports)))) +;;@example +;;(file->exports "random.scm") +;; @result{} (make-random-state seed->random-state +;; copy-random-state random) +;; +;;(file->exports "randinex.scm") +;; @result{} (random:solid-sphere! random:hollow-sphere! +;; random:normal-vector! random:normal +;; random:exp random:uniform) +;;@end example + +;;@body +;;Returns a list of lists; each sublist holding the name of the file +;;implementing @1, and the identifier symbols exported (advertised) by +;;SLIB (or SLIB-style) feature @1, in @2. +(define (feature->export-alist feature catalog) + (define (f2e feature) + (define path (cdr (or (assq feature catalog) '(#f . #f)))) + (define (return path) + (define path.scm (string-append path (scheme-file-suffix))) + (cond ((file-exists? path.scm) + (cons path.scm (file->exports path.scm))) + (else (slib:warn 'feature->export-alist 'path? path.scm) + (list path)))) + (cond ((not path) '()) + ((symbol? path) (f2e path)) + ((string? path) (list (return path))) + ((not (pair? path)) + (slib:error 'feature->export-alist feature 'path? path)) + (else (case (car path) + ((source defmacro macro-by-example macro macros-that-work + syntax-case syntactic-closures) + (list (return (if (pair? (cdr path)) + (cadr path) + (cdr path))))) + ((compiled) (map list (cdr path))) + ((aggregate) (apply append (map f2e (cdr path)))) + (else (slib:warn 'feature->export-alist feature 'feature? path) + '()))))) + (f2e feature)) +;;@body +;;Returns a list of all exports of @1. +(define (feature->exports feature catalog) + (apply append (map cdr (feature->export-alist feature catalog)))) +;;@noindent +;;In the case of @code{aggregate} features, more than one file may +;;have export lists to report: +;; +;;@example +;;(feature->export-alist 'r5rs slib:catalog)) +;; @result{} (("/usr/local/lib/slib/values.scm" +;; call-with-values values) +;; ("/usr/local/lib/slib/mbe.scm" +;; define-syntax macro:expand +;; macro:load macro:eval) +;; ("/usr/local/lib/slib/eval.scm" +;; eval scheme-report-environment +;; null-environment interaction-environment)) +;; +;;(feature->export-alist 'stdio *catalog*) +;; @result{} (("/usr/local/lib/slib/scanf.scm" +;; fscanf sscanf scanf scanf-read-list) +;; ("/usr/local/lib/slib/printf.scm" +;; sprintf printf fprintf) +;; ("/usr/local/lib/slib/stdio.scm" +;; stderr stdout stdin)) +;; +;;(feature->exports 'stdio slib:catalog) +;; @result{} (fscanf sscanf scanf scanf-read-list +;; sprintf printf fprintf stderr stdout stdin) +;;@end example diff --git a/manifest.txi b/manifest.txi new file mode 100644 index 0000000..e9fe3ee --- /dev/null +++ b/manifest.txi @@ -0,0 +1,145 @@ +@code{(require 'manifest)} +@ftindex manifest + +@noindent +In some of these examples, @var{slib:catalog} is the SLIB part of +the catalog; it is free of compiled and implementation-specific +entries. It would be defined by: + +@example +(define slib:catalog (cdr (member (assq 'null *catalog*) *catalog*))) +@end example + + +@defun file->requires file provided? catalog + +Returns a list of the features @code{require}d by @var{file} assuming the +predicate @var{provided?} and association-list @var{catalog}. +@end defun +@example +(define (provided+? . features) + (lambda (feature) + (or (memq feature features) (provided? feature)))) + +(file->requires "obj2str.scm" (provided+? 'compiling) '()) + @result{} (string-port generic-write) + +(file->requires "obj2str.scm" provided? '()) + @result{} (string-port) +@end example + + +@defun feature->requires feature provided? catalog + +Returns a list of the features @code{require}d by @var{feature} assuming the +predicate @var{provided?} and association-list @var{catalog}. +@end defun +@example +(feature->requires 'batch (provided+? 'compiling) *catalog*) + @result{} (tree line-i/o databases parameters string-port + pretty-print common-list-functions posix-time) + +(feature->requires 'batch provided? *catalog*) + @result{} (tree line-i/o databases parameters string-port + pretty-print common-list-functions) + +(feature->requires 'batch provided? '((batch . "batch"))) + @result{} (tree line-i/o databases parameters string-port + pretty-print common-list-functions) +@end example + + +@defun file->loads file + +Returns a list of strings naming existing files loaded (load +slib:load slib:load-source macro:load defmacro:load syncase:load +synclo:load macwork:load) by @var{file} or any of the files it loads. +@end defun +@example +(file->loads (in-vicinity (library-vicinity) "scainit.scm")) + @result{} ("/usr/local/lib/slib/scaexpp.scm" + "/usr/local/lib/slib/scaglob.scm" + "/usr/local/lib/slib/scaoutp.scm") +@end example + + +@defun load->path exp + +Given a @code{(load '<expr>)}, where <expr> is a string or vicinity +stuff), @code{(load->path <expr>)} figures a path to the file. +@code{load->path} returns that path if it names an existing file; otherwise #f. +@end defun +@example +(load->path '(in-vicinity (library-vicinity) "mklibcat")) + @result{} "/usr/local/lib/slib/mklibcat.scm" +@end example + + +@defun file->definitions file + +Returns a list of the identifier symbols defined by SLIB (or +SLIB-style) file @var{file}. +@end defun +@example +(file->definitions "random.scm") + @result{} (*random-state* make-random-state + seed->random-state copy-random-state random + random:chunk) +@end example + + +@defun file->exports file + +Returns a list of the identifier symbols exported (advertised) by +SLIB (or SLIB-style) file @var{file}. +@end defun +@example +(file->exports "random.scm") + @result{} (make-random-state seed->random-state + copy-random-state random) + +(file->exports "randinex.scm") + @result{} (random:solid-sphere! random:hollow-sphere! + random:normal-vector! random:normal + random:exp random:uniform) +@end example + + +@defun feature->export-alist feature catalog + +Returns a list of lists; each sublist holding the name of the file +implementing @var{feature}, and the identifier symbols exported (advertised) by +SLIB (or SLIB-style) feature @var{feature}, in @var{catalog}. +@end defun + +@defun feature->exports feature catalog + +Returns a list of all exports of @var{feature}. +@end defun +@noindent +In the case of @code{aggregate} features, more than one file may +have export lists to report: + +@example +(feature->export-alist 'r5rs slib:catalog)) + @result{} (("/usr/local/lib/slib/values.scm" + call-with-values values) + ("/usr/local/lib/slib/mbe.scm" + define-syntax macro:expand + macro:load macro:eval) + ("/usr/local/lib/slib/eval.scm" + eval scheme-report-environment + null-environment interaction-environment)) + +(feature->export-alist 'stdio *catalog*) + @result{} (("/usr/local/lib/slib/scanf.scm" + fscanf sscanf scanf scanf-read-list) + ("/usr/local/lib/slib/printf.scm" + sprintf printf fprintf) + ("/usr/local/lib/slib/stdio.scm" + stderr stdout stdin)) + +(feature->exports 'stdio slib:catalog) + @result{} (fscanf sscanf scanf scanf-read-list + sprintf printf fprintf stderr stdout stdin) +@end example diff --git a/matfile.scm b/matfile.scm new file mode 100644 index 0000000..2e3ff15 --- /dev/null +++ b/matfile.scm @@ -0,0 +1,187 @@ +; "matfile.scm", Read MAT-File Format version 4 (MATLAB) +; 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. + +(require 'array) +(require 'byte) +(require 'byte-number) +(require-if 'compiling 'string-case) ; string-ci->symbol used by matfile:load + +;;@code{(require 'matfile)} +;;@ftindex matfile +;;@ftindex matlab +;; +;;@uref{http://www.mathworks.com/access/helpdesk/help/pdf_doc/matlab/matfile_format.pdf} +;; +;;@noindent +;;This package reads MAT-File Format version 4 (MATLAB) binary data +;;files. MAT-files written from big-endian or little-endian computers +;;having IEEE format numbers are currently supported. Support for files +;;written from VAX or Cray machines could also be added. +;; +;;@noindent +;;The numeric and text matrix types handled; support for @dfn{sparse} +;;matrices awaits a sample file. + +(define (bytes->long lst) + (bytes->integer lst -4)) +(define (bytes->short lst) + (bytes->integer lst -2)) +(define (bytes->ushort lst) + (bytes->integer lst 2)) + +;;Version 4 MAT-file endianness cannot be detected solely from the +;;first word; it is ambiguous when 0. +(define (matfile:read-matrix port) + (define null (integer->char 0)) + (define (read1 endian type mrows ncols imagf namlen) + (set! type (bytes->long type)) + (set! mrows (bytes->long mrows)) + (set! ncols (bytes->long ncols)) + (set! imagf (bytes->long imagf)) + (set! namlen (+ -1 (bytes->long namlen))) + (let ((d-prot (modulo (quotient type 10) 10)) + (d-endn (case (quotient type 1000) + ((0 ;ieee-little-endian + 2 ;vax-d-float + 3) endian) ;vag-g-float + ((1 ;ieee-big-endian + 4) (- endian)) ;cray + (else #f))) + (m-type (case (modulo type 10) + ((0) 'numeric) + ((1) 'text) + ((2) 'sparse) + (else #f)))) + (define d-leng (case d-prot + ((0) 8) + ((1 2) 4) + ((3 4) 2) + ((5) 1) + (else #f))) + (define d-conv (case d-prot + ((0) (case (quotient type 1000) + ((0 1) bytes->ieee-double) + ((2) bytes->vax-d-double) + ((3) bytes->vax-g-double) + ((4) bytes->cray-double))) + ((1) (case (quotient type 1000) + ((0 1) bytes->ieee-float) + ((2) bytes->vax-d-float) + ((3) bytes->vax-g-float) + ((4) bytes->cray-float))) + ((2) bytes->long) + ((3) bytes->short) + ((4) bytes->ushort) + ((5) (if (eqv? 'text m-type) + (lambda (lst) (integer->char (byte-ref lst 0))) + (lambda (lst) (byte-ref lst 0)))) + (else #f))) + ;;(@print d-leng d-endn m-type type mrows ncols imagf namlen d-conv) + (cond ((and (= 0 (modulo (quotient type 100) 10) (quotient type 65536)) + d-leng d-endn m-type + (<= 0 imagf 1) + (< 0 mrows #xFFFFFF) + (< 0 ncols #xFFFFFF) + (< 0 namlen #xFFFF)) + (set! imagf (case imagf ((0) #f) ((1) #t))) + (let ((namstr (make-string namlen)) + (mat (case m-type + ((numeric) (create-array + (case d-prot + ((0) ((if imagf Ac64 Ar64))) + ((1) ((if imagf Ac32 Ar32))) + ((2) (As32)) + ((3) (As16)) + ((4) (Au16)) + ((5) (Au8)) + (else (slib:error 'p 'type d-prot))) + mrows ncols)) + ((text) (create-array "." mrows ncols)) + ((sparse) (slib:error 'sparse '?))))) + (do ((idx 0 (+ 1 idx))) + ((>= idx namlen)) + (string-set! namstr idx (read-char port))) + ;;(@print namstr) + (if (not (eqv? null (read-char port))) + (slib:error 'matfile 'string 'missing null)) + (do ((jdx 0 (+ 1 jdx))) + ((>= jdx ncols)) + (do ((idx 0 (+ 1 idx))) + ((>= idx mrows)) + (array-set! mat (d-conv (read-bytes (* d-endn d-leng) port)) + idx jdx))) + (if imagf + (do ((jdx 0 (+ 1 jdx))) + ((>= jdx ncols)) + (do ((idx 0 (+ 1 idx))) + ((>= idx mrows)) + (array-set! mat + (+ (* (d-conv (read-bytes (* d-endn d-leng) port)) + +i) + (array-ref mat idx jdx)) + idx jdx)))) + (list namstr mat))) + (else #f)))) + ;;(trace read1) + (let* ((type (read-bytes 4 port)) + (mrows (read-bytes 4 port)) + (ncols (read-bytes 4 port)) + (imagf (read-bytes 4 port)) + (namlen (read-bytes 4 port))) + ;;Try it with either endianness: + (or (read1 1 type mrows ncols imagf namlen) + (read1 -1 + (bytes-reverse type) + (bytes-reverse mrows) + (bytes-reverse ncols) + (bytes-reverse imagf) + (bytes-reverse namlen))))) + +;;@body @1 should be a string naming an existing file containing a +;;MATLAB Version 4 MAT-File. The @0 procedure reads matrices from the +;;file and returns a list of the results; a list of the name string and +;;array for each matrix. +(define (matfile:read filename) + (call-with-open-ports + (open-file filename 'rb) + (lambda (port) + (do ((mat (matfile:read-matrix port) (matfile:read-matrix port)) + (mats '() (cons mat mats))) + ((or (not mat) (eof-object? (peek-char port))) + (if (and (null? mats) (not mat)) + '() + (reverse (cons mat mats)))))))) + +;;@body @1 should be a string naming an existing file containing a +;;MATLAB Version 4 MAT-File. The @0 procedure reads matrices from the +;;file and defines the @code{string-ci->symbol} for each matrix to its +;;corresponding array. @0 returns a list of the symbols defined. +(define (matfile:load filename) + (require 'string-case) + (let ((mats (matfile:read filename))) + (for-each (lambda (nam-mat) + (and nam-mat + (slib:eval + (list 'define + (string-ci->symbol (car nam-mat)) + (list 'quote (cadr nam-mat)))))) + mats) + (map string-ci->symbol (map car mats)))) + +;;(trace-all "/home/jaffer/slib/matfile.scm") diff --git a/matfile.txi b/matfile.txi new file mode 100644 index 0000000..394ddbd --- /dev/null +++ b/matfile.txi @@ -0,0 +1,31 @@ +@code{(require 'matfile)} +@ftindex matfile +@ftindex matlab + +@uref{http://www.mathworks.com/access/helpdesk/help/pdf_doc/matlab/matfile_format.pdf} + +@noindent +This package reads MAT-File Format version 4 (MATLAB) binary data +files. MAT-files written from big-endian or little-endian computers +having IEEE format numbers are currently supported. Support for files +written from VAX or Cray machines could also be added. + +@noindent +The numeric and text matrix types handled; support for @dfn{sparse} +@cindex sparse +matrices awaits a sample file. + + +@defun matfile:read filename +@var{filename} should be a string naming an existing file containing a +MATLAB Version 4 MAT-File. The @code{matfile:read} procedure reads matrices from the +file and returns a list of the results; a list of the name string and +array for each matrix. +@end defun + +@defun matfile:load filename +@var{filename} should be a string naming an existing file containing a +MATLAB Version 4 MAT-File. The @code{matfile:load} procedure reads matrices from the +file and defines the @code{string-ci->symbol} for each matrix to its +corresponding array. @code{matfile:load} returns a list of the symbols defined. +@end defun @@ -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. ;;; revised Dec. 6, 1993 to R4RS syntax (if not semantics). -;;; revised Mar. 2 1994 for SLIB (jaffer@ai.mit.edu). +;;; revised Mar. 2 1994 for SLIB (agj @ alum.mit.edu). ;;; corrections, Apr. 24, 1997. ;;; corr., Jan. 30, 1999. (mflatt@cs.rice.edu, dorai@cs.rice.edu) @@ -27,9 +27,8 @@ ;;; defmacro. (require 'common-list-functions) ;nconc, some, every -;(require 'rev2-procedures) ;append! alternate for nconc (require 'rev4-optional-procedures) ;list-tail -(require 'defmacroexpand) +(require 'defmacroexpand) ;defmacro:expand* (define hyg:rassq (lambda (k al) @@ -401,43 +400,42 @@ (define mbe:ellipsis? (lambda (x) (and (pair? x) (pair? (cdr x)) (eq? (cadr x) '...)))) +;@ +(define macro:eval slib:eval) +(define macro:load slib:load) +(define macro:expand defmacro:expand*) -;define-syntax - +;@ define-syntax (defmacro define-syntax (macro-name syn-rules) (if (or (not (pair? syn-rules)) - (not (eq? (car syn-rules) 'syntax-rules))) - (slib:error 'define-syntax 'not-an-r4rs-high-level-macro - macro-name syn-rules) - (let ((keywords (cons macro-name (cadr syn-rules))) - (clauses (cddr syn-rules))) - `(defmacro ,macro-name macro-arg - (let ((macro-arg (cons ',macro-name macro-arg)) - (keywords ',keywords)) - (cond ,@(map - (lambda (clause) - (let ((in-pattern (car clause)) + (not (eq? (car syn-rules) 'syntax-rules))) + (slib:error 'define-syntax 'not-an-r4rs-high-level-macro + macro-name syn-rules) + (let ((keywords (cons macro-name (cadr syn-rules))) + (clauses (cddr syn-rules))) + `(defmacro ,macro-name macro-arg + (let ((macro-arg (cons ',macro-name macro-arg)) + (keywords ',keywords)) + (cond ,@(map + (lambda (clause) + (let ((in-pattern (car clause)) (out-pattern (cadr clause))) - `((mbe:matches-pattern? ',in-pattern macro-arg - keywords) + `((mbe:matches-pattern? ',in-pattern macro-arg + keywords) (let ((tagged-out-pattern+alist - (hyg:tag - ',out-pattern - (nconc (hyg:flatten ',in-pattern) - keywords) '()))) + (hyg:tag + ',out-pattern + (nconc (hyg:flatten ',in-pattern) + keywords) '()))) (hyg:untag - (mbe:expand-pattern - (car tagged-out-pattern+alist) - (mbe:get-bindings ',in-pattern macro-arg - keywords) - keywords) - (cdr tagged-out-pattern+alist) - '()))))) - clauses) - (else (slib:error ',macro-name 'no-matching-clause - ',clauses)))))))) + (mbe:expand-pattern + (car tagged-out-pattern+alist) + (mbe:get-bindings ',in-pattern macro-arg + keywords) + keywords) + (cdr tagged-out-pattern+alist) + '()))))) + clauses) + (else (slib:error ',macro-name 'no-matching-clause + ',clauses)))))))) -(define macro:eval slib:eval) -(define macro:load slib:load) -(provide 'macro) -;eof diff --git a/minimize.scm b/minimize.scm index 50a7e65..e28568a 100644 --- a/minimize.scm +++ b/minimize.scm @@ -48,7 +48,6 @@ ;; (lambda (a b c d e f g ) (= g 500))) ;; ==> (816.4965933140557e-3 . -6.088662107903635) ;;@end example - (define golden-section-search (let ((gss 'golden-section-search:) (r (/ (- (sqrt 5) 1) 2))) ; 1 / golden-section @@ -91,7 +90,7 @@ (set! fmin (min fa fb))) ((2) (set! fmin (min fmin fa fb)) - (if (eqv? fmax fa fb) (slib:error gss 'flat? fmax))) + (if (= fmax fa fb) (slib:error gss 'flat? fmax))) (else (set! fmin (min fmin fa fb)))) (cond ((stop? left right a b fa fb count) diff --git a/mitscheme.init b/mitscheme.init index afec48e..934de62 100644 --- a/mitscheme.init +++ b/mitscheme.init @@ -8,45 +8,49 @@ (define getenv get-environment-variable) ;;; (software-type) should be set to the generic operating system type. -(define (software-type) (if (getenv "HOMEDRIVE") 'MS-DOS 'UNIX)) +(define (software-type) + (if (eq? 'unix microcode-id/operating-system) 'UNIX 'MS-DOS)) ;;; (scheme-implementation-type) should return the name of the scheme ;;; implementation loading this file. - (define (scheme-implementation-type) 'MITScheme) ;;; (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://swissnet.ai.mit.edu/scheme-home.html") + "http://www.swiss.ai.mit.edu/projects/scheme/") ;;; (scheme-implementation-version) should return a string describing ;;; the version the scheme implementation loading this file. - (define (scheme-implementation-version) - (let* ((str (with-output-to-string identify-world)) - (beg (+ (string-search-forward "Release " str) 8)) - (rst (substring str beg (string-length str))) - (end (string-find-next-char-in-set - rst - (predicate->char-set char-whitespace?)))) - (substring rst 0 end))) + (get-subsystem-version-string "Release")) + +(define (mit-scheme-release>= major minor) + (let ((version (scheme-implementation-version))) + (let ((components (burst-string version #\. #f)) + (lose + (lambda () + (error "Malformed release version string:" version)))) + (let ((major* + (or (and (pair? components) + (string->number (car components))) + (lose)))) + (or (> major* major) + (and (= major* major) + (>= (or (and (pair? (cdr components)) + (string->number (cadr components))) + (lose)) + minor))))))) ;;; (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) - ((MS-DOS) "c:\\scheme\\") - ((UNIX) "/usr/local/lib/mit-scheme/") - ((VMS) "scheme$src:"))) + (->namestring (system-library-directory-pathname #f))) ;;; (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") @@ -54,22 +58,18 @@ (case (software-type) ((MS-DOS) "c:\\slib\\") ((UNIX) "/usr/local/lib/slib/") - ((VMS) "lib$scheme:") (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-path (getenv "HOME"))) - (lambda () home-path))) +(define (home-vicinity) + (->namestring (user-homedir-pathname))) ;;; *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 @@ -79,11 +79,14 @@ ;; Scheme report features - rev5-report ;conforms to - eval ;R5RS two-argument eval +; **** no, for several reasons +; r5rs ;conforms to +; **** no -- special arguments not supported +; eval ;R5RS two-argument eval +; **** sort of -- not integrated with continuations values ;R5RS multiple values dynamic-wind ;R5RS dynamic-wind - macro ;R5RS high level macros + fluid-let delay ;has DELAY and FORCE multiarg-apply ;APPLY can take more than 2 args. char-ready? @@ -93,11 +96,12 @@ ;STRING-FILL!, LIST->VECTOR, ;VECTOR->LIST, and VECTOR-FILL! - rev4-report ;conforms to + r4rs ;conforms to - ieee-p1178 ;conforms to +; **** no -- #F and '() are identical +; ieee-p1178 ;conforms to -; rev3-report ;conforms to +; r3rs ;conforms to rev2-procedures ;SUBSTRING-MOVE-LEFT!, ;SUBSTRING-MOVE-RIGHT!, @@ -108,7 +112,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 @@ -118,16 +122,14 @@ ;; 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 + sort pretty-print object->string +; **** limited subset with (load-option 'format) ; format ;Common-lisp output formatting trace ;has macros: TRACE and UNTRACE compiler ;has (COMPILER) @@ -143,6 +145,19 @@ Xwindows )) +; **** MIT Scheme has SORT, but SORT! accepts only vectors. +(define sort! sort) + +(define mit-scheme-has-r4rs-macros? + (mit-scheme-release>= 7 7)) +(if mit-scheme-has-r4rs-macros? + (set! *features* (cons 'macro *features*))) + +(if (get-subsystem-version-string "6.001") + ;; Runs code from "Structure and Interpretation of Computer + ;; Programs" by Abelson and Sussman. + (set! *features* (cons 'sicp *features*))) + (define current-time current-file-time) (define difftime -) (define offset-time +) @@ -151,19 +166,16 @@ (define output-port-width output-port/x-size) ;;; (OUTPUT-PORT-HEIGHT <port>) -(define (output-port-height . arg) 24) +(define (output-port-height port) + (or (output-port/y-size port) + 24)) ;;; (CURRENT-ERROR-PORT) -(define current-error-port - (let ((port console-output-port)) - (lambda () port))) +(define current-error-port nearest-cmdl/port) ;;; (TMPNAM) makes a temporary file name. -(define tmpnam - (let ((cntr 100)) - (lambda () (set! cntr (+ 1 cntr)) - (let ((tmp (string-append "slib_" (number->string cntr)))) - (if (file-exists? tmp) (tmpnam) tmp))))) +(define (tmpnam) + (->namestring (temporary-file-pathname))) ;;; FORCE-OUTPUT flushes any pending output on optional arg output port. (define force-output flush-output) @@ -172,21 +184,31 @@ ;;; CALL-WITH-INPUT-STRING and CALL-WITH-OUTPUT-STRING are the string ;;; port versions of CALL-WITH-*PUT-FILE. -(define (call-with-output-string proc) - (let ((co (current-output-port))) - (with-output-to-string - (lambda () - (let ((port (current-output-port))) - (with-output-to-port co - (lambda () (proc port)))))))) +(define call-with-output-string with-string-output-port) (define (call-with-input-string string proc) - (let ((ci (current-input-port))) - (with-input-from-string string - (lambda () - (let ((port (current-input-port))) - (with-input-from-port ci - (lambda () (proc port)))))))) + (proc (string->input-port string))) + +(define (make-exchanger obj) + (lambda (rep) (let ((old obj)) (set! obj rep) old))) +(define (open-file filename modes) + (case modes + ((r) (open-input-file filename)) + ((r+) (open-i/o-file filename)) + ((w) (open-output-file filename)) + ((rb) (open-binary-input-file filename)) + ((r+b rb+) (open-binary-i/o-file filename)) + ((wb) (open-binary-output-file filename)) + (else (slib:error 'open-file 'mode? modes)))) +(define (call-with-open-ports . ports) + (define proc (car ports)) + (cond ((procedure? proc) (set! ports (cdr ports))) + (else (set! ports (reverse ports)) + (set! proc (car ports)) + (set! ports (reverse (cdr ports))))) + (let ((ans (apply proc ports))) + (for-each close-port ports) + ans)) (define object->string write-to-string) (define object->limited-string write-to-string) @@ -199,61 +221,113 @@ (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. It is defined incorrectly (65536) -;;; by MITScheme version 8.0. -(define char-code-limit 256) +;;; be returned by CHAR->INTEGER. +;;; +;;; [Note that this definition conflicts with MIT Scheme's definition +;;; of the same name.] +;;; +;;; Can't use correct value because "jacal/types.scm" assumes that +;;; every possible character can be stored into a string. In MIT +;;; Scheme, only 8-bit characters fit in strings, while the character +;;; object supports 16 bits of character code with 5 bucky bits. So +;;; instead provide the limit that is appropriate for string +;;; characters. +(define char-code-limit + ;;char-integer-limit + 256) ;;; MOST-POSITIVE-FIXNUM is used in modular.scm -(define most-positive-fixnum #x03FFFFFF) +(define most-positive-fixnum + (let loop ((n 1)) + (if (fix:fixnum? n) + (loop (* n 2)) + (- n 1)))) ;;; Return argument -(define (identity x) x) +(define identity identity-procedure) ;;; SLIB:EVAL is single argument eval using the top-level (user) environment. -;(define (slib:eval form) (eval form (repl/environment (nearest-repl)))) +;(define (slib:eval form) (eval form (nearest-repl/environment))) (define (slib:eval form) (eval form user-initial-environment)) (define *macros* '(defmacro)) (define (defmacro? m) (and (memq m *macros*) #t)) -(syntax-table-define system-global-syntax-table 'defmacro - (macro defmacargs - (let ((macname (car defmacargs)) (macargs (cadr defmacargs)) - (macbdy (cddr defmacargs))) - `(begin - (set! *macros* (cons ',macname *macros*)) - (syntax-table-define system-global-syntax-table ',macname - (macro ,macargs ,@macbdy)))))) - -(define (macroexpand-1 e) - (if (pair? e) (let ((a (car e))) - (if (and (symbol? a) (defmacro? a)) - (apply (syntax-table-ref system-global-syntax-table a) - (cdr e)) - e)) - e)) - -(define (macroexpand e) - (if (pair? e) (let ((a (car e))) - (if (and (symbol? a) (defmacro? a)) - (macroexpand - (apply (syntax-table-ref system-global-syntax-table a) - (cdr e))) - e)) - e)) - -(define gentemp - (let ((*gensym-counter* -1)) - (lambda () - (set! *gensym-counter* (+ *gensym-counter* 1)) - (string->symbol - (string-append "slib:G" (number->string *gensym-counter*)))))) +(if mit-scheme-has-r4rs-macros? + (environment-define-macro user-initial-environment 'defmacro + (non-hygienic-macro-transformer->expander + (lambda arguments + (let ((name (car arguments))) + `(begin + (set! *macros* (cons ',name *macros*)) + (environment-define-macro user-initial-environment ',name + (non-hygienic-macro-transformer->expander + (lambda ,@(cdr arguments)) + user-initial-environment))))) + user-initial-environment)) + (syntax-table-define system-global-syntax-table 'defmacro + (macro defmacargs + (let ((macname (car defmacargs)) (macargs (cadr defmacargs)) + (macbdy (cddr defmacargs))) + `(begin + (set! *macros* (cons ',macname *macros*)) + (syntax-table-define system-global-syntax-table ',macname + (macro ,macargs ,@macbdy))))))) + +(define macroexpand-1) +(define macroexpand) +(let ((finish + (lambda (get-transformer apply-transformer) + (set! macroexpand-1 + (lambda (form) + (let ((transformer (get-transformer form))) + (if transformer + (apply-transformer transformer form) + form)))) + (set! macroexpand + (lambda (form) + (let ((transformer (get-transformer form))) + (if transformer + (macroexpand (apply-transformer transformer form)) + form))))))) + (if mit-scheme-has-r4rs-macros? + (let ((e (->environment '(runtime syntactic-closures)))) + (let ((transformer-item/expander (access transformer-item/expander e)) + (expander-item/expander (access expander-item/expander e)) + (expander-item/environment (access expander-item/environment e))) + (finish + (lambda (form) + (and (pair? form) + (let ((a (car form))) + (and (symbol? a) + (defmacro? a) + (environment-lookup-macro user-initial-environment + a))))) + (lambda (item form) + (let ((item (transformer-item/expander item))) + ((expander-item/expander item) + form + user-initial-environment + (expander-item/environment item))))))) + (finish + (lambda (form) + (and (pair? form) + (let ((a (car form))) + (and (symbol? a) + (defmacro? a) + (syntax-table-ref system-global-syntax-table a))))) + (apply-transformer + (lambda (transformer form) + (apply transformer (cdr form))))))) + +(define gentemp generate-uninterned-symbol) (define defmacro:eval slib:eval) (define defmacro:load load) -;;; If your implementation provides R4RS macros: -;(define macro:eval slib:eval) -;(define macro:load load) +(if mit-scheme-has-r4rs-macros? + (begin + (environment-define (the-environment) 'macro:eval slib:eval) + (environment-define (the-environment) 'macro:load load))) (define (slib:eval-load <pathname> evl) (if (not (file-exists? <pathname>)) @@ -261,31 +335,30 @@ (call-with-input-file <pathname> (lambda (port) (let ((old-load-pathname *load-pathname*)) - (set! *load-pathname* <pathname>) - (do ((o (read port) (read port))) - ((eof-object? o)) - (evl o)) - (set! *load-pathname* old-load-pathname))))) + (fluid-let ((*load-pathname* <pathname>)) + (do ((o (read port) (read port))) + ((eof-object? o)) + (evl o))))))) -(define record-modifier record-updater) ;some versions need this? +;; Older implementations need this definition. +(if (lexical-unreferenceable? (the-environment) 'record-modifier) + (local-assignment (the-environment) 'record-modifier record-updater)) -(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)))) +(define (slib:warn . args) + (if (provided? 'trace) (print-call-stack (notification-output-port))) + (apply warn args)) ;; define an error procedure for the library (define (slib:error . args) (if (provided? 'trace) (print-call-stack (current-error-port))) - (apply error-procedure (append args (list (the-environment))))) + (apply error args)) ;; define these as appropriate for your system. -(define slib:tab (integer->char 9)) -(define slib:form-feed (integer->char 12)) +(define slib:tab (name->char "tab")) +(define slib:form-feed (name->char "page")) -(define in-vicinity string-append) +(define (in-vicinity vicinity file-name) + (->namestring (merge-pathnames file-name vicinity))) ;;; Define SLIB:EXIT to be the implementation procedure to exit or ;;; return if exitting not supported. @@ -297,22 +370,18 @@ (else (exit 1))))) ;;; Here for backward compatability - (define (scheme-file-suffix) ".scm") ;;; (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:load (in-vicinity (library-vicinity) "require.scm")) diff --git a/mkclrnam.scm b/mkclrnam.scm new file mode 100644 index 0000000..7377f37 --- /dev/null +++ b/mkclrnam.scm @@ -0,0 +1,259 @@ +;;; "mkclrnam.scm" create color name databases +;Copyright 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. + +(require 'string-search) +(require 'line-i/o) +(require 'scanf) +(require 'color) +(require 'color-names) +(require 'databases) +(require-if 'compiling 'filename) + +;;@subsubheading Dictionary Creation +;; +;;@code{(require 'color-database)} +;;@ftindex color-database + +;;@args file table-name rdb base-table-type +;;@args file table-name rdb +;; +;;@3 must be an open relational database or a string naming a relational +;;database file, @2 a symbol, and the string @1 must name an existing +;;file with colornames and their corresponding xRGB (6-digit hex) +;;values. @0 creates a table @2 in @3 and enters the associations found +;;in @1 into it. +(define (file->color-dictionary file table-name . *db*) + (define rdb (apply open-database! *db*)) + (define-tables rdb + `(,table-name + ((name string)) + ((color string) + (order ordinal)) + ())) + (let ((table ((rdb 'open-table) table-name #t))) + (and table (load-rgb-txt file table)))) + +;;@args url table-name rdb base-table-type +;;@args url table-name rdb +;; +;;@3 must be an open relational database or a string naming a relational +;;database file and @2 a symbol. @0 retrieves the resource named by the +;;string @1 using the @dfn{wget} program; then calls +;;@code{file->color-dictionary} to enter its associations in @2 in @1. +(define (url->color-dictionary url table-name . rdb) + (require 'filename) + (call-with-tmpnam + (lambda (file) + (system (string-append "wget -c -O" file " -USLIB" *SLIB-VERSION* " " url)) + (apply file->color-dictionary file table-name rdb)))) + +(define (load-rgb-txt path color-table) + (cond ((not (file-exists? path)) + (slib:error 'load-color-dictionary! 'file-exists? path))) + (write 'load-rgb-txt) (display #\ ) (write path) (newline) + (let ((color-table:row-insert (color-table 'row:insert)) + (color-table:row-retrieve (color-table 'row:retrieve)) + (method-id #f)) + (define (floats->rgb . rgbi) + (apply color:sRGB + (map (lambda (x) (inexact->exact (round (* 255 x)))) rgbi))) + (define (parse-rgb-line line) + (let ((rgbx #f) (r #f) (g #f) (b #f) + (ri #f) (gi #f) (bi #f) (name #f) (junk #f) (ans #f)) + (define (check-match line color1 . colors) + (cond ((null? colors) (color->string color1)) + ((> (CMC:DE* color1 (car colors)) 5.0) + (newline) (display line) (force-output) + (slib:warn (round (CMC:DE* color1 (car colors))) + 'mismatch (color->string color1) + (color->string (car colors))) + (apply check-match line colors)) + (else (apply check-match line colors)))) + (for-each + (lambda (method) + (or ans + (let ((try (method line))) + (cond (try (set! ans try) + (display "**** Using method ") + (display method-id) (newline) + (set! parse-rgb-line method)))))) + (list + (lambda (line) + (define en #f) (define fr #f) (define de #f) + (define es #f) (define cz #f) (define hu #f) + (case (sscanf line "#%6x %[^ ] %[^ ] %[^ ] %[^ ] %[^ ] %[^ ]%s" + rgbx en fr de es cz hu junk) + ((7) + (set! method-id 'm77) + (cons (check-match line (xRGB->color rgbx)) + (map color-name:canonicalize (list en fr de es cz hu)))) + (else #f))) + (lambda (line) + (case (sscanf line " %24[a-zA-Z0-9_ ] %d %d %d %e %e %e %s" + name r g b ri gi bi junk) + ((7) + (set! method-id 'm7) + (list (check-match line (color:sRGB r g b) (floats->rgb ri gi bi)) + (color-name:canonicalize name))) + (else #f))) + (lambda (line) + (case (sscanf line " %[a-zA-Z0-9_] %6x %d %d %d %e %e %e %s" + name rgbx r g b ri gi bi junk) + ((8) + (set! method-id 'm8) + (list (check-match line (xrgb->color rgbx) + (color:sRGB r g b) + (floats->rgb ri gi bi)) + (color-name:canonicalize name))) + (else #f))) + (lambda (line) + (case (sscanf line " %[a-zA-Z0-9] %6x %d,%d,%d" name rgbx r g b) + ((5) + (set! method-id 'm5) + (list (check-match line (xrgb->color rgbx) (color:sRGB r g b)) + (color-name:canonicalize name))) + (else #f))) + (lambda (line) + (case (sscanf line " %[- a-zA-Z0-9_'] #%6x %d %d %d %s" + name rgbx r g b junk) + ((6 5) + (set! method-id 'm65) + (list (check-match line (xrgb->color rgbx) (color:sRGB r g b)) + (color-name:canonicalize name))) + (else #f))) + (lambda (line) + (case (sscanf line " %d %d %d %[a-zA-Z0-9 ]%s" r g b name junk) + ((4) (set! method-id 'm4a) + (list (check-match line (color:sRGB r g b)) + (color-name:canonicalize name))) + (else #f))) + (lambda (line) + (case (sscanf line " %[- a-zA-Z.] %d %d %d %s" + name r g b junk) + ((4) (set! method-id 'm4b) + (list (check-match line (color:sRGB r g b)) + (color-name:canonicalize name))) + (else #f))) + (lambda (line) + (case (sscanf line "\" Resene %[^\"]\" %d %d %d %s" + name r g b junk) + ((4) (set! method-id 'm4b) + (list (check-match line (color:sRGB r g b)) + (color-name:canonicalize name))) + (else #f))) + (lambda (line) + (case (sscanf line "\" %[^\"]\" %d %d %d %s" + name r g b junk) + ((4) (set! method-id 'm4c) + (list (check-match line (color:sRGB r g b)) + (color-name:canonicalize name))) + (else #f))) + (lambda (line) + (case (sscanf line " %[a-zA-Z0-9_] #%x%6x%s" name rgbx junk) + ((2) (set! method-id 'm2a) + (list (check-match line (xrgb->color rgbx)) + (color-name:canonicalize name))) + (else #f))) + (lambda (line) + (case (sscanf line "%[- a-zA-Z']=#%6x<br>" name rgbx) + ((2) (set! method-id 'm2b) + (let ((idx (substring? "rgb" name))) + (and (eqv? idx (+ -3 (string-length name))) + (list (check-match line (xrgb->color rgbx)) + (color-name:canonicalize (substring name 0 idx)))))) + (else #f))) + (lambda (line) + (case (sscanf line "\" %[^\"]\" %s" name junk) + ((2) (set! method-id 'm2c) + (let ((clr (string->color junk))) + (and clr (list (check-match line clr) + (color-name:canonicalize name))))) + (else #f))))) + ans)) + (define (numbered-gray? str) + (define idx #f) + (and (or (eqv? 0 (substring-ci? "gray" str)) + (eqv? 0 (substring-ci? "grey" str))) + (eqv? 1 (sscanf (substring str 4 (string-length str)) + "%d%s" idx str)))) + (call-with-input-file path + (lambda (port) + (define *idx* 0) + (define *rcs-header* (read-line port)) + (do ((line (read-line port) (read-line port))) + ((eof-object? line) + (display "Inserted ") (display *idx*) (display "colors") (newline) + *rcs-header*) + (let ((colin (parse-rgb-line line))) + (cond ((equal? "" line)) + ;;((char=? #\# (string-ref line 0))) + ((not colin) (write-line line)) + ((numbered-gray? (cadr colin))) + (else + (for-each + (lambda (name) + (let ((oclin (color-table:row-retrieve name))) + (cond + ((and oclin (equal? (car colin) (cadr oclin)))) + ((not oclin) + (set! *idx* (+ 1 *idx*)) + (color-table:row-insert + (list name (car colin) *idx*))) + (else (slib:warn 'collision name oclin))))) + (cdr colin)))))))))) + +;;@noindent +;;This section has detailed the procedures for creating and loading +;;color dictionaries. So where are the dictionaries to load? +;; +;;@uref{http://swissnet.ai.mit.edu/~jaffer/Color/Dictionaries.html} +;; +;;@noindent +;;Describes and evaluates several color-name dictionaries on the web. +;;The following procedure creates a database containing two of these +;;dictionaries. + +;;@body +;;Creates an @r{alist-table} relational database in @r{library-vicinity} +;;containing the @dfn{Resene} and @dfn{saturate} color-name +;;dictionaries. +;; +;;If the files @file{resenecolours.txt} and @file{saturate.txt} exist in +;;the @r{library-vicinity}, then they used as the source of color-name +;;data. Otherwise, @0 calls url->color-dictionary with the URLs of +;;appropriate source files. +(define (make-slib-color-name-db) + (define cndb (create-database (in-vicinity (library-vicinity) "clrnamdb.scm") + 'alist-table)) + (for-each + (lambda (lst) + (apply + (lambda (url path name) + (define filename (in-vicinity (library-vicinity) path)) + (if (file-exists? filename) + (file->color-dictionary filename name cndb) + (url->color-dictionary url name cndb))) + lst)) + '(("http://swissnet.ai.mit.edu/~jaffer/Color/saturate.txt" + "saturate.txt" + saturate) + ("http://swissnet.ai.mit.edu/~jaffer/Color/resenecolours.txt" + "resenecolours.txt" + resene))) + (close-database cndb)) diff --git a/mkclrnam.txi b/mkclrnam.txi new file mode 100644 index 0000000..3eeb892 --- /dev/null +++ b/mkclrnam.txi @@ -0,0 +1,54 @@ +@subsubheading Dictionary Creation + +@code{(require 'color-database)} +@ftindex color-database + + +@defun file->color-dictionary file table-name rdb base-table-type + + +@defunx file->color-dictionary file table-name rdb + +@var{rdb} must be an open relational database or a string naming a relational +database file, @var{table-name} a symbol, and the string @var{file} must name an existing +file with colornames and their corresponding xRGB (6-digit hex) +values. @code{file->color-dictionary} creates a table @var{table-name} in @var{rdb} and enters the associations found +in @var{file} into it. +@end defun + +@defun url->color-dictionary url table-name rdb base-table-type + + +@defunx url->color-dictionary url table-name rdb + +@var{rdb} must be an open relational database or a string naming a relational +database file and @var{table-name} a symbol. @code{url->color-dictionary} retrieves the resource named by the +string @var{url} using the @dfn{wget} program; then calls +@cindex wget +@code{file->color-dictionary} to enter its associations in @var{table-name} in @var{url}. +@end defun +@noindent +This section has detailed the procedures for creating and loading +color dictionaries. So where are the dictionaries to load? + +@uref{http://swissnet.ai.mit.edu/~jaffer/Color/Dictionaries.html} + +@noindent +Describes and evaluates several color-name dictionaries on the web. +The following procedure creates a database containing two of these +dictionaries. + + +@defun make-slib-color-name-db + +Creates an @r{alist-table} relational database in @r{library-vicinity} +containing the @dfn{Resene} and @dfn{saturate} color-name +@cindex Resene +@cindex saturate +dictionaries. + +If the files @file{resenecolours.txt} and @file{saturate.txt} exist in +the @r{library-vicinity}, then they used as the source of color-name +data. Otherwise, @code{make-slib-color-name-db} calls url->color-dictionary with the URLs of +appropriate source files. +@end defun diff --git a/mklibcat.scm b/mklibcat.scm index 5b7d211..e6a0321 100644 --- a/mklibcat.scm +++ b/mklibcat.scm @@ -1,5 +1,5 @@ ;"mklibcat.scm" Build catalog for SLIB -;Copyright (C) 1997 Aubrey Jaffer +;Copyright (C) 1997, 1998, 1999, 2000, 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. ; @@ -17,185 +17,228 @@ ;promotional, or sales literature without prior written consent in ;each case. -(call-with-output-file (in-vicinity (implementation-vicinity) "slibcat") - (lambda (op) - (display ";\"slibcat\" SLIB catalog for " op) - (display (scheme-implementation-type) op) - (display (scheme-implementation-version) op) - (display ". -*-scheme-*-" op) (newline op) - (display ";" op) (newline op) - (display "; DO NOT EDIT THIS FILE -- it is automagically generated" op) - (newline op) (newline op) +(let ((catpath (in-vicinity (implementation-vicinity) "slibcat"))) + (and (file-exists? catpath) (delete-file catpath)) + (call-with-output-file catpath + (lambda (op) + (define (display* . args) + (for-each (lambda (arg) (display arg op)) args) + (newline op)) + (define (write* asp) + (display " " op) (write asp op) (newline op)) + (display* ";\"slibcat\" SLIB catalog for " + (scheme-implementation-type) (scheme-implementation-version) + ". -*-scheme-*-") + (display* ";") + (display* "; DO NOT EDIT THIS FILE -- it is automagically generated") + (display*) - (display "(" op) (newline op) - (for-each - (lambda (asp) (display " " op) (write asp op) (newline op)) - (append - (list (cons 'schelog - (in-vicinity (sub-vicinity (library-vicinity) "schelog") - "schelog")) - (cons 'portable-scheme-debugger - (in-vicinity (sub-vicinity (library-vicinity) "psd") - "psd-slib")) - (cons 'jfilter - (in-vicinity (sub-vicinity (library-vicinity) "jfilter") - "jfilter"))) - (map (lambda (p) - (if (symbol? (cdr p)) p - (cons - (car p) - (if (pair? (cdr p)) - (cons - (cadr p) - (in-vicinity (library-vicinity) (cddr p))) - (in-vicinity (library-vicinity) (cdr p)))))) - '( - (rev4-optional-procedures . "sc4opt") - (rev2-procedures . "sc2") - (multiarg/and- . "mularg") - (multiarg-apply . "mulapply") - (rationalize . "ratize") - (transcript . "trnscrpt") - (with-file . "withfile") - (dynamic-wind . "dynwind") - (dynamic . "dynamic") - (fluid-let defmacro . "fluidlet") - (alist . "alist") - (hash . "hash") - (sierpinski . "sierpinski") - (soundex . "soundex") - (hash-table . "hashtab") - (logical . "logical") - (random . "random") - (random-inexact . "randinex") - (modular . "modular") - (factor . "factor") - (primes . factor) - (charplot . "charplot") - (sort . "sort") - (tsort . topological-sort) - (topological-sort . "tsort") - (common-list-functions . "comlist") - (tree . "tree") - (coerce . "coerce") - (format . "format") - (generic-write . "genwrite") - (pretty-print . "pp") - (pprint-file . "ppfile") - (object->string . "obj2str") - (string-case . "strcase") - (stdio . "stdio") - (printf . "printf") - (scanf . "scanf") - (line-i/o . "lineio") - (string-port . "strport") - (getopt . "getopt") - (debug . "debug") - (qp . "qp") - (break defmacro . "break") - (trace defmacro . "trace") - (eval . "eval") - (record . "record") - (promise . "promise") - (synchk . "synchk") - (defmacroexpand . "defmacex") - (macro-by-example defmacro . "mbe") - (syntax-case . "scainit") - (syntactic-closures . "scmacro") - (macros-that-work . "macwork") - (macro . macro-by-example) - (object . "object") - (yasos macro . "yasyn") - (oop . yasos) - (collect macro . "collect") - (structure syntax-case . "structure") - (values . "values") - (queue . "queue") - (priority-queue . "priorque") - (array . "array") - (array-for-each . "arraymap") - (repl . "repl") - (process . "process") - (chapter-order . "chap") - (posix-time . "psxtime") - (common-lisp-time . "cltime") - (time-zone . "timezone") - (relational-database . "rdms") - (database-utilities . "dbutil") - (database-browse . "dbrowse") - (html-form . "htmlform") - (alist-table . "alistab") - (parameters . "paramlst") - (getopt-parameters . "getparam") - (read-command . "comparse") - (batch . "batch") - (glob . "glob") - (filename . glob) - (make-crc . "makcrc") - (fft . "fft") - (wt-tree . "wttree") - (string-search . "strsrch") - (root . "root") - (minimize . "minimize") - (precedence-parse . "prec") - (parse . precedence-parse) - (commutative-ring . "cring") - (self-set . "selfset") - (determinant . "determ") - (byte . "byte") - (tzfile . "tzfile") - (schmooz . "schmooz") - (net-clients . "nclients") - (db->html . "db2html") - (http . "http-cgi") - (cgi . http) - (uri . "uri") - (uniform-resource-identifier . uri) - (pnm . "pnm") - (metric-units . "simetrix") - (diff . "differ") - (srfi-0 . srfi) - (srfi defmacro . "srfi") - (srfi-1 . "srfi-1") - (new-catalog . "mklibcat") - )))) - (display " " op) + (display* "(") + (for-each + write* + (append + (list (cons 'schelog + (in-vicinity (sub-vicinity (library-vicinity) "schelog") + "schelog")) + (cons 'portable-scheme-debugger + (in-vicinity (sub-vicinity (library-vicinity) "psd") + "psd-slib")) + (cons 'jfilter + (in-vicinity (sub-vicinity (library-vicinity) "jfilter") + "jfilter"))) + (catalog:resolve + (library-vicinity) + '( + ;; null is the start of SLIB associations. + (null "null") + (aggregate "null") + (r2rs aggregate rev3-procedures rev2-procedures) + (r3rs aggregate rev3-procedures) + (r4rs aggregate rev4-optional-procedures) + (r5rs aggregate values macro eval) + (rev4-optional-procedures "sc4opt") + (rev3-procedures "null") + (rev2-procedures "sc2") + (multiarg/and- "mularg") + (multiarg-apply "mulapply") + (rationalize "ratize") + (transcript "trnscrpt") + (with-file "withfile") + (dynamic-wind "dynwind") + (dynamic "dynamic") + (fluid-let defmacro "fluidlet") + (alist "alist") + (hash "hash") + (sierpinski "sierpinski") + (hilbert-fill "phil-spc") + (soundex "soundex") + (hash-table "hashtab") + (logical "logical") + (random "random") + (random-inexact "randinex") + (modular "modular") + (factor "factor") + (primes factor) + (eps-graph "grapheps") + (charplot "charplot") + (sort "sort") + (tsort topological-sort) + (topological-sort "tsort") + (common-list-functions "comlist") + (tree "tree") + (coerce "coerce") + ;;(format "format") + (generic-write "genwrite") + (pretty-print "pp") + (pprint-file "ppfile") + (object->string "obj2str") + (string-case "strcase") + (line-i/o "lineio") + (string-port "strport") + (getopt "getopt") + (qp "qp") + (eval "eval") + (record "record") + (synchk "synchk") + (defmacroexpand "defmacex") - (let* ((req (in-vicinity (library-vicinity) - (string-append "require" (scheme-file-suffix))))) - (write (cons '*SLIB-VERSION* (or (require:version req) *SLIB-VERSION*)) - op)) - (newline op) - (display ")" op) (newline op) + (printf "printf") + (scanf defmacro "scanf") + (stdio-ports "stdio") + (stdio aggregate scanf printf stdio-ports) - (let ((load-if-exists - (lambda (path) - (cond ((not (file-exists? path)) - (set! path (string-append path (scheme-file-suffix))))) - (cond ((file-exists? path) - (slib:load-source path)))))) - ;;(load-if-exists (in-vicinity (implementation-vicinity) "mksitcat")) - (load-if-exists (in-vicinity (implementation-vicinity) "mkimpcat"))) + (break defmacro "break") + (trace defmacro "trace") + (debugf "debug") + (debug aggregate trace break debugf) - (let ((catcat - (lambda (vicinity name specificity) - (let ((path (in-vicinity vicinity name))) - (and (file-exists? path) - (call-with-input-file path - (lambda (ip) - (newline op) - (display "; " op) - (write path op) - (display " SLIB " op) - (display specificity op) - (display "-specific catalog additions" op) - (newline op) (newline op) - (do ((c (read-char ip) (read-char ip))) - ((eof-object? c)) - (write-char c op))))))))) - (catcat (library-vicinity) "sitecat" "site") - (catcat (implementation-vicinity) "implcat" "implementation") - (catcat (implementation-vicinity) "sitecat" "site")) - )) + (delay promise) + (promise macro "promise") -(set! *catalog* #f) + (macro-by-example defmacro "mbe") + + (syntax-case "scainit") + (syntactic-closures "scmacro") + (macros-that-work "macwork") + (macro macro-by-example) + (object "object") + (yasos macro "yasyn") + (oop yasos) + (collect "collectx") + (structure syntax-case "structure") + (values "values") + (queue "queue") + (priority-queue "priorque") + (array "array") + (subarray "subarray") + (array-for-each "arraymap") + (repl "repl") + (process "process") + (chapter-order "chap") + (posix-time "psxtime") + (common-lisp-time "cltime") + (time-zone defmacro "timezone") + (relational-database "rdms") + (databases "dbutil") + (database-utilities databases) + (database-commands "dbcom") + (database-browse "dbrowse") + (database-interpolate "dbinterp") + (within-database macro "dbsyn") + (html-form "htmlform") + (alist-table "alistab") + (parameters "paramlst") + (getopt-parameters "getparam") + (read-command "comparse") + (batch "batch") + (glob "glob") + (filename glob) + (crc "crc") + (fft "fft") + (wt-tree "wttree") + (string-search "strsrch") + (root "root") + (minimize "minimize") + (precedence-parse defmacro "prec") + (parse precedence-parse) + (commutative-ring "cring") + (self-set "selfset") + (determinant "determ") + (byte "byte") + (byte-number "bytenumb") + (tzfile "tzfile") + (schmooz "schmooz") + (transact defmacro "transact") + (net-clients transact) + (db->html "db2html") + (http defmacro "http-cgi") + (cgi http) + (uri defmacro "uri") + (uniform-resource-identifier uri) + (pnm "pnm") + (metric-units "simetrix") + (diff "differ") + (solid "solid") + (vrml97 solid) + (vrml vrml97) + (color defmacro "color") + (color-space "colorspc") + (cie color-space) + (color-names "colornam") + (color-database defmacro "mkclrnam") + (resene color-names "clrnamdb.scm") + (saturate color-names "clrnamdb.scm") + (daylight "daylight") + (matfile "matfile") + (mat-file matfile) + (spectral-tristimulus-values color-space) + (cie1964 spectral-tristimulus-values "cie1964.xyz") + (cie1931 spectral-tristimulus-values "cie1931.xyz") + (ciexyz cie1931) + (cvs defmacro "cvs") + (html-for-each defmacro "html4each") + (directory "dirs") + (ncbi-dna defmacro "ncbi-dna") + (manifest "manifest") + (top-refs "top-refs") + (vet "vet") + (srfi-0 srfi) + (srfi defmacro "srfi") + (srfi-1 "srfi-1") + (srfi-2 defmacro "srfi-2") + (srfi-8 macro "srfi-8") + (srfi-9 macro "srfi-9") + (new-catalog "mklibcat") + )))) + (let* ((req (in-vicinity (library-vicinity) + (string-append "require" (scheme-file-suffix))))) + (write* (cons '*SLIB-VERSION* (or (slib:version req) *SLIB-VERSION*)))) + (display* ")") + + (let ((load-if-exists + (lambda (path) + (cond ((not (file-exists? path)) + (set! path (string-append path (scheme-file-suffix))))) + (cond ((file-exists? path) + (slib:load-source path)))))) + ;;(load-if-exists (in-vicinity (implementation-vicinity) "mksitcat")) + (load-if-exists (in-vicinity (implementation-vicinity) "mkimpcat"))) + + (let ((catcat + (lambda (vicinity name specificity) + (let ((path (in-vicinity vicinity name))) + (and (file-exists? path) + (call-with-input-file path + (lambda (ip) + (display*) + (display* "; " "\"" path "\"" " SLIB " + specificity "-specific catalog additions") + (display*) + (do ((c (read-char ip) (read-char ip))) + ((eof-object? c)) + (write-char c op))))))))) + (catcat (library-vicinity) "sitecat" "site") + (catcat (implementation-vicinity) "implcat" "implementation") + (catcat (implementation-vicinity) "sitecat" "site")) + )) + (set! *catalog* #f)) diff --git a/modular.scm b/modular.scm index a653739..e836100 100644 --- a/modular.scm +++ b/modular.scm @@ -1,5 +1,5 @@ ;;;; "modular.scm", modular fixnum arithmetic for Scheme -;;; Copyright (C) 1991, 1993, 1995 Aubrey Jaffer +;;; Copyright (C) 1991, 1993, 1995, 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,45 +17,128 @@ ;promotional, or sales literature without prior written consent in ;each case. +(require 'multiarg/and-) + +;;@code{(require 'modular)} +;;@ftindex modular + +;;@body +;;These procedures implement the Common-Lisp functions of the same names. +;;The real number @var{x2} must be non-zero. +;;@code{mod} returns @code{(- @var{x1} (* @var{x2} (floor (/ @var{x1} @var{x2}))))}. +;;@code{rem} returns @code{(- @var{x1} (* @var{x2} (truncate (/ @var{x1} @var{x2}))))}. +;; +;;If @var{x1} and @var{x2} are integers, then @code{mod} behaves like +;;@code{modulo} and @code{rem} behaves like @code{remainder}. +;; +;;@format +;;@t{(mod -90 360) @result{} 270 +;;(rem -90 180) @result{} -90 +;; +;;(mod 540 360) @result{} 180 +;;(rem 540 360) @result{} 180 +;; +;;(mod (* 5/2 pi) (* 2 pi)) @result{} 1.5707963267948965 +;;(rem (* -5/2 pi) (* 2 pi)) @result{} -1.5707963267948965 +;;} +;;@end format +(define (mod x1 x2) + (if (and (integer? x1) (exact? x1) (integer? x2) (exact? x2)) + (modulo x1 x2) + (- x1 (* x2 (floor (/ x1 x2)))))) +(define (rem x1 x2) + (if (and (integer? x1) (exact? x1) (integer? x2) (exact? x2)) + (remainder x1 x2) + (- x1 (* x2 (truncate (/ x1 x2)))))) + +;;@args n1 n2 +;;Returns a list of 3 integers @code{(d x y)} such that d = gcd(@var{n1}, +;;@var{n2}) = @var{n1} * x + @var{n2} * y. +(define (extended-euclid x y) + (define q 0) + (do ((r0 x r1) (r1 y (remainder r0 r1)) + (u0 1 u1) (u1 0 (- u0 (* q u1))) + (v0 0 v1) (v1 1 (- v0 (* q v1)))) + ;; (assert (= r0 (+ (* u0 x) (* v0 y)))) + ;; (assert (= r1 (+ (* u1 x) (* v1 y)))) + ((zero? r1) (list r0 u0 v0)) + (set! q (quotient r0 r1)))) + +(define modular:extended-euclid extended-euclid) + +;;@body +;;Returns @code{(quotient (+ -1 n) -2)} for positive odd integer @var{n}. (define (symmetric:modulus n) (cond ((or (not (number? n)) (not (positive? n)) (even? n)) (slib:error 'symmetric:modulus n)) (else (quotient (+ -1 n) -2)))) +;;@args modulus +;;Returns the non-negative integer characteristic of the ring formed when +;;@var{modulus} is used with @code{modular:} procedures. (define (modulus->integer m) (cond ((negative? m) (- 1 m m)) ((zero? m) #f) (else m))) -(define (modular:normalize m k) - (cond ((positive? m) (modulo k m)) - ((zero? m) k) - ((<= m k (- m)) k) - ((or (provided? 'bignum) - (<= m (quotient (+ -1 most-positive-fixnum) 2))) - (let* ((pm (+ 1 (* -2 m))) - (s (modulo k pm))) - (if (<= s (- m)) s (- s pm)))) - ((positive? k) (+ (+ (+ k -1) m) m)) - (else (- (- (+ k 1) m) m)))) +;;@args modulus n +;;Returns the integer @code{(modulo @var{n} (modulus->integer +;;@var{modulus}))} in the representation specified by @var{modulus}. +(define modular:normalize + (if (provided? 'bignum) + (lambda (m k) + (cond ((positive? m) (modulo k m)) + ((zero? m) k) + ((<= m k (- m)) k) + (else + (let* ((pm (+ 1 (* -2 m))) + (s (modulo k pm))) + (if (<= s (- m)) s (- s pm)))))) + (lambda (m k) + (cond ((positive? m) (modulo k m)) + ((zero? m) k) + ((<= m k (- m)) k) + ((<= m (quotient (+ -1 most-positive-fixnum) 2)) + (let* ((pm (+ 1 (* -2 m))) + (s (modulo k pm))) + (if (<= s (- m)) s (- s pm)))) + ((positive? k) (+ (+ (+ k -1) m) m)) + (else (- (- (+ k 1) m) m)))))) ;;;; NOTE: The rest of these functions assume normalized arguments! -(require 'logical) +;;@noindent +;;The rest of these functions assume normalized arguments; That is, the +;;arguments are constrained by the following table: +;; +;;@noindent +;;For all of these functions, if the first argument (@var{modulus}) is: +;;@table @code +;;@item positive? +;;Work as before. The result is between 0 and @var{modulus}. +;; +;;@item zero? +;;The arguments are treated as integers. An integer is returned. +;; +;;@item negative? +;;The arguments and result are treated as members of the integers modulo +;;@code{(+ 1 (* -2 @var{modulus}))}, but with @dfn{symmetric} +;;representation; i.e. @code{(<= (- @var{modulus}) @var{n} +;;@var{modulus})}. +;;@end table -(define (modular:extended-euclid x y) - (define q 0) - (do ((r0 x r1) (r1 y (remainder r0 r1)) - (u0 1 u1) (u1 0 (- u0 (* q u1))) - (v0 0 v1) (v1 1 (- v0 (* q v1)))) - ;; (assert (= r0 (+ (* u0 x) (* v0 y)))) - ;; (assert (= r1 (+ (* u1 x) (* v1 y)))) - ((zero? r1) (list r0 u0 v0)) - (set! q (quotient r0 r1)))) +;;@noindent +;;If all the arguments are fixnums the computation will use only fixnums. +;;@args modulus k +;;Returns @code{#t} if there exists an integer n such that @var{k} * n +;;@equiv{} 1 mod @var{modulus}, and @code{#f} otherwise. (define (modular:invertable? m a) (eqv? 1 (gcd (or (modulus->integer m) 0) a))) +;;@args modulus n2 +;;Returns an integer n such that 1 = (n * @var{n2}) mod @var{modulus}. If +;;@var{n2} has no inverse mod @var{modulus} an error is signaled. (define (modular:invert m a) (cond ((eqv? 1 (abs a)) a) ; unit (else @@ -68,12 +151,17 @@ (slib:error 'modular:invert "can't invert" m a)))) (else (slib:error 'modular:invert "can't invert" m a))))))) +;;@args modulus n2 +;;Returns (@minus{}@var{n2}) mod @var{modulus}. (define (modular:negate m a) (if (zero? a) 0 (if (negative? m) (- a) (- m a)))) ;;; Being careful about overflow here + +;;@args modulus n2 n3 +;;Returns (@var{n2} + @var{n3}) mod @var{modulus}. (define (modular:+ m a b) (cond ((positive? m) (modulo (+ (- a m) b) m)) @@ -91,6 +179,8 @@ (+ s -1 m) (- s m)))))) +;;@args modulus n2 n3 +;;Returns (@var{n2} @minus{} @var{n3}) mod @var{modulus}. (define (modular:- m a b) (cond ((positive? m) (modulo (- a b) m)) ((zero? m) (- a b)) @@ -102,7 +192,15 @@ ;;; modular:r = 2**((nb-2)/2) where nb = number of bits in a word. (define modular:r - (ash 1 (quotient (integer-length most-positive-fixnum) 2))) + (do ((mpf most-positive-fixnum (quotient mpf 4)) + (r 1 (* 2 r))) + ((<= mpf 0) (quotient r 2)))) + +;;@args modulus n2 n3 +;;Returns (@var{n2} * @var{n3}) mod @var{modulus}. +;; +;;The Scheme code for @code{modular:*} with negative @var{modulus} is +;;not completed for fixnum-only implementations. (define modular:* (if (provided? 'bignum) (lambda (m a b) @@ -115,9 +213,8 @@ (cond ((zero? m) (* a b)) ((negative? m) - "This doesn't work for the full range of modulus M;" - "Someone please create or convert the following" - "algorighm to work with symmetric representation" + ;; This doesn't work for the full range of modulus M. + ;; Need algorighm to work with symmetric representation. (modular:normalize m (* a b))) (else (cond @@ -146,13 +243,22 @@ (modulo (+ (if (positive? p) (- p m) p) (* a0 (modulo b q))) m))))))))) -(define (modular:expt m a b) - (cond ((= a 1) 1) - ((= a (- m 1)) (if (odd? b) a 1)) - ((zero? a) 0) - ((zero? m) (integer-expt a b)) - (else - (logical:ipow-by-squaring a b 1 - (lambda (c d) (modular:* m c d)))))) - -(define extended-euclid modular:extended-euclid) +;;@args modulus n2 n3 +;;Returns (@var{n2} ^ @var{n3}) mod @var{modulus}. +(define modular:expt + (let ((integer-expt (and (provided? 'inexact) expt))) + (lambda (m n xpn) + (cond ((= n 1) 1) + ((= n (- m 1)) (if (odd? xpn) n 1)) + ((and (zero? m) integer-expt) (integer-expt n xpn)) + ((negative? xpn) + (modular:expt m (modular:invert m n) (- xpn))) + ((zero? n) 0) + (else + (do ((x n (modular:* m x x)) + (j xpn (quotient j 2)) + (acc 1 (if (even? j) acc (modular:* m x acc)))) + ((<= j 1) + (case j + ((0) acc) + ((1) (modular:* m x acc)))))))))) diff --git a/modular.txi b/modular.txi new file mode 100644 index 0000000..d947b35 --- /dev/null +++ b/modular.txi @@ -0,0 +1,114 @@ +@code{(require 'modular)} +@ftindex modular + + +@defun mod x1 x2 +@defunx rem x1 x2 + +These procedures implement the Common-Lisp functions of the same names. +The real number @var{x2} must be non-zero. +@code{mod} returns @code{(- @var{x1} (* @var{x2} (floor (/ @var{x1} @var{x2}))))}. +@code{rem} returns @code{(- @var{x1} (* @var{x2} (truncate (/ @var{x1} @var{x2}))))}. + +If @var{x1} and @var{x2} are integers, then @code{mod} behaves like +@code{modulo} and @code{rem} behaves like @code{remainder}. + +@format +@t{(mod -90 360) @result{} 270 +(rem -90 180) @result{} -90 + +(mod 540 360) @result{} 180 +(rem 540 360) @result{} 180 + +(mod (* 5/2 pi) (* 2 pi)) @result{} 1.5707963267948965 +(rem (* -5/2 pi) (* 2 pi)) @result{} -1.5707963267948965 +} +@end format +@end defun + +@defun extended-euclid n1 n2 + +Returns a list of 3 integers @code{(d x y)} such that d = gcd(@var{n1}, +@var{n2}) = @var{n1} * x + @var{n2} * y. +@end defun + +@defun symmetric:modulus n + +Returns @code{(quotient (+ -1 n) -2)} for positive odd integer @var{n}. +@end defun + +@defun modulus->integer modulus + +Returns the non-negative integer characteristic of the ring formed when +@var{modulus} is used with @code{modular:} procedures. +@end defun + +@defun modular:normalize modulus n + +Returns the integer @code{(modulo @var{n} (modulus->integer +@var{modulus}))} in the representation specified by @var{modulus}. +@end defun +@noindent +The rest of these functions assume normalized arguments; That is, the +arguments are constrained by the following table: + +@noindent +For all of these functions, if the first argument (@var{modulus}) is: +@table @code +@item positive? +Work as before. The result is between 0 and @var{modulus}. + +@item zero? +The arguments are treated as integers. An integer is returned. + +@item negative? +The arguments and result are treated as members of the integers modulo +@code{(+ 1 (* -2 @var{modulus}))}, but with @dfn{symmetric} +@cindex symmetric +representation; i.e. @code{(<= (- @var{modulus}) @var{n} +@var{modulus})}. +@end table + +@noindent +If all the arguments are fixnums the computation will use only fixnums. + + +@defun modular:invertable? modulus k + +Returns @code{#t} if there exists an integer n such that @var{k} * n +@equiv{} 1 mod @var{modulus}, and @code{#f} otherwise. +@end defun + +@defun modular:invert modulus n2 + +Returns an integer n such that 1 = (n * @var{n2}) mod @var{modulus}. If +@var{n2} has no inverse mod @var{modulus} an error is signaled. +@end defun + +@defun modular:negate modulus n2 + +Returns (@minus{}@var{n2}) mod @var{modulus}. +@end defun + +@defun modular:+ modulus n2 n3 + +Returns (@var{n2} + @var{n3}) mod @var{modulus}. +@end defun + +@defun modular:- modulus n2 n3 + +Returns (@var{n2} @minus{} @var{n3}) mod @var{modulus}. +@end defun + +@defun modular:* modulus n2 n3 + +Returns (@var{n2} * @var{n3}) mod @var{modulus}. + +The Scheme code for @code{modular:*} with negative @var{modulus} is +not completed for fixnum-only implementations. +@end defun + +@defun modular:expt modulus n2 n3 + +Returns (@var{n2} ^ @var{n3}) mod @var{modulus}. +@end defun diff --git a/mulapply.scm b/mulapply.scm index 4f0853c..6c58959 100644 --- a/mulapply.scm +++ b/mulapply.scm @@ -1,5 +1,5 @@ ; "mulapply.scm" Redefine APPLY take more than 2 arguments. -;Copyright (C) 1991 Aubrey Jaffer +;Copyright (C) 1991, 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. ; @@ -16,13 +16,13 @@ ;material, there shall be no use of my name in any advertising, ;promotional, or sales literature without prior written consent in ;each case. - -(define two-arg:apply apply) +;@ (define apply - (lambda args - (two-arg:apply (car args) (apply:append-to-last (cdr args))))) - -(define (apply:append-to-last lst) - (if (null? (cdr lst)) - (car lst) - (cons (car lst) (apply:append-to-last (cdr lst))))) + (letrec ((apply-2 apply) + (append-to-last + (lambda (lst) + (if (null? (cdr lst)) + (car lst) + (cons (car lst) (append-to-last (cdr lst))))))) + (lambda args + (apply-2 (car args) (append-to-last (cdr args)))))) @@ -1,14 +1,10 @@ ;;; "mularg.scm" Redefine - and / to take more than 2 arguments. -(define two-arg:/ /) -(define two-arg:- -) -(define / /) -(define - -) -(let ((maker - (lambda (op) - (lambda (d1 . ds) - (cond ((null? ds) (op d1)) - ((null? (cdr ds)) (op d1 (car ds))) - (else (for-each (lambda (d) (set! d1 (op d1 d))) ds) d1)))))) - (set! / (maker /)) - (set! - (maker -))) +(define (mul:argumentizer op) + (lambda (d1 . ds) + (cond ((null? ds) (op d1)) + ((null? (cdr ds)) (op d1 (car ds))) + (else (for-each (lambda (d) (set! d1 (op d1 d))) ds) d1)))) +;@ +(define / (let ((/ /)) (mul:argumentizer /))) +(define - (let ((- -)) (mul:argumentizer -))) diff --git a/mwexpand.scm b/mwexpand.scm index 9dea34b..07acf1d 100644 --- a/mwexpand.scm +++ b/mwexpand.scm @@ -29,7 +29,7 @@ (define mw:quit ; assigned by macwork:expand (lambda (v) v)) - +;@ (define (macwork:expand def-or-exp) (call-with-current-continuation (lambda (k) @@ -329,30 +329,30 @@ (define (mw:let-syntax exp env) (if (and (> (mw:safe-length exp) 2) - (comlist:every (lambda (binding) - (and (pair? binding) - (symbol? (car binding)) - (pair? (cdr binding)) - (null? (cddr binding)))) - (cadr exp))) + (mw:every (lambda (binding) + (and (pair? binding) + (symbol? (car binding)) + (pair? (cdr binding)) + (null? (cddr binding)))) + (cadr exp))) (mw:body (cddr exp) - (mw:syntax-extend env - (map car (cadr exp)) - (map (lambda (spec) - (mw:compile-transformer-spec - spec - env)) - (map cadr (cadr exp))))) + (mw:syntax-extend env + (map car (cadr exp)) + (map (lambda (spec) + (mw:compile-transformer-spec + spec + env)) + (map cadr (cadr exp))))) (mw:error "Malformed let-syntax" exp env))) (define (mw:letrec-syntax exp env) (if (and (> (mw:safe-length exp) 2) - (comlist:every (lambda (binding) - (and (pair? binding) - (symbol? (car binding)) - (pair? (cdr binding)) - (null? (cddr binding)))) - (cadr exp))) + (mw:every (lambda (binding) + (and (pair? binding) + (symbol? (car binding)) + (pair? (cdr binding)) + (null? (cddr binding)))) + (cadr exp))) (let ((env (mw:syntax-extend env (map car (cadr exp)) (map (lambda (id) diff --git a/mwsynrul.scm b/mwsynrul.scm index bc5d7de..0ced293 100644 --- a/mwsynrul.scm +++ b/mwsynrul.scm @@ -72,7 +72,7 @@ (let ((literals (cadr spec)) (rules (cddr spec))) (if (or (not (list? literals)) - (not (comlist:every (lambda (rule) + (not (mw:every (lambda (rule) (and (= (mw:safe-length rule) 2) (pair? (car rule)))) rules))) @@ -115,7 +115,7 @@ (+ rank 1) (lambda (P vars1) (k (mw:make-ellipsis-pattern P vars1) - (comlist:union vars1 vars)))) + (mw:union vars1 vars)))) (mw:error "Malformed pattern" P)) (loop (car P) vars @@ -201,7 +201,7 @@ (lambda (T2 inserted referenced) (k (cons (mw:make-ellipsis-template T1 - (comlist:remove-if-not + (mw:remove-if-not (lambda (var) (> (mw:patternvar-rank var) rank)) referenced1)) @@ -259,7 +259,7 @@ (let* ((P1 (mw:ellipsis-pattern P)) (answers (map (lambda (F) (match F P1 answer rank)) F))) - (if (comlist:every identity answers) + (if (mw:every identity answers) (append (map (lambda (var) (cons var (map (lambda (answer) diff --git a/ncbi-dna.scm b/ncbi-dna.scm new file mode 100644 index 0000000..03fff65 --- /dev/null +++ b/ncbi-dna.scm @@ -0,0 +1,172 @@ +;;;; "ncbi-dna.scm" Read and manipulate NCBI-format nucleotide sequences +;;; 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 'scanf) +(require 'string-case) +(require 'string-search) +(require 'array-for-each) +(require-if 'compiling 'printf) ;used by cDNA:report-base-count + +(define (ncbi:read-DNA-line port) + (define lst (scanf-read-list + " %d %[acgt] %[acgt] %[acgt] %[acgt] %[acgt] %[acgt]" port)) + (cond ((or (null? lst) (eof-object? lst)) #f) + ((not (eqv? 1 (modulo (car lst) 60))) + (slib:warn 'bad 'idx lst) #f) + (else (apply string-append (cdr lst))))) + +;;@body +;;Reads the NCBI-format DNA sequence following the word @samp{ORIGIN} +;;from @1. +(define (ncbi:read-DNA-sequence port) + (find-string-from-port? "ORIGIN" port) + (find-string-from-port? (string #\newline) port) + (do ((lne (ncbi:read-DNA-line port) (ncbi:read-DNA-line port)) + (lns '() (cons lne lns))) + ((not lne) (apply string-append (reverse lns))))) + +;;@body +;;Reads the NCBI-format DNA sequence following the word @samp{ORIGIN} +;;from @1. +(define (ncbi:read-file file) + (call-with-input-file file ncbi:read-DNA-sequence)) + +;;@body +;;Replaces @samp{T} with @samp{U} in @1 +(define (mRNA<-cDNA str) + (array-for-each + (lambda (chr) + (case chr + ((#\a) #\a) + ((#\t) #\u) + ((#\c) #\c) + ((#\g) #\g) + ((#\A) #\A) + ((#\T) #\U) + ((#\C) #\C) + ((#\G) #\G) + (else chr))) + str)) + +(define cDNA:codons + '((TTT phe #\F) (TCT ser #\S) (TAT tyr #\Y) (TGT cys #\C) + (TTC phe #\F) (TCC ser #\S) (TAC tyr #\Y) (TGC cys #\C) + (TTA leu #\L) (TCA ser #\S) (TAA) (TGA) ;stops + (TTG leu #\L) (TCG ser #\S) (TAG) (TGG trp #\W) + (CTT leu #\L) (CCT pro #\P) (CAT his #\H) (CGT arg #\R) + (CTC leu #\L) (CCC pro #\P) (CAC his #\H) (CGC arg #\R) + (CTA leu #\L) (CCA pro #\P) (CAA gln #\Q) (CGA arg #\R) + (CTG leu #\L) (CCG pro #\P) (CAG gln #\Q) (CGG arg #\R) + (ATT ile #\I) (ACT thr #\T) (AAT asn #\N) (AGT ser #\S) + (ATC ile #\I) (ACC thr #\T) (AAC asn #\N) (AGC ser #\S) + (ATA ile #\I) (ACA thr #\T) (AAA lys #\K) (AGA arg #\R) + (ATG met #\M) (ACG thr #\T) (AAG lys #\K) (AGG arg #\R) + (GTT val #\V) (GCT ala #\A) (GAT asp #\D) (GGT gly #\G) + (GTC val #\V) (GCC ala #\A) (GAC asp #\D) (GGC gly #\G) + (GTA val #\V) (GCA ala #\A) (GAA glu #\E) (GGA gly #\G) + (GTG val #\V) (GCG ala #\A) (GAG glu #\E) (GGG gly #\G))) + +;;@body +;;Returns a list of three-letter symbol codons comprising the protein +;;sequence encoded by @1 starting with its first occurence of +;;@samp{atg}. +(define (codons<-cDNA cDNA) + (define len (string-length cDNA)) + (define start #f) + (set! start (substring-ci? "atg" cDNA)) + (if (not start) (slib:warn 'missed 'start)) + (let loop ((protein '(*N*)) + (cdx (or start 0))) + (if (<= len cdx) (slib:error 'reached 'end cdx)) + (let ((codon (string-ci->symbol (substring cDNA cdx (+ 3 cdx))))) + (define asc (assq codon cDNA:codons)) + (cond ((not asc) + (slib:warn 'mystery 'codon codon) + (reverse (cons '*C* protein))) + ((null? (cdr asc)) (reverse (cons '*C* protein))) + (else (loop (cons codon protein) (+ 3 cdx))))))) + +;;@body +;;Returns a list of three-letter symbols for the protein sequence +;;encoded by @1 starting with its first occurence of @samp{atg}. +(define (protein<-cDNA cDNA) + (define len (string-length cDNA)) + (define start #f) + (set! start (substring-ci? "atg" cDNA)) + (if (not start) (slib:warn 'missed 'start)) + (let loop ((protein '(*N*)) + (cdx (or start 0))) + (if (<= len cdx) (slib:error 'reached 'end cdx)) + (let ((codon (string-ci->symbol (substring cDNA cdx (+ 3 cdx))))) + (define asc (assq codon cDNA:codons)) + (cond ((not asc) + (slib:warn 'mystery 'codon codon) + (reverse (cons '*C* protein))) + ((null? (cdr asc)) (reverse (cons '*C* protein))) + (else (loop (cons (cadr asc) protein) (+ 3 cdx))))))) + +;;@body +;;Returns a string of one-letter amino acid codes for the protein +;;sequence encoded by @1 starting with its first occurence of +;;@samp{atg}. +(define (P<-cDNA cDNA) + (define len (string-length cDNA)) + (define start #f) + (set! start (substring-ci? "atg" cDNA)) + (if (not start) (slib:warn 'missed 'start)) + (let loop ((protein '()) + (cdx (or start 0))) + (if (<= len cdx) (slib:error 'reached 'end cdx)) + (let ((codon (string-ci->symbol (substring cDNA cdx (+ 3 cdx))))) + (define asc (assq codon cDNA:codons)) + (cond ((not asc) (slib:error 'mystery 'codon codon)) + ((null? (cdr asc)) (list->string (reverse protein))) + (else (loop (cons (caddr asc) protein) (+ 3 cdx))))))) + +;;@ +;;These cDNA count routines provide a means to check the nucleotide +;;sequence with the @samp{BASE COUNT} line preceding the sequence from +;;NCBI. + +;;@body +;;Returns a list of counts of @samp{a}, @samp{c}, @samp{g}, and +;;@samp{t} occurrencing in @1. +(define (cDNA:base-count cDNA) + (define cnt:a 0) + (define cnt:c 0) + (define cnt:g 0) + (define cnt:t 0) + (array-for-each (lambda (chr) + (case chr + ((#\a #\A) (set! cnt:a (+ 1 cnt:a))) + ((#\c #\C) (set! cnt:c (+ 1 cnt:c))) + ((#\g #\G) (set! cnt:g (+ 1 cnt:g))) + ((#\t #\T) (set! cnt:t (+ 1 cnt:t))) + (else (slib:error 'cDNA:base-count 'unknown 'base chr)))) + cDNA) + (list cnt:a cnt:c cnt:g cnt:t)) + +;;@body +;;Prints the counts of @samp{a}, @samp{c}, @samp{g}, and @samp{t} +;;occurrencing in @1. +(define (cDNA:report-base-count cDNA) + (require 'printf) + (apply printf "BASE COUNT %6d a %6d c %6d g %6d t\\n" + (cDNA:base-count cDNA))) diff --git a/ncbi-dna.txi b/ncbi-dna.txi new file mode 100644 index 0000000..9a5babc --- /dev/null +++ b/ncbi-dna.txi @@ -0,0 +1,54 @@ + +@defun ncbi:read-dna-sequence port + +Reads the NCBI-format DNA sequence following the word @samp{ORIGIN} +from @var{port}. +@end defun + +@defun ncbi:read-file file + +Reads the NCBI-format DNA sequence following the word @samp{ORIGIN} +from @var{file}. +@end defun + +@defun mrna<-cdna str + +Replaces @samp{T} with @samp{U} in @var{str} +@end defun + +@defun codons<-cdna cdna + +Returns a list of three-letter symbol codons comprising the protein +sequence encoded by @var{cdna} starting with its first occurence of +@samp{atg}. +@end defun + +@defun protein<-cdna cdna + +Returns a list of three-letter symbols for the protein sequence +encoded by @var{cdna} starting with its first occurence of @samp{atg}. +@end defun + +@defun p<-cdna cdna + +Returns a string of one-letter amino acid codes for the protein +sequence encoded by @var{cdna} starting with its first occurence of +@samp{atg}. +@end defun + +These cDNA count routines provide a means to check the nucleotide +sequence with the @samp{BASE COUNT} line preceding the sequence from +NCBI. + + +@defun cdna:base-count cdna + +Returns a list of counts of @samp{a}, @samp{c}, @samp{g}, and +@samp{t} occurrencing in @var{cdna}. +@end defun + +@defun cdna:report-base-count cdna + +Prints the counts of @samp{a}, @samp{c}, @samp{g}, and @samp{t} +occurrencing in @var{cdna}. +@end defun diff --git a/nclients.scm b/nclients.scm deleted file mode 100644 index 08f3d0b..0000000 --- a/nclients.scm +++ /dev/null @@ -1,385 +0,0 @@ -;;; "nclients.scm" Interface to net-client programs. -; Copyright 1997, 1998 Aubrey Jaffer -; -;Permission to copy this software, to modify it, to redistribute it, -;to distribute modified versions, and to use it for any purpose is -;granted, subject to the following restrictions and understandings. -; -;1. Any copy made of this software must include this copyright notice -;in full. -; -;2. I have made no warrantee 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 'string-search) -(require 'line-i/o) -(require 'system) -(require 'printf) -(require 'scanf) - -;;@args proc -;;@args proc k -;;Calls @1 with @var{k} 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. @var{k} may be ommited, in which case -;;it defaults to @code{1}. -(define (call-with-tmpnam proc . k) - (do ((cnt (if (null? k) 0 (+ -1 (car k))) (+ -1 cnt)) - (paths '() (cons (tmpnam) paths))) - ((negative? cnt) - (let ((ans (apply proc paths))) - (for-each (lambda (path) (if (file-exists? path) (delete-file path))) - paths) - ans)))) - -;;@args -;;@0 returns a string of the form @samp{username@r{@@}hostname}. If -;;this e-mail address cannot be obtained, #f is returned. -(define user-email-address - (let ((user (or (getenv "USER") (getenv "USERNAME"))) - (hostname (getenv "HOSTNAME"))) ;with domain - (lambda () - (if (not (and user hostname)) - (call-with-tmpnam - (lambda (tmp) - (define command->string - (lambda (command) - (and (zero? (system (string-append command " >" tmp))) - (file-exists? tmp) - (let ((res #f)) - (call-with-input-file tmp - (lambda (port) - (and (eqv? 1 (fscanf port "%s" res)) res))))))) - (case (software-type) - ;;((AMIGA) ) - ;;((MACOS THINKC) ) - ((MS-DOS WINDOWS OS/2 ATARIST) - (let ((compname (getenv "COMPUTERNAME")) ;without domain - (workgroup #f) - (netdir (or (getenv "windir") - (getenv "winbootdir") - (and (getenv "SYSTEMROOT") - (string-append (getenv "SYSTEMROOT") - "\\system32")) - "C:\\windows"))) - (define (net . cmd) - (zero? (system (apply string-append - (or netdir "") - (if netdir "\\" "") - "NET " cmd)))) - (and (not (and user hostname)) - (zero? (system (string-append - (or netdir "") - (if netdir "\\" "") - "IPCONFIG /ALL > " tmp " "))) - (file-exists? tmp) - ;;(print tmp '=) (display-file tmp) - (call-with-input-file tmp - (lambda (port) - (find-string-from-port? "Host Name" port) - (fscanf port " %*[. ]: %s" hostname) - (delete-file tmp)))) - (and (not (and user hostname)) - (net "START /LIST >" tmp) - (file-exists? tmp) - (not (eof-object? (call-with-input-file tmp read-char))) - (cond - ((call-with-input-file tmp - (lambda (port) - (find-string-from-port? "o network servic" port))) - (and (net "CONFIG /YES >" tmp) - (net "STOP /YES"))) - (else (net "CONFIG /YES >" tmp))) - (call-with-input-file tmp - (lambda (port) - (do ((line (read-line port) (read-line port))) - ((eof-object? line)) - (sscanf line " Workstation root directory %s" - netdir) - (sscanf line " Computer name \\\\%s" compname) - (sscanf line " Workstation Domain %s" workgroup) - (sscanf line " Workgroup %s" workgroup) - (sscanf line " User name %s" user))))) - (and netdir (not (and user hostname)) - (set! netdir (string-append netdir "\\system.ini")) - (file-exists? netdir) - (call-with-input-file netdir - (lambda (port) - (and (find-string-from-port? "[DNS]" port) - (read-line port) ;past newline - (do ((line (read-line port) (read-line port))) - ((not (and (string? line) - (string-index line #\=)))) - (sscanf line "HostName=%s" compname) - (sscanf line "DomainName=%s" workgroup))))) - (not user) - (call-with-input-file netdir - (lambda (port) - (and (find-string-from-port? "[Network]" port) - (read-line port) ;past newline - (do ((line (read-line port) (read-line port))) - ((not (and (string? line) - (string-index line #\=)))) - (sscanf line "UserName=%s" user)))))) - (if (and compname (not hostname)) - (set! hostname - (string-append - compname "." (or workgroup "localnet")))))) - ;;((NOSVE) ) - ;;((VMS) ) - ((UNIX COHERENT) - (if (not user) - (set! user (command->string "whoami"))) - (if (not hostname) - (set! hostname (command->string "hostname"))))) - (if (not user) (set! user "John_Doe")) - (if (not hostname) (set! hostname "localhost"))))) - (string-append user "@" hostname)))) - -;;@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, the value of @0 is -;;#f. -(define current-directory - (case (software-type) - ;;((AMIGA) ) - ;;((MACOS THINKC) ) - ((MS-DOS WINDOWS ATARIST OS/2) - (lambda () - (call-with-tmpnam - (lambda (tmp) - (and (zero? (system (string-append "cd >" tmp))) - (file-exists? tmp) - (call-with-input-file tmp - (lambda (port) - (let ((lst (scanf-read-list "%[^:]%[:] %s" port))) - (and (pair? lst) - (eqv? 3 (length lst)) - (apply string-append lst)))))))))) - ;;((NOSVE) ) - ((UNIX COHERENT) - (lambda () - (call-with-tmpnam - (lambda (tmp) - (and (zero? (system (string-append "pwd >" tmp))) - (file-exists? tmp) - (let ((path (call-with-input-file tmp read-line))) - (and (string? path) path))))))) - ;;((VMS) ) - (else #f))) - -;;@body -;;Creates a sub-directory @1 of the current-directory. If successful, -;;@0 returns #t; otherwise #f. -(define (make-directory name) - (zero? (system (string-append "mkdir " name)))) - -;;@body -;;Returns #t if changing directory to @1 makes the current working -;;directory the same as it is before changing directory; otherwise -;;returns #f. -(define (null-directory? file-name) - (member file-name '("" "." "./" ".\\"))) - -;;@body -;;Returns #t if @1 is a fully specified pathname (does not depend on -;;the current working directory); otherwise returns #f. -(define (absolute-path? file-name) - (and (string? file-name) - (positive? (string-length file-name)) - (memv (string-ref file-name 0) '(#\\ #\/)))) - - -;;@body Returns #t if the string @1 contains characters used for -;;specifying glob patterns, namely @samp{*}, @samp{?}, or @samp{[}. -(define (glob-pattern? str) - (let loop ((idx (+ -1 (string-length str)))) - (if (negative? idx) - #f - (case (string-ref str idx) - ((#\* #\[ #\?) #t) - (else (loop (+ -1 idx))))))) - -;;@body -;;Returns a list of the decoded FTP @1; or #f if indecipherable. FTP -;;@dfn{Uniform Resource Locator}, @dfn{ange-ftp}, and @dfn{getit} -;;formats are handled. The returned list has four elements which are -;;strings or #f: -;; -;;@enumerate 0 -;;@item -;;username -;;@item -;;password -;;@item -;;remote-site -;;@item -;;remote-directory -;;@end enumerate -(define (parse-ftp-address uri) - (define length? (lambda (len lst) (and (eqv? len (length lst)) lst))) - (cond - ((not uri) #f) - ((length? 1 (scanf-read-list " ftp://%s %s" uri)) - => (lambda (host) - (let ((login #f) (path #f) (dross #f)) - (sscanf (car host) "%[^/]/%[^@]%s" login path dross) - (and login - (append (cond - ((length? 2 (scanf-read-list "%[^@]@%[^@]%s" login)) - => (lambda (userpass@hostport) - (append - (cond ((length? 2 (scanf-read-list - "%[^:]:%[^@/]%s" - (car userpass@hostport)))) - (else (list (car userpass@hostport) #f))) - (cdr userpass@hostport)))) - (else (list "anonymous" #f login))) - (list path)))))) - (else - (let ((user@site #f) (colon #f) (path #f) (dross #f)) - (case (sscanf uri " %[^:]%[:]%[^@] %s" user@site colon path dross) - ((2 3) - (let ((user #f) (site #f)) - (cond ((or (eqv? 2 (sscanf user@site "/%[^@/]@%[^@]%s" - user site dross)) - (eqv? 2 (sscanf user@site "%[^@/]@%[^@]%s" - user site dross))) - (list user #f site path)) - ((eqv? 1 (sscanf user@site "@%[^@]%s" site dross)) - (list #f #f site path)) - (else (list #f #f user@site path))))) - (else - (let ((site (scanf-read-list " %[^@/] %s" uri))) - (and (length? 1 site) (list #f #f (car site) #f))))))))) - -;;@body -;;@3 must be a non-empty string or #f. @1 must be a non-empty list -;;of pathnames or Glob patterns (@pxref{Filenames}) matching files to -;;transfer. -;; -;;@0 puts the files specified by @1 into the @5 directory of FTP @4 -;;using name @2 with (optional) @3. -;; -;;If @3 is #f and @2 is not @samp{ftp} or @samp{anonymous}, then @2 is -;;ignored; FTP takes the username and password from the @file{.netrc} -;;or equivalent file. -(define (ftp-upload paths user password remote-site remote-dir) - (call-with-tmpnam - (lambda (script logfile) - (define local-path (current-directory)) - (define passwd (or password (user-email-address))) - (dynamic-wind - (lambda () #f) - (lambda () - (call-with-current-continuation - (lambda (exit) - (define (run-ftp-script paths) - (call-with-output-file script - (lambda (port) - (define lcd "") - (cond ((or (member user '(ftp anonymous "ftp" "anonymous")) - password) - (fprintf port "user %s %s\n" user passwd))) - (fprintf port "binary\n") ; Turn binary ON for all transfers - ;;(fprintf port "prompt\n") ; Turn prompt OFF for possible mget - (if (not (null-directory? remote-dir)) - (fprintf port "cd %s\n" remote-dir)) - (for-each - (lambda (path-name) - (let* ((r/i (string-reverse-index path-name #\/)) - (dir (if r/i (substring path-name 0 (+ 1 r/i)) "")) - (file-name (if r/i - (substring path-name (+ 1 r/i) - (string-length path-name)) - path-name))) - (cond ((and r/i (glob-pattern? dir)) - (slib:warn - "Wildcard not allowed in directory component " - path-name) - (exit #f)) - ((and (not (glob-pattern? file-name)) - (not (file-exists? path-name))) - (slib:warn " file doesn't exist:" path-name) - (exit #f)) - ((equal? lcd dir)) - ((absolute-path? dir) - (fprintf port "lcd %s\n" dir)) - ((eqv? 0 (substring? lcd dir)) - (fprintf port "lcd %s\n" - (substring dir (string-length lcd) - (string-length dir)))) - (else - (fprintf port "lcd %s\n" local-path) - (if (not (null-directory? dir)) - (fprintf port "lcd %s\n" dir)))) - (set! lcd dir) - (cond ((glob-pattern? file-name) - (fprintf port "mput %s\n" file-name)) - (else - (fprintf port "put %s\n" file-name))))) - paths))) - ;;(display-file script) - (cond - ((zero? (system - (string-append - "ftp " - (if (or (member user '(ftp anonymous "ftp" "anonymous")) - password) - "-inv" "-iv") - " " remote-site - " <" script - " >" logfile))) - (file-exists? logfile) - (call-with-input-file logfile - (lambda (port) - (do ((line (read-line port) (read-line port))) - ((or (eof-object? line) - (substring-ci? "Unknown host" line) - (substring-ci? "Not connected" line) - (and (memv (string-ref line 0) '(#\4 #\5)) - (not (substring-ci? "bytes" line)))) - (cond ((eof-object? line) #t) - (else (slib:warn line) #f))) - ;;(write-line line) - )))) - (else (slib:warn 'ftp 'failed) #f))) - (cond ((or local-path (every? absolute-file? paths)) - (run-ftp-script paths)) - (else (for-each (lambda (path) (run-ftp-script (list path))) - paths)))))) - (lambda () - (if (file-exists? script) (delete-file script)) - (if (file-exists? logfile) (delete-file logfile))))) - 2)) - -;;@body -;;Returns a URI-string for @1 on the local host. -(define (path->uri path) - (if (absolute-path? path) - (sprintf #f "file:%s" path) - (sprintf #f "file:%s/%s" (current-directory) path))) - -;;@body -;;If a @samp{netscape} browser is running, @0 causes the browser to -;;display the page specified by string @1 and returns #t. -;; -;;If the browser is not running, @0 runs @samp{netscape} with the -;;argument @1. If the browser starts as a background job, @0 returns -;;#t immediately; if the browser starts as a foreground job, then @0 -;;returns #t when the browser exits; otherwise it returns #f. -(define (browse-url-netscape url) - (or (eqv? 0 (system (sprintf #f "netscape-remote -remote 'openURL(%s)'" url))) - (eqv? 0 (system (sprintf #f "netscape -remote 'openURL(%s)'" url))) - (eqv? 0 (system (sprintf #f "netscape '%s'&" url))) - (eqv? 0 (system (sprintf #f "netscape '%s'" url))))) diff --git a/nclients.txi b/nclients.txi deleted file mode 100644 index ff62436..0000000 --- a/nclients.txi +++ /dev/null @@ -1,103 +0,0 @@ - -@defun call-with-tmpnam proc - - -@defunx call-with-tmpnam proc k -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}. -@end defun - -@defun user-email-address - -@code{user-email-address} returns a string of the form @samp{username@r{@@}hostname}. If -this e-mail address cannot be obtained, #f is returned. -@end defun - -@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, the value of @code{current-directory} is -#f. -@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 null-directory? file-name - -Returns #t if changing directory to @var{file-name} makes the current working -directory the same as it is before changing directory; otherwise -returns #f. -@end defun - -@defun absolute-path? file-name - -Returns #t if @var{file-name} is a fully specified pathname (does not depend on -the current working directory); otherwise returns #f. -@end defun - -@defun glob-pattern? str -Returns #t if the string @var{str} contains characters used for -specifying glob patterns, namely @samp{*}, @samp{?}, or @samp{[}. -@end defun - -@defun parse-ftp-address uri - -Returns a list of the decoded FTP @var{uri}; or #f if indecipherable. FTP -@dfn{Uniform Resource Locator}, @dfn{ange-ftp}, and @dfn{getit} -@cindex Uniform Resource Locator -@cindex ange-ftp -@cindex getit -formats are handled. The returned list has four elements which are -strings or #f: - -@enumerate 0 -@item -username -@item -password -@item -remote-site -@item -remote-directory -@end enumerate -@end defun - -@defun ftp-upload paths user password remote-site remote-dir - -@var{password} must be a non-empty string or #f. @var{paths} must be a non-empty list -of pathnames or Glob patterns (@pxref{Filenames}) matching files to -transfer. - -@code{ftp-upload} puts the files specified by @var{paths} into the @var{remote-dir} directory of FTP @var{remote-site} -using name @var{user} with (optional) @var{password}. - -If @var{password} is #f and @var{user} is not @samp{ftp} or @samp{anonymous}, then @var{user} is -ignored; FTP takes the username and password from the @file{.netrc} -or equivalent file. -@end defun - -@defun path->uri path - -Returns a URI-string for @var{path} on the local host. -@end defun - -@defun browse-url-netscape url - -If a @samp{netscape} browser is running, @code{browse-url-netscape} causes the browser to -display the page specified by string @var{url} and returns #t. - -If the browser is not running, @code{browse-url-netscape} runs @samp{netscape} with the -argument @var{url}. If the browser starts as a background job, @code{browse-url-netscape} returns -#t immediately; if the browser starts as a foreground job, then @code{browse-url-netscape} -returns #t when the browser exits; otherwise it returns #f. -@end defun diff --git a/null.scm b/null.scm new file mode 100644 index 0000000..ac7c2f7 --- /dev/null +++ b/null.scm @@ -0,0 +1 @@ +;;; Stub for AGGREGATE feature. diff --git a/obj2str.scm b/obj2str.scm index a9b8313..7c77ef0 100644 --- a/obj2str.scm +++ b/obj2str.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,6 +18,7 @@ ;each case. (require 'string-port) +(require-if 'compiling 'generic-write) ;;@body Returns the textual representation of @1 as a string. (define (object->string obj) @@ -23,11 +23,11 @@ (if (object? obj) ((vector-ref obj 4)) (slib:error "Cannot get methods on non-object: " obj))) - +;@ (define (object? obj) (and (vector? obj) (eq? object:tag (vector-ref obj 0)))) - +;@ (define (make-method! obj generic-method method) (if (object? obj) (if (procedure? method) @@ -36,22 +36,22 @@ method) (slib:error "Method must be a procedure: " method)) (slib:error "Cannot make method on non-object: " obj))) - +;@ (define (get-method obj generic-method) (if (object? obj) ((vector-ref obj 1) generic-method) (slib:error "Cannot get method on non-object: " obj))) - +;@ (define (unmake-method! obj generic-method) (if (object? obj) ((vector-ref obj 3) generic-method) (slib:error "Cannot unmake method on non-object: " obj))) - +;@ (define (make-predicate! obj generic-predicate) (if (object? obj) ((vector-ref obj 2) generic-predicate (lambda (self) #t)) (slib:error "Cannot make predicate on non-object: " obj))) - +;@ (define (make-generic-method . exception-procedure) (define generic-method (lambda (obj . operands) @@ -70,7 +70,7 @@ (lambda (obj . params) (slib:error "Operation not supported: " obj)))) generic-method) - +;@ (define (make-generic-predicate) (define generic-predicate (lambda (obj) @@ -80,7 +80,7 @@ #f) #f))) generic-predicate) - +;@ (define (make-object . ancestors) (define method-list (apply append (map (lambda (obj) (get-all-methods obj)) ancestors))) @@ -95,5 +95,3 @@ (let ((method-def (assq generic-method method-list))) (if method-def (cdr method-def) #f))) (vector object:tag get-method make-method! unmake-method! all-methods)) - - diff --git a/paramlst.scm b/paramlst.scm index fcee1c9..65fcf01 100644 --- a/paramlst.scm +++ b/paramlst.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. ; @@ -42,7 +42,7 @@ ,(lambda (a) (if (null? a) #f (car a))))))) (lambda (arity) (assq arity table)))) - +;@ (define (fill-empty-parameters defaulters parameter-list) (map (lambda (defaulter parameter) (cond ((null? (cdr parameter)) @@ -50,7 +50,7 @@ (if defaulter (defaulter parameter-list) '()))) (else parameter))) defaulters parameter-list)) - +;@ (define (check-parameters checks parameter-list) (and (every (lambda (check parameter) (every @@ -69,7 +69,7 @@ ((null? (cdr param)) (slib:warn param 'missing) #f) (else (slib:warn param 'not (car arity-spec)) #f))) arity-specs parameter-list)) - +;@ (define (parameter-list->arglist positions arities parameter-list) (and (= (length arities) (length positions) (length parameter-list)) (let ((arity-specs (map arity->arity-spec arities)) @@ -81,14 +81,14 @@ ((caddr arity-spec) (cdr param)))) positions arity-specs parameter-list) (vector->list ans))))) - +;@ (define (make-parameter-list parameter-names) (map list parameter-names)) - +;@ (define (parameter-list-ref parameter-list i) (let ((ans (assoc i parameter-list))) (and ans (cdr ans)))) - +;@ (define (parameter-list-expand expanders parms) (do ((lens (map length parms) (map length parms)) (olens '() lens)) @@ -110,7 +110,7 @@ (cdr parm))))))) expanders parms))) - +;@ (define (adjoin-parameters! parameter-list . parameters) (let ((apairs (map (lambda (param) (cond ((pair? param) @@ -129,7 +129,7 @@ (set-cdr! apair (cons #t (cdr apair))))))) apairs parameters) parameter-list))) - +;@ (define (remove-parameter pname parameter-list) (define found? #f) (remove-if (lambda (elt) diff --git a/phil-spc.scm b/phil-spc.scm new file mode 100644 index 0000000..3372ce6 --- /dev/null +++ b/phil-spc.scm @@ -0,0 +1,94 @@ +; "phil-spc.scm": Peano-Hilbert space filling mapping +; 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 'logical) + +;;@code{(require 'hilbert-fill)} +;;@ftindex hilbert-fill +;; +;;@noindent +;;@cindex Peano +;;@cindex Hilbert +;;@cindex Space-Filling +;;The @dfn{Peano-Hilbert Space-Filling Curve} is a one-to-one mapping +;;between a unit line segment and an @var{n}-dimensional unit cube. +;; +;;@noindent +;;The integer procedures map the non-negative integers to an +;;arbitrarily large @var{n}-dimensional cube with its corner at the +;;origin and all coordinates are non-negative. +;; +;;@noindent +;;For any exact nonnegative integers @var{scalar} and @var{rank}, +;; +;;@example +;;(= @var{scalar} (hilbert-coordinates->integer +;; (integer->hilbert-coordinates @var{scalar} @var{rank}))) +;; @result{} #t +;;@end example + +;;@body +;;Returns a list of @2 integer coordinates corresponding to exact +;;non-negative integer @1. The lists returned by @0 for @1 arguments +;;0 and 1 will differ in the first element. +(define (integer->hilbert-coordinates scalar rank) + (define ndones (logical:ones rank)) + (define rank*nbits + (let ((rank^2 (* rank rank))) + (* (quotient (+ -1 rank^2 (integer-length scalar)) rank^2) + rank^2))) + (let ((nthbits (quotient (logical:ones rank*nbits) ndones))) + (define igry (logxor (integer->gray-code scalar) (ash nthbits -1))) + (do ((bdxn (- rank rank*nbits) (+ rank bdxn)) + (chnk (logand (ash igry (- rank rank*nbits)) ndones) + (logand (ash igry (+ rank bdxn)) ndones)) + (rotation 0 (modulo (+ (integer-length (logand (- chnk) chnk)) + 1 rotation) + rank)) + (flipbit 0 (ash 1 rotation)) + (bignum 0 (+ (logxor flipbit (logical:rotate chnk rotation rank)) + (ash bignum rank)))) + ((positive? bdxn) + (map gray-code->integer (bitwise:delaminate rank bignum)))))) + +;;@body +;;Returns an exact non-negative integer corresponding to @1, a list +;;of non-negative integer coordinates. +(define (hilbert-coordinates->integer coords) + (define rank (length coords)) + (define bignum (apply bitwise:laminate (map integer->gray-code coords))) + (let ((rank*nbits + (* (quotient (+ -1 rank (integer-length (apply max coords))) rank) + rank rank)) + (ndones (logical:ones rank))) + (define nthbits (quotient (logical:ones rank*nbits) ndones)) + (define (loop bdxn rotation flipbit scalar) + (if (positive? bdxn) + (gray-code->integer (logxor scalar (ash nthbits -1))) + (let ((chnk (logical:rotate + (logxor flipbit (logand ndones (ash bignum bdxn))) + (- rotation) + rank))) + (loop (+ rank bdxn) + (modulo (+ (integer-length (logand (- chnk) chnk)) + 1 rotation) + rank) + (ash 1 rotation) + (+ chnk (ash scalar rank)))))) + (loop (- rank rank*nbits) 0 0 0))) diff --git a/phil-spc.txi b/phil-spc.txi new file mode 100644 index 0000000..1193c6c --- /dev/null +++ b/phil-spc.txi @@ -0,0 +1,38 @@ +@code{(require 'hilbert-fill)} +@ftindex hilbert-fill + +@noindent +@cindex Peano +@cindex Hilbert +@cindex Space-Filling +The @dfn{Peano-Hilbert Space-Filling Curve} is a one-to-one mapping +@cindex Peano-Hilbert Space-Filling Curve +between a unit line segment and an @var{n}-dimensional unit cube. + +@noindent +The integer procedures map the non-negative integers to an +arbitrarily large @var{n}-dimensional cube with its corner at the +origin and all coordinates are non-negative. + +@noindent +For any exact nonnegative integers @var{scalar} and @var{rank}, + +@example +(= @var{scalar} (hilbert-coordinates->integer + (integer->hilbert-coordinates @var{scalar} @var{rank}))) + @result{} #t +@end example + + +@defun integer->hilbert-coordinates scalar rank + +Returns a list of @var{rank} integer coordinates corresponding to exact +non-negative integer @var{scalar}. The lists returned by @code{integer->hilbert-coordinates} for @var{scalar} arguments +0 and 1 will differ in the first element. +@end defun + +@defun hilbert-coordinates->integer coords + +Returns an exact non-negative integer corresponding to @var{coords}, a list +of non-negative integer coordinates. +@end defun diff --git a/plottest.scm b/plottest.scm index a601a49..0a1f1f6 100644 --- a/plottest.scm +++ b/plottest.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,6 +19,7 @@ (require 'charplot) (require 'random) +(require 'random-inexact) (define strophoid (let ((l '())) @@ -30,18 +31,16 @@ (set! l (cons (cons x y) l)) (set! l (cons (cons x (- y)) l)))))) l)) +(plot strophoid "x" "y") (newline) -(plot! strophoid "x" "y") (newline) +(histograph (do ((idx 99 (+ -1 idx)) + (lst '() (cons (* .02 (random:normal)) lst))) + ((negative? idx) lst)) + "normal") +(newline) -(define unif - (let* ((l 6) - (v (make-vector l))) - (do ((i (- l 1) (- i 1))) - ((negative? i)) - (vector-set! v i (cons i 0))) - (do ((i 24 (- i 1)) - (r (random l) (random l))) - ((zero? i) (vector->list v)) - (set-cdr! (vector-ref v r) (+ 1 (cdr (vector-ref v r))))))) - -(plot! unif "n" "occur") +(histograph (do ((idx 99 (+ -1 idx)) + (lst '() (cons (random 5) lst))) + ((negative? idx) lst)) + "random") +(newline) @@ -1,5 +1,5 @@ -;;; "pnm.scm" Read PNM image files. -; Copyright 2000 Aubrey Jaffer +;;; "pnm.scm" Read and write PNM image files. +; Copyright 2000, 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,24 +17,63 @@ ;promotional, or sales literature without prior written consent in ;each case. -(require 'scanf) -(require 'printf) (require 'array) +(require 'subarray) (require 'array-for-each) -(require 'byte) (require 'line-i/o) +(require 'logical) +(require 'byte) -(define (pnm:read+integer port) - (define uint #f) - (do ((chr (peek-char port) (peek-char port))) - ((not (and (char? chr) (or (char-whitespace? chr) (eqv? #\# chr))))) - (if (eqv? #\# chr) - (read-line port) - (read-char port))) - (if (eof-object? (peek-char port)) - (peek-char port) - (and (eqv? 1 (fscanf port " %u" uint)) uint))) +;;@code{(require 'pnm)} +;;@ftindex pnm +(define (pnm:read-pbm-char port) + (let loop ((chr (read-char port))) + (case chr + ((#\0) #f) + ((#\1) #t) + ((#\#) + (read-line port) + (loop (read-char port))) + (else + (if (char-whitespace? chr) + (loop (read-char port)) + (slib:error chr 'unexpected 'character)))))) + +;;@args path +;;The string @1 must name a @dfn{portable bitmap graphics} file. +;;@0 returns a list of 4 items: +;;@enumerate +;;@item +;;A symbol describing the type of the file named by @1. +;;@item +;;The image width in pixels. +;;@item +;;The image height in pixels. +;;@item +;;The maximum value of pixels assume in the file. +;;@end enumerate +;; +;;The current set of file-type symbols is: +;;@table @asis +;;@item pbm +;;@itemx pbm-raw +;;@cindex pbm +;;@cindex pbm-raw +;;Black-and-White image; pixel values are 0 or 1. +;;@item pgm +;;@itemx pgm-raw +;;@cindex pgm +;;@cindex pgm-raw +;;Gray (monochrome) image; pixel values are from 0 to @var{maxval} +;;specified in file header. +;;@item ppm +;;@itemx ppm-raw +;;@cindex ppm +;;@cindex ppm-raw +;;RGB (full color) image; red, green, and blue interleaved pixel values +;;are from 0 to @var{maxval} +;;@end table (define (pnm:type-dimensions port) (if (input-port? port) (let* ((c1 (read-char port)) @@ -45,83 +84,122 @@ (char-numeric? c2) (char-whitespace? (peek-char port))) (let* ((format (string->symbol (string #\p c2))) - (width (pnm:read+integer port)) - (height (pnm:read+integer port)) + (width (read port)) + (height (read port)) (ret (case format ((p1) (list 'pbm width height 1)) ((p4) (list 'pbm-raw width height 1)) - ((p2) (list 'pgm width height (pnm:read+integer port))) - ((p5) (list 'pgm-raw width height (pnm:read+integer port))) - ((p3) (list 'ppm width height (pnm:read+integer port))) - ((p6) (list 'ppm-raw width height (pnm:read+integer port))) + ((p2) (list 'pgm width height (read port))) + ((p5) (list 'pgm-raw width height (read port))) + ((p3) (list 'ppm width height (read port))) + ((p6) (list 'ppm-raw width height (read port))) (else #f)))) (and (char-whitespace? (read-char port)) ret))) (else #f))) - (call-with-input-file port pnm:type-dimensions))) + (call-with-open-ports (open-file port 'rb) pnm:type-dimensions))) -(define (pnm:read-binary! array port) - (array-map! array (lambda () (read-byte port)))) +(define (pnm:read-bit-vector! array port) + (define dims (array-dimensions array)) + (let* ((height (car (array-dimensions array))) + (width (cadr (array-dimensions array))) + (wid8 (logand -8 width))) + (do ((jdx 0 (+ 1 jdx))) + ((>= jdx height)) + (let ((row (subarray array jdx))) + (do ((idx 0 (+ 8 idx))) + ((>= idx wid8) + (if (< idx width) + (let ((byt (read-byte port))) + (do ((idx idx (+ 1 idx)) + (bdx 7 (+ -1 bdx))) + ((>= idx width)) + (array-set! row (logbit? bdx byt) idx))))) + (let ((byt (read-byte port))) + (array-set! row (logbit? 7 byt) (+ 0 idx)) + (array-set! row (logbit? 6 byt) (+ 1 idx)) + (array-set! row (logbit? 5 byt) (+ 2 idx)) + (array-set! row (logbit? 4 byt) (+ 3 idx)) + (array-set! row (logbit? 3 byt) (+ 4 idx)) + (array-set! row (logbit? 2 byt) (+ 5 idx)) + (array-set! row (logbit? 1 byt) (+ 6 idx)) + (array-set! row (logbit? 0 byt) (+ 7 idx))))))) + (if (eof-object? (peek-char port)) + array + (do ((chr (read-char port) (read-char port)) + (cnt 0 (+ 1 cnt))) + ((eof-object? chr) (slib:error cnt 'bytes 'remain 'in port))))) +;;@args path array +;; +;;Reads the @dfn{portable bitmap graphics} file named by @var{path} into +;;@var{array}. @var{array} must be the correct size and type for +;;@var{path}. @var{array} is returned. +;; +;;@args path +;; +;;@code{pnm:image-file->array} creates and returns an array with the +;;@dfn{portable bitmap graphics} file named by @var{path} read into it. (define (pnm:image-file->array path . array) (set! array (and (not (null? array)) (car array))) - (call-with-input-file path - (lambda (port) - (apply (lambda (type width height max-pixel) - (define (read-binary) - (pnm:read-binary! array port) - (if (eof-object? (peek-char port)) array - (slib:error type 'not 'at 'file 'end))) - (define (read-text) - (array-map! array (lambda () (pnm:read+integer port))) - (if (eof-object? (pnm:read+integer port)) array - (slib:error type 'not 'at 'file 'end))) - (define (read-pbm) - (array-map! array (lambda () (eqv? 1 (pnm:read+integer port)))) - (if (eof-object? (pnm:read+integer port)) array - (slib:error type 'not 'at 'file 'end))) - (case type - ((pbm) - (or array - (set! array (make-array #t height width))) - (read-pbm)) - ((pgm) - (or array - (set! array (make-array max-pixel height width))) - (read-text)) - ((ppm) - (or array - (set! array (make-array max-pixel height width 3))) - (read-text)) - ((pbm-raw) - (or array - (set! array (make-array #t height (quotient width 8)))) - (read-binary)) - ((pgm-raw) - (or array - (set! array (make-array max-pixel height width))) - (read-binary)) - ((ppm-raw) - (or array - (set! array (make-array max-pixel height width 3))) - (read-binary)))) - (pnm:type-dimensions port))))) - -(define (pnm:image-file->uniform-array path . array) - (fluid-let ((make-array make-uniform-array) - (pnm:read-binary! - (lambda (ra port) - (if (array? ra #t) - (error 'pnm:image-file->array - "pbm-raw support unimplemented") - (let ((bytes (apply make-uniform-array #\a - (array-dimensions ra)))) - (uniform-array-read! bytes port) - (array-map! ra char->integer bytes)))))) - (apply pnm:image-file->array path array))) + (call-with-open-ports + (open-file path 'rb) + (lambda (port) + (apply (lambda (type width height max-pixel) + (define (read-binary) + (array-map! array (lambda () (read-byte port))) + (if (eof-object? (peek-char port)) array + (slib:error type 'not 'at 'file 'end))) + (define (read-text) + (array-map! array (lambda () (read port))) + (if (not (eof-object? (read port))) + (slib:warn type 'not 'at 'file 'end)) + array) + (define (read-pbm) + (array-map! array (lambda () (pnm:read-pbm-char port))) + (if (not (eof-object? (read port))) + (slib:warn type 'not 'at 'file 'end)) + array) + (case type + ((pbm) + (or array + (set! array (create-array (At1) height width))) + (read-pbm)) + ((pgm) + (or array + (set! array (create-array + ((if (<= max-pixel 256) Au8 Au16)) + height width))) + (read-text)) + ((ppm) + (or array + (set! array (create-array + ((if (<= max-pixel 256) Au8 Au16)) + height width 3))) + (read-text)) + ((pbm-raw) + (or array + (set! array (create-array (At1) height width))) + (pnm:read-bit-vector! array port)) + ((pgm-raw) + (or array + (set! array (create-array (Au8) height width))) + (read-binary)) + ((ppm-raw) + (or array + (set! array (create-array (Au8) height width 3))) + (read-binary)))) + (pnm:type-dimensions port))))) ;; ARRAY is required to be zero-based. -(define (pnm:array-write type array maxval port) + +;;@args type array maxval path comment @dots{} +;; +;;Writes the contents of @2 to a @1 image file named @4. The file +;;will have pixel values between 0 and @3, which must be compatible +;;with @1. For @samp{pbm} files, @3 must be @samp{1}. +;;@var{comment}s are included in the file header. +(define (pnm:array-write type array maxval port . comments) (define (write-header type height width maxval) (let ((magic (case type @@ -131,9 +209,13 @@ ((pbm-raw) "P4") ((pgm-raw) "P5") ((ppm-raw) "P6") - (else (error 'pnm:array-write "bad type" type))))) - (fprintf port "%s\n%d %d" magic width height) - (if maxval (fprintf port "\n%d" maxval)))) + (else (slib:error 'pnm:array-write "bad type" type))))) + (display magic port) (newline port) + (for-each (lambda (str) + (display "#" port) (display str port) (newline port)) + comments) + (display width port) (display " " port) (display height port) + (cond (maxval (newline port) (display maxval port))))) (define (write-pixels type array maxval) (let* ((shp (array-dimensions array)) (height (car shp)) @@ -141,15 +223,14 @@ (case type ((pbm-raw) (newline port) - (if (array? array #t) - (uniform-array-write array port) - (error 'pnm:array-write "expected bit-array" array))) + (if (not (boolean? (array-ref array 0 0))) + (slib:error 'pnm:array-write "expected bit-array" array)) + (uniform-array-write array port)) ((pgm-raw ppm-raw) (newline port) -;;; (let ((bytes (apply make-uniform-array #\a shp))) -;;; (array-map! bytes integer->char array) -;;; (uniform-array-write bytes port)) - (uniform-array-write array port)) + ;;(uniform-array-write array port) + (array-for-each (lambda (byt) (write-byte byt port)) array) + ) ((pbm) (do ((i 0 (+ i 1))) ((>= i height)) @@ -187,16 +268,16 @@ (or (and (eqv? 2 rnk) (integer? (car shp)) (integer? (cadr shp))) - (error 'pnm:array-write "bad shape" type array)) + (slib:error 'pnm:array-write "bad shape" type array)) (or (eqv? 1 maxval) - (error 'pnm:array-write "maxval supplied not 1" type)) + (slib:error 'pnm:array-write "maxval supplied not 1" type)) (write-header type (car shp) (cadr shp) #f) (write-pixels type array 1)) ((pgm pgm-raw) (or (and (eqv? 2 rnk) (integer? (car shp)) (integer? (cadr shp))) - (error 'pnm:array-write "bad shape" type array)) + (slib:error 'pnm:array-write "bad shape" type array)) (write-header type (car shp) (cadr shp) maxval) (write-pixels type array maxval)) ((ppm ppm-raw) @@ -204,10 +285,10 @@ (integer? (car shp)) (integer? (cadr shp)) (eqv? 3 (caddr shp))) - (error 'pnm:array-write "bad shape" type array)) + (slib:error 'pnm:array-write "bad shape" type array)) (write-header type (car shp) (cadr shp) maxval) (write-pixels type array maxval)) - (else (error 'pnm:array-write type 'unrecognized 'type)))) - (call-with-output-file port - (lambda (port) - (pnm:array-write type array maxval port))))) + (else (slib:error 'pnm:array-write type 'unrecognized 'type)))) + (call-with-open-ports + (open-file port 'wb) + (lambda (port) (pnm:array-write type array maxval port))))) @@ -0,0 +1,66 @@ +@code{(require 'pnm)} +@ftindex pnm + + +@defun pnm:type-dimensions path + +The string @var{path} must name a @dfn{portable bitmap graphics} file. +@cindex portable bitmap graphics +@code{pnm:type-dimensions} returns a list of 4 items: +@enumerate +@item +A symbol describing the type of the file named by @var{path}. +@item +The image width in pixels. +@item +The image height in pixels. +@item +The maximum value of pixels assume in the file. +@end enumerate + +The current set of file-type symbols is: +@table @asis +@item pbm +@itemx pbm-raw +@cindex pbm +@cindex pbm-raw +Black-and-White image; pixel values are 0 or 1. +@item pgm +@itemx pgm-raw +@cindex pgm +@cindex pgm-raw +Gray (monochrome) image; pixel values are from 0 to @var{maxval} +specified in file header. +@item ppm +@itemx ppm-raw +@cindex ppm +@cindex ppm-raw +RGB (full color) image; red, green, and blue interleaved pixel values +are from 0 to @var{maxval} +@end table +@end defun + +@defun pnm:image-file->array path array + + +Reads the @dfn{portable bitmap graphics} file named by @var{path} into +@cindex portable bitmap graphics +@var{array}. @var{array} must be the correct size and type for +@var{path}. @var{array} is returned. + + +@defunx pnm:image-file->array path + +@code{pnm:image-file->array} creates and returns an array with the +@dfn{portable bitmap graphics} file named by @var{path} read into it. +@cindex portable bitmap graphics +@end defun + +@defun pnm:array-write type array maxval path comment @dots{} + + +Writes the contents of @var{array} to a @var{type} image file named @var{path}. The file +will have pixel values between 0 and @var{maxval}, which must be compatible +with @var{type}. For @samp{pbm} files, @var{maxval} must be @samp{1}. +@var{comment}s are included in the file header. +@end defun @@ -1,15 +1,13 @@ ;"pp.scm" Pretty-Print (require 'generic-write) - -(define (pp:pretty-print obj . opt) +;@ +(define (pretty-print obj . opt) (let ((port (if (pair? opt) (car opt) (current-output-port)))) (generic-write obj #f (output-port-width port) (lambda (s) (display s port) #t)))) - +;@ (define (pretty-print->string obj . width) (define result '()) (generic-write obj #f (if (null? width) (output-port-width) (car width)) (lambda (str) (set! result (cons str result)) #t)) (reverse-string-append result)) - -(define pretty-print pp:pretty-print) @@ -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,7 @@ (require 'pretty-print) +;@ (define (pprint-filter-file inport filter . optarg) ((lambda (fun) (if (input-port? inport) @@ -63,8 +64,8 @@ (lp c)))))))) (lp (peek-char port))) (set! *load-pathname* old-load-pathname))))))) - +;@ (define (pprint-file ifile . optarg) (pprint-filter-file ifile - (lambda (x) x) + identity (if (null? optarg) (current-output-port) (car optarg)))) @@ -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. ; @@ -51,9 +51,10 @@ (require 'string-port) (require 'delay) -(define *syn-defs* #f) (define *syn-rules* #f) ;Dynamically bound (define *prec:port* #f) ;Dynamically bound +;@ +(define *syn-defs* #f) ;; keeps track of input column so we can generate useful error displays. (define tok:column 0) @@ -64,14 +65,18 @@ (set! tok:column 0) (set! tok:column (+ 1 tok:column))) c)) +;@ (define (tok:bump-column pos . ports) ((lambda (thunk) (cond ((null? ports) (thunk)) - (else (fluid-let ((*prec:port* (car ports))) (thunk))))) + (else (fluid-let ((*prec:port* (car ports)) + (prec:token #f)) + (thunk))))) (lambda () (cond ((eqv? #\newline (tok:peek-char)) (tok:read-char))) ;to do newline (set! tok:column (+ tok:column pos))))) + (define (prec:warn . msgs) (do ((j (+ -1 tok:column) (+ -8 j))) ((> 8 j) @@ -94,7 +99,7 @@ #f (let ((pair (assv char alist))) (and pair (cdr pair))))) - +;@ (define (tok:char-group group chars chars-proc) (map (lambda (token) ;;; (let ((oldlexrec (tok:lookup *syn-defs* token))) @@ -159,10 +164,10 @@ (else obj))) ;;;Calls to set up tables. - +;@ (define (prec:define-grammar . synlsts) (set! *syn-defs* (append (apply append synlsts) *syn-defs*))) - +;@ (define (prec:make-led toks . args) (map (lambda (tok) (cons (cons 'led (prec:de-symbolfy tok)) @@ -186,50 +191,57 @@ ;;; utility functions called during parsing. The utility functions ;;; (prec:parse-*) could be incorportated into the defining commands, ;;; but tracing these functions is useful for debugging. - +;@ (define (prec:delim tk) (prec:make-led tk 0 #f)) - +;@ (define (prec:nofix tk sop . binds) (prec:make-nud tk prec:parse-nofix sop (apply append binds))) + (define (prec:parse-nofix self sop binds) (set! *syn-rules* (prec:process-binds binds *syn-rules*)) (prec:call-or-list (or sop (prec:symbolfy self)))) - +;@ (define (prec:prefix tk sop bp . binds) (prec:make-nud tk prec:parse-prefix sop bp (apply append binds))) + (define (prec:parse-prefix self sop bp binds) (fluid-let ((*syn-rules* (prec:process-binds binds *syn-rules*))) (prec:call-or-list (or sop (prec:symbolfy self)) (prec:parse1 bp)))) - +;@ (define (prec:infix tk sop lbp bp . binds) (prec:make-led tk lbp prec:parse-infix sop bp (apply append binds))) + (define (prec:parse-infix left self lbp sop bp binds) (fluid-let ((*syn-rules* (prec:process-binds binds *syn-rules*))) (prec:call-or-list (or sop (prec:symbolfy self)) left (prec:parse1 bp)))) - +;@ (define (prec:nary tk sop bp) (prec:make-led tk bp prec:parse-nary sop bp)) + (define (prec:parse-nary left self lbp sop bp) (prec:apply-or-cons (or sop (prec:symbolfy self)) (cons left (prec:parse-list self bp)))) - +;@ (define (prec:postfix tk sop lbp . binds) (prec:make-led tk lbp prec:parse-postfix sop (apply append binds))) + (define (prec:parse-postfix left self lbp sop binds) (set! *syn-rules* (prec:process-binds binds *syn-rules*)) (prec:call-or-list (or sop (prec:symbolfy self)) left)) - +;@ (define (prec:prestfix tk sop bp . binds) (prec:make-nud tk prec:parse-rest sop bp (apply append binds))) + (define (prec:parse-rest self sop bp binds) (fluid-let ((*syn-rules* (prec:process-binds binds *syn-rules*))) (prec:apply-or-cons (or sop (prec:symbolfy self)) (prec:parse-list #f bp)))) - +;@ (define (prec:commentfix tk stp match . binds) (append (prec:make-nud tk prec:parse-nudcomment stp match (apply append binds)) (prec:make-led tk 220 prec:parse-ledcomment stp match (apply append binds)))) + (define (prec:parse-nudcomment self stp match binds) (fluid-let ((*syn-rules* (prec:process-binds binds *syn-rules*))) (tok:read-through-comment stp match) @@ -254,12 +266,13 @@ (lambda (c) (display c sp) #f))))))) (stp (and len (substring str 0 (- len (string-length match))))))) (else (find-string-from-port? match *prec:port*)))) - +;@ (define (prec:matchfix tk sop sep match . binds) (define sep-lbp 0) (prec:make-nud tk prec:parse-matchfix sop sep-lbp sep match (apply append (prec:delim match) binds))) + (define (prec:parse-matchfix self sop sep-lbp sep match binds) (fluid-let ((*syn-rules* (prec:process-binds binds *syn-rules*))) (cond (sop (prec:apply-or-cons @@ -281,12 +294,13 @@ (do () ((prec:delim? (force prec:token))) (prec:parse1 0)))) ans))))) - +;@ (define (prec:inmatchfix tk sop sep match lbp . binds) (define sep-lbp 0) (prec:make-led tk lbp prec:parse-inmatchfix sop sep-lbp sep match (apply append (prec:delim match) binds))) + (define (prec:parse-inmatchfix left self lbp sop sep-lbp sep match binds) (fluid-let ((*syn-rules* (prec:process-binds binds *syn-rules*))) (prec:apply-or-cons @@ -378,11 +392,12 @@ (prec:parse1 bp)))) (prec:advance) ans)))) - +;@ (define (prec:parse grammar delim . port) (set! delim (prec:de-symbolfy delim)) (fluid-let ((*syn-rules* (append (prec:delim delim) grammar)) - (*prec:port* (if (null? port) (current-input-port) (car port)))) + (*prec:port* (if (null? port) (current-input-port) (car port))) + (prec:token prec:token)) (prec:advance) ; setup prec:token with first token (cond ((eof-object? (force prec:token)) (force prec:token)) ((equal? (force prec:token) delim) #f) @@ -396,7 +411,7 @@ (eof-object? (force prec:token)))) (prec:advance)))) ans))))) - +;@ (define tok:decimal-digits "0123456789") (define tok:upper-case "ABCDEFGHIJKLMNOPQRSTUVWXYZ") (define tok:lower-case "abcdefghijklmnopqrstuvwxyz") @@ -422,27 +437,10 @@ (prec:define-grammar (tok:char-group 0 (integer->char 26) #f)) ))) -;;; Save these convenient definitions. +;;;@ Save these convenient definitions. (define *syn-ignore-whitespace* *syn-defs*) (set! *syn-defs* '()) -(define (prec:trace) - (require 'trace) - (trace prec:parse prec:parse1 - prec:parse-delimited prec:parse-list - prec:call-or-list prec:apply-or-cons - ;;tokenize prec:advance-return-last prec:advance - prec:nudcall prec:ledcall - prec:parse-nudcomment prec:parse-ledcomment - prec:parse-delimited prec:parse-list - prec:parse-nary prec:parse-rest - prec:parse-matchfix prec:parse-inmatchfix - prec:parse-prefix prec:parse-infix prec:parse-postfix - ;;prec:delim? - ;;prec:ledf prec:nudf prec:lbp - ) - (set! *qp-width* 333)) - ;;(begin (trace-all "prec.scm") (set! *qp-width* 333)) ;;(pretty-print (grammar-read-tab (get-grammar 'standard))) ;;(prec:trace) @@ -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 'string-case) +(require-if 'compiling 'generic-write) ;; Determine the case of digits > 9. We assume this to be constant. (define stdio:hex-upper-case? (string=? "-F" (number->string -15 16))) @@ -539,8 +540,8 @@ ((end-of-format?) (incomplete)) (else (and (out #\%) (out fc) (out #\?) (loop args)))))))) (else (and (out fc) (loop args))))))))) - -(define (stdio:fprintf port format . args) +;@ +(define (fprintf port format . args) (let ((cnt 0)) (apply stdio:iprintf (lambda (x) @@ -549,11 +550,11 @@ (else (set! cnt (+ 1 cnt)) (display x port) #t))) format args) cnt)) - -(define (stdio:printf format . args) +;@ +(define (printf format . args) (apply stdio:fprintf (current-output-port) format args)) - -(define (stdio:sprintf str format . args) +;@ +(define (sprintf str format . args) (let* ((cnt 0) (s (cond ((string? str) str) ((number? str) (make-string str)) @@ -587,8 +588,6 @@ ((eqv? end cnt) s) (else (substring s 0 cnt))))) -(define printf stdio:printf) -(define fprintf stdio:fprintf) -(define sprintf stdio:sprintf) +(define stdio:fprintf fprintf) -;;(do ((i 0 (+ 1 i))) ((> i 50)) (printf "%s\n" (sprintf i "%#-13a:%#13a:%-13.8a:" "123456789" "123456789" "123456789"))) +;;(do ((i 0 (+ 1 i))) ((> i 50)) (printf "%s\\n" (sprintf i "%#-13a:%#13a:%-13.8a:" "123456789" "123456789" "123456789"))) diff --git a/priorque.scm b/priorque.scm index 0ad3007..9f1591f 100644 --- a/priorque.scm +++ b/priorque.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,21 +17,20 @@ ;promotional, or sales literature without prior written consent in ;each case. -;;; Algorithm from: -;;; Introduction to Algorithms by T. Cormen, C. Leiserson, R. Rivest. -;;; 1989 MIT Press. +;;@code{(require 'priority-queue)} +;;@ftindex priority-queue +;; +;;@noindent +;;This algorithm for priority queues is due to +;;@cite{Introduction to Algorithms} +;;by T. Cormen, C. Leiserson, R. Rivest. +;;1989 MIT Press. (require 'record) ;; Record type. (define heap:rtd (make-record-type "heap" '(array size heap<?))) -;; Constructor. -(define heap:make-heap - (let ((cstr (record-constructor heap:rtd))) - (lambda (pred<?) - (cstr (make-vector 4) 0 pred<?)))) - ;; Reference an element. (define heap:ref (let ((ra (record-accessor heap:rtd 'array))) @@ -55,10 +54,6 @@ (vector-set! ra i (vector-ref ra j)) (vector-set! ra j tmp))))) - -;; Get length. -(define heap:length (record-accessor heap:rtd 'size)) - (define heap:heap<? (record-accessor heap:rtd 'heap<?)) (define heap:set-size! @@ -92,7 +87,24 @@ (heap:exchange a i largest) (heap:heapify a largest))))) -(define (heap:insert! a key) +;;;; Externals + +;;@body +;;Returns a binary heap suitable which can be used for priority queue +;;operations. +(define make-heap + (let ((cstr (record-constructor heap:rtd))) + (lambda (pred<?) + (cstr (make-vector 4) 0 pred<?)))) + +;;@args heap +;;Returns the number of elements in @1. +(define heap-length (record-accessor heap:rtd 'size)) + +;;@args heap item +;;Inserts @2 into @1. @2 can be inserted multiple +;;times. The value returned is unspecified. +(define (heap-insert! a key) (define i (+ 1 (heap:length a))) (heap:set-size! a i) (do () @@ -102,7 +114,11 @@ (set! i (heap:parent i))) (heap:set! a i key)) -(define (heap:extract-max! a) +;;@args heap +;;Returns the item which is larger than all others according to the +;;@var{pred<?} argument to @code{make-heap}. If there are no items in +;;@1, an error is signaled. +(define (heap-extract-max! a) (if (< (heap:length a) 1) (slib:error "heap underflow" a)) (let ((max (heap:ref a 1))) @@ -111,26 +127,5 @@ (heap:heapify a 1) max)) -;; -;; Externals. -;; -(define make-heap heap:make-heap) -(define heap-insert! heap:insert!) -(define heap-extract-max! heap:extract-max!) -(define heap-length heap:length) - -(define (heap:test) - (require 'debug) - (let ((heap #f)) - (set! heap (make-heap char>?)) - (heap-insert! heap #\A) - (heap-insert! heap #\Z) - (heap-insert! heap #\G) - (heap-insert! heap #\B) - (heap-insert! heap #\G) - (heap-insert! heap #\Q) - (heap-insert! heap #\S) - (heap-insert! heap #\R) - (do ((i 7 (+ -1 i))) - ((negative? i)) - (write (heap-extract-max! heap)) (newline)))) +;; Internal protect. +(define heap:length heap-length) diff --git a/priorque.txi b/priorque.txi new file mode 100644 index 0000000..a1cd195 --- /dev/null +++ b/priorque.txi @@ -0,0 +1,33 @@ +@code{(require 'priority-queue)} +@ftindex priority-queue + +@noindent +This algorithm for priority queues is due to +@cite{Introduction to Algorithms} +by T. Cormen, C. Leiserson, R. Rivest. +1989 MIT Press. + + +@defun make-heap pred<? + +Returns a binary heap suitable which can be used for priority queue +operations. +@end defun + +@defun heap-length heap + +Returns the number of elements in @var{heap}. +@end defun + +@deffn {Procedure} heap-insert! heap item + +Inserts @var{item} into @var{heap}. @var{item} can be inserted multiple +times. The value returned is unspecified. +@end deffn + +@deffn {Procedure} heap-extract-max! heap + +Returns the item which is larger than all others according to the +@var{pred<?} argument to @code{make-heap}. If there are no items in +@var{heap}, an error is signaled. +@end deffn diff --git a/process.scm b/process.scm index bdd7969..d691aa6 100644 --- a/process.scm +++ b/process.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. ; @@ -20,13 +20,14 @@ (require 'full-continuation) (require 'queue) +;@ (define (add-process! thunk1) (cond ((procedure? thunk1) (defer-ints) (enqueue! process:queue thunk1) (allow-ints)) (else (slib:error "add-process!: wrong type argument " thunk1)))) - +;@ (define (process:schedule!) (defer-ints) (cond ((queue-empty? process:queue) (allow-ints) @@ -38,7 +39,7 @@ (allow-ints) (proc 'run)) (kill-process!)))))) - +;@ (define (kill-process!) (defer-ints) (cond ((queue-empty? process:queue) (allow-ints) diff --git a/promise.scm b/promise.scm index f38aebf..44ffea1 100644 --- a/promise.scm +++ b/promise.scm @@ -1,5 +1,5 @@ ;;;"promise.scm" promise for force and delay -;;; From Revised^4 Report on the Algorithmic Language Scheme +;;; From Revised^5 Report on the Algorithmic Language Scheme ;;; Editors: William Clinger and Jonathon Rees ; ; We intend this report to belong to the entire Scheme community, and so @@ -7,9 +7,9 @@ ; particular, we encourage implementors of Scheme to use this report as ; a starting point for manuals and other documentation, modifying it as ; necessary. - -(define promise:force (lambda (object) (object))) - +;@ +(define force (lambda (object) (object))) +;@ (define make-promise (lambda (proc) (let ((result-ready? #f) @@ -23,7 +23,10 @@ (begin (set! result-ready? #t) (set! result x) result)))))))) - ;;; change occurences of (DELAY <expression>) to ;;; (MAKE-PROMISE (LAMBDA () <expression>)) -;;; and (define force promise:force) +;@ +(define-syntax delay + (syntax-rules () + ((delay expression) + (make-promise (lambda () expression))))) diff --git a/pscheme.init b/pscheme.init index 841f191..b791df6 100644 --- a/pscheme.init +++ b/pscheme.init @@ -2,7 +2,7 @@ ;;; Author: Ben Goetter <goetter@mazama.net> ;;; last revised for 1.1.0 on 16 October 2000 ;;; Initial work for 0.2.3 by Robert Goldman (goldman@htc.honeywell.com) -;;; SLIB orig Author: Aubrey Jaffer (jaffer@ai.mit.edu) +;;; SLIB orig Author: Aubrey Jaffer (agj @ alum.mit.edu) ;;; ;;; This code is in the public domain. @@ -38,7 +38,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 @@ -52,11 +52,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!, @@ -67,7 +67,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 @@ -120,6 +120,37 @@ ;; pscheme: current-error-port, delete-file, force-output already defined +(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 @@ -231,7 +262,6 @@ ;;; (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) (if (not (file-exists? f)) (set! f (string-append f (scheme-file-suffix)))) @@ -240,11 +270,9 @@ ;;; (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) ;;; Pscheme and SLIB both define REQUIRE, so dispatch on argument type. diff --git a/psxtime.scm b/psxtime.scm index 9d94b86..753e81f 100644 --- a/psxtime.scm +++ b/psxtime.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,6 +19,8 @@ ;;; No, it doesn't do leap seconds. +(require-if 'compiling 'time-zone) + (define time:days/month '#(#(31 28 31 30 31 30 31 31 30 31 30 31) ; Normal years. #(31 29 31 30 31 30 31 31 30 31 30 31))) @@ -61,11 +63,11 @@ tm_gmtoff ; Seconds west of UTC. tm_zone ; Timezone abbreviation. ))))))))))) - -(define (time:gmtime t) +;@ +(define (gmtime t) (time:split t 0 0 "GMT")) - -(define (time:localtime caltime . tz) +;@ +(define (localtime caltime . tz) (require 'time-zone) (set! tz (if (null? tz) (tzset) (car tz))) (apply time:split caltime (tz:params caltime tz))) @@ -112,16 +114,16 @@ (loop guess (+ 1 j) (decoder guess)))))))))) - -(define (time:mktime univtime . tz) +;@ +(define (mktime univtime . tz) (require 'time-zone) (set! tz (if (null? tz) (tzset) (car tz))) (+ (gmktime univtime) (tz:std-offset tz))) - -(define (time:gmktime univtime) +;@ +(define (gmktime univtime) (time:invert time:gmtime univtime)) - -(define (time:asctime decoded) +;@ +(define (asctime decoded) (let ((days '#("Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat")) (months '#("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")) @@ -140,16 +142,16 @@ (number->2digits (vector-ref decoded 0) "0") " " (number->string (+ 1900 (vector-ref decoded 5))) (string #\newline)))) - -(define (time:ctime . args) +;@ +(define (ctime . args) (time:asctime (apply time:localtime args))) - -(define (time:gtime time) +;@ +(define (gtime time) (time:asctime (time:gmtime time))) ;;; GMT Local -- take optional 2nd TZ arg -(define gmtime time:gmtime) (define localtime time:localtime) -(define gmktime time:gmktime) (define mktime time:mktime) -(define gtime time:gtime) (define ctime time:ctime) +(define time:gmtime gmtime) (define time:localtime localtime) +;;(define time:gmktime gmktime) (define time:mktime mktime) +;;(define time:gtime gtime) (define time:ctime ctime) -(define asctime time:asctime) +(define time:asctime asctime) @@ -1,5 +1,5 @@ ;;;; "qp.scm" Print finite length representation for any Scheme object. -;;; 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. ; @@ -17,9 +17,10 @@ ;promotional, or sales literature without prior written consent in ;each case. +;@ (define *qp-width* (output-port-width (current-output-port))) - -(define qp:qp +;@ +(define qp (let ((+ +) (- -) (< <) (= =) (>= >=) (apply apply) (boolean? boolean?) (car car) (cdr cdr) (char? char?) (display display) (eq? eq?) @@ -127,23 +128,23 @@ (lambda objs (cond - ((or (not *qp-width*) (= 0 *qp-width*)) + ((not *qp-width*) (for-each (lambda (x) (write x) (display #\ )) objs) (newline)) + ((= 0 *qp-width*) + (for-each (lambda (x) + (if (procedure? x) (display "#[proc]") (write x)) + (display #\ )) objs)) (else (qp-pairs (cdr objs) (- *qp-width* (qp-obj (car objs) (l-elt-room *qp-width* objs)))))))))) - -(define qp:qpn - (let ((newline newline) (apply apply) (qp:qp qp:qp)) - (lambda objs (apply qp:qp objs) (newline)))) - -(define qp:qpr - (let ((- -) (apply apply) (length length) (list-ref list-ref) (qp:qpn qp:qpn)) - (lambda objs (apply qp:qpn objs) +;@ +(define qpn + (let ((newline newline) (apply apply) (qp qp)) + (lambda objs (apply qp objs) (newline)))) +;@ +(define qpr + (let ((- -) (apply apply) (length length) (list-ref list-ref) (qpn qpn)) + (lambda objs (apply qpn objs) (list-ref objs (- (length objs) 1))))) - -(define qp qp:qp) -(define qpn qp:qpn) -(define qpr qp:qpr) @@ -1,21 +1,33 @@ -; "queue.scm" Queues/Stacks for Scheme -; Written by Andrew Wilcox (awilcox@astro.psu.edu) on April 1, 1992. -; -; This code is in the public domain. +;; "queue.scm" Queues/Stacks for Scheme +;; Written by Andrew Wilcox (awilcox@astro.psu.edu) on April 1, 1992. +;; +;; This code is in the public domain. (require 'record) -; Elements in a queue are stored in a list. The last pair in the list -; is stored in the queue type so that datums can be added in constant -; time. +;;@code{(require 'queue)} +;;@ftindex queue +;; +;;A @dfn{queue} is a list where elements can be added to both the front +;;and rear, and removed from the front (i.e., they are what are often +;;called @dfn{dequeues}). A queue may also be used like a stack. + +;; Elements in a queue are stored in a list. The last pair in the list +;; is stored in the queue type so that datums can be added in constant +;; time. (define queue:record-type (make-record-type "queue" '(first-pair last-pair))) + +;;@args +;;Returns a new, empty queue. (define make-queue (let ((construct-queue (record-constructor queue:record-type))) (lambda () (construct-queue '() '())))) +;;@args obj +;;Returns @code{#t} if @var{obj} is a queue. (define queue? (record-predicate queue:record-type)) (define queue:first-pair (record-accessor queue:record-type @@ -27,21 +39,13 @@ (define queue:set-last-pair! (record-modifier queue:record-type 'last-pair)) +;;@body +;;Returns @code{#t} if the queue @var{q} is empty. (define (queue-empty? q) (null? (queue:first-pair q))) -(define (queue-front q) - (let ((first-pair (queue:first-pair q))) - (if (null? first-pair) - (slib:error "queue is empty" q)) - (car first-pair))) - -(define (queue-rear q) - (let ((last-pair (queue:last-pair q))) - (if (null? last-pair) - (slib:error "queue is empty" q)) - (car last-pair))) - +;;@body +;;Adds @var{datum} to the front of queue @var{q}. (define (queue-push! q datum) (let* ((old-first-pair (queue:first-pair q)) (new-first-pair (cons datum old-first-pair))) @@ -50,6 +54,8 @@ (queue:set-last-pair! q new-first-pair))) q) +;;@body +;;Adds @var{datum} to the rear of queue @var{q}. (define (enqueue! q datum) (let ((new-pair (cons datum '()))) (cond ((null? (queue:first-pair q)) @@ -59,6 +65,11 @@ (queue:set-last-pair! q new-pair)) q) +;;@body +;;@deffnx {Procedure} queue-pop! q +;;Both of these procedures remove and return the datum at the front of +;;the queue. @code{queue-pop!} is used to suggest that the queue is +;;being used like a stack. (define (dequeue! q) (let ((first-pair (queue:first-pair q))) (if (null? first-pair) @@ -68,5 +79,31 @@ (if (null? first-cdr) (queue:set-last-pair! q '())) (car first-pair)))) - (define queue-pop! dequeue!) + +;;@ All of the following functions raise an error if the queue @var{q} +;;is empty. + +;;@body +;;Removes and returns (the list) of all contents of queue @var{q}. +(define (dequeue-all! q) + (let ((lst (queue:first-pair q))) + (queue:set-first-pair! q '()) + (queue:set-last-pair! q '()) + lst)) + +;;@body +;;Returns the datum at the front of the queue @var{q}. +(define (queue-front q) + (let ((first-pair (queue:first-pair q))) + (if (null? first-pair) + (slib:error "queue is empty" q)) + (car first-pair))) + +;;@body +;;Returns the datum at the rear of the queue @var{q}. +(define (queue-rear q) + (let ((last-pair (queue:last-pair q))) + (if (null? last-pair) + (slib:error "queue is empty" q)) + (car last-pair))) diff --git a/queue.txi b/queue.txi new file mode 100644 index 0000000..4590f34 --- /dev/null +++ b/queue.txi @@ -0,0 +1,60 @@ +@code{(require 'queue)} +@ftindex queue + +A @dfn{queue} is a list where elements can be added to both the front +@cindex queue +and rear, and removed from the front (i.e., they are what are often +called @dfn{dequeues}). A queue may also be used like a stack. +@cindex dequeues + + +@defun make-queue + +Returns a new, empty queue. +@end defun + +@defun queue? obj + +Returns @code{#t} if @var{obj} is a queue. +@end defun + +@defun queue-empty? q + +Returns @code{#t} if the queue @var{q} is empty. +@end defun + +@deffn {Procedure} queue-push! q datum + +Adds @var{datum} to the front of queue @var{q}. +@end deffn + +@deffn {Procedure} enqueue! q datum + +Adds @var{datum} to the rear of queue @var{q}. +@end deffn + +@deffn {Procedure} dequeue! q + +@deffnx {Procedure} queue-pop! q +Both of these procedures remove and return the datum at the front of +the queue. @code{queue-pop!} is used to suggest that the queue is +being used like a stack. +@end deffn +All of the following functions raise an error if the queue @var{q} +is empty. + + +@deffn {Procedure} dequeue-all! q + +Removes and returns (the list) of all contents of queue @var{q}. +@end deffn + +@defun queue-front q + +Returns the datum at the front of the queue @var{q}. +@end defun + +@defun queue-rear q + +Returns the datum at the rear of the queue @var{q}. +@end defun @@ -20,7 +20,7 @@ ;;; software shall duly acknowledge such use, in accordance with the ;;; usual standards of acknowledging credit in academic research. ;;; -;;; 4. MIT has made no warrantee or representation that the operation +;;; 4. MIT has made no warranty or representation that the operation ;;; of this software will be error-free, and MIT is under no ;;; obligation to provide any services, by way of maintenance, update, ;;; or otherwise. diff --git a/randinex.scm b/randinex.scm index 19b9d81..717b306 100644 --- a/randinex.scm +++ b/randinex.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,19 +22,23 @@ ;;; Sphere and normal functions corrections from: Harald Hanche-Olsen +(require 'random) +(require 'inexact) + +;;@code{(require 'random-inexact)} +;;@ftindex random-inexact + ;;; Generate an inexact real between 0 and 1. -(define random:uniform1 - ; how many chunks fill an inexact? +(define random:uniform1 ; how many chunks fill an inexact? (do ((random:chunks/float 0 (+ 1 random:chunks/float)) (smidgen 1.0 (/ smidgen 256.0))) - ((or (= 1.0 (+ 1 smidgen)) (= 4 random:chunks/float)) + ((or (= 1 (+ 1 smidgen)) (= 4 random:chunks/float)) (lambda (state) (do ((cnt random:chunks/float (+ -1 cnt)) (uni (/ (random:chunk state) 256.0) (/ (+ uni (random:chunk state)) 256.0))) ((= 1 cnt) uni)))))) - ;;@args ;;@args state ;;Returns an uniformly distributed inexact real random number in the @@ -70,24 +74,24 @@ ;;; 1-exp(-r^2/2). This latter means that u=exp(-r^2/2) is uniformly ;;; distributed on [0,1], so r=sqrt(-2 log u) can be used to generate r. -(define *2pi (* 8 (atan 1))) - ;;@args vect ;;@args vect state ;;Fills @1 with inexact real random numbers which are independent ;;and standard normally distributed (i.e., with mean 0 and variance 1). -(define (random:normal-vector! vect . args) - (let ((state (if (null? args) *random-state* (car args))) - (sum2 0)) - (let ((do! (lambda (k x) - (vector-set! vect k x) - (set! sum2 (+ sum2 (* x x)))))) - (do ((n (- (vector-length vect) 1) (- n 2))) - ((negative? n) sum2) - (let ((t (* *2pi (random:uniform1 state))) - (r (sqrt (* -2 (log (random:uniform1 state)))))) - (do! n (* r (cos t))) - (if (positive? n) (do! (- n 1) (* r (sin t))))))))) +(define random:normal-vector! + (let ((*2pi (* 8 (atan 1)))) + (lambda (vect . args) + (let ((state (if (null? args) *random-state* (car args))) + (sum2 0)) + (let ((do! (lambda (k x) + (vector-set! vect k x) + (set! sum2 (+ sum2 (* x x)))))) + (do ((n (- (vector-length vect) 1) (- n 2))) + ((negative? n) sum2) + (let ((t (* *2pi (random:uniform1 state))) + (r (sqrt (* -2 (log (random:uniform1 state)))))) + (do! n (* r (cos t))) + (if (positive? n) (do! (- n 1) (* r (sin t))))))))))) ;;; For the uniform distibution on the hollow sphere, pick a normal diff --git a/randinex.txi b/randinex.txi index 80531eb..b73f983 100644 --- a/randinex.txi +++ b/randinex.txi @@ -1,3 +1,6 @@ +@code{(require 'random-inexact)} +@ftindex random-inexact + @defun random:uniform @@ -26,31 +29,31 @@ standard deviation @var{d} use @w{@code{(+ @var{m} (* @var{d} (random:normal)))}}. @end defun -@defun random:normal-vector! vect +@deffn {Procedure} random:normal-vector! vect -@defunx random:normal-vector! vect state +@deffnx {Procedure} random:normal-vector! vect state Fills @var{vect} with inexact real random numbers which are independent and standard normally distributed (i.e., with mean 0 and variance 1). -@end defun +@end deffn -@defun random:hollow-sphere! vect +@deffn {Procedure} random:hollow-sphere! vect -@defunx random:hollow-sphere! vect state +@deffnx {Procedure} random:hollow-sphere! vect state Fills @var{vect} with inexact real random numbers the sum of whose squares is equal to 1.0. Thinking of @var{vect} as coordinates in space of dimension n = @code{(vector-length @var{vect})}, the coordinates are uniformly distributed over the surface of the unit n-shere. -@end defun +@end deffn -@defun random:solid-sphere! vect +@deffn {Procedure} random:solid-sphere! vect -@defunx random:solid-sphere! vect state +@deffnx {Procedure} random:solid-sphere! vect state Fills @var{vect} with inexact real random numbers the sum of whose squares is less than 1.0. Thinking of @var{vect} as coordinates in space of dimension @var{n} = @code{(vector-length @var{vect})}, the coordinates are uniformly distributed within the unit @var{n}-shere. The sum of the squares of the numbers is returned. -@end defun +@end deffn @@ -1,5 +1,5 @@ ;;;; "random.scm" Pseudo-Random number generator for scheme. -;;; Copyright (C) 1991, 1993, 1998, 1999 Aubrey Jaffer +;;; Copyright (C) 1991, 1993, 1998, 1999, 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. ; @@ -19,8 +19,14 @@ (require 'byte) (require 'logical) +(require-if 'compiling 'object->string) ; for make-random-state + +;;@code{(require 'random)} +;;@ftindex random ;;; random:chunk returns an integer in the range of 0 to 255. +;;; export for random-inexact: +;;@ (define (random:chunk sta) (cond ((positive? (byte-ref sta 258)) (byte-set! sta 258 0) @@ -39,34 +45,30 @@ ans)))) -;;@args n ;;@args n state -;;Accepts a positive integer or real @1 and returns a number of the -;;same type between zero (inclusive) and @1 (exclusive). The values -;;returned by @0 are uniformly distributed from 0 to @1. +;;@args n +;; +;;@1 must be an exact positive integer. @0 returns an exact integer +;;between zero (inclusive) and @1 (exclusive). The values returned by +;;@0 are uniformly distributed from 0 to @1. ;; -;;The optional argument @var{state} must be of the type returned by -;;@code{(seed->random-state)} or @code{(make-random-state)}. It defaults -;;to the value of the variable @code{*random-state*}. This object is used -;;to maintain the state of the pseudo-random-number generator and is -;;altered as a side effect of calls to @code{random}. +;;The optional argument @2 must be of the type returned by +;;@code{(seed->random-state)} or @code{(make-random-state)}. It +;;defaults to the value of the variable @code{*random-state*}. This +;;object is used to maintain the state of the pseudo-random-number +;;generator and is altered as a side effect of calls to @code{random}. (define (random modu . args) - (let ((state (if (null? args) *random-state* (car args)))) - (if (exact? modu) - (letrec ((bitlen (integer-length (+ -1 modu))) - (rnd (lambda () - (do ((bln bitlen (+ -8 bln)) - (rbs 0 (+ (ash rbs 8) (random:chunk state)))) - ((<= bln 7) - (set! rbs (+ (ash rbs bln) - (bit-field (random:chunk state) 0 bln))) - (and (< rbs modu) rbs)))))) - (do ((ans (rnd) (rnd))) (ans ans))) - (* (random:uniform1 state) modu)))) - -(define random:random random) -;;;random:uniform is in randinex.scm. It is needed only if inexact is -;;;supported. + (define state (if (null? args) *random-state* (car args))) + (define bitlen (integer-length (+ -1 modu))) + (define (rnd) + (do ((bln bitlen (+ -8 bln)) + (rbs 0 (+ (ash rbs 8) (random:chunk state)))) + ((<= bln 7) + (if (positive? bln) + (set! rbs (logxor (ash rbs bln) + (random:chunk state)))) + (if (< rbs modu) rbs (rnd))))) + (rnd)) ;;@defvar *random-state* @@ -84,7 +86,7 @@ ;;@args ;;Returns a new copy of @code{*random-state*}. (define (copy-random-state . sta) - (string-copy (if (null? sta) *random-state* (car sta)))) + (bytes-copy (if (null? sta) *random-state* (car sta)))) ;;@body @@ -105,11 +107,13 @@ ; merge seed into state (do ((i 0 (+ 1 i)) (j 0 (modulo (+ 1 j) seed-len)) - (seed-len (bytes-length seed)) + (seed-len (string-length seed)) (k 0)) ((>= i 256)) (let ((swp (byte-ref sta i))) - (set! k (logand #xff (+ k (byte-ref seed j) swp))) + (set! k (logand #xff (+ k + (modulo (char->integer (string-ref seed j)) 255) + swp))) (byte-set! sta i (byte-ref sta k)) (byte-set! sta k swp))) sta) @@ -131,9 +135,6 @@ (require 'object->string) (set! seed (object->limited-string seed 50))))) (seed->random-state seed))) - +;@ (define *random-state* (make-random-state "http://swissnet.ai.mit.edu/~jaffer/SLIB.html")) - -(provide 'random) ;to prevent loops -(if (provided? 'inexact) (require 'random-inexact)) @@ -1,17 +1,23 @@ +@code{(require 'random)} +@ftindex random -@defun random n -@defunx random n state -Accepts a positive integer or real @var{n} and returns a number of the -same type between zero (inclusive) and @var{n} (exclusive). The values -returned by @code{random} are uniformly distributed from 0 to @var{n}. + +@defun random n state + + +@defunx random n + +@var{n} must be an exact positive integer. @code{random} returns an exact integer +between zero (inclusive) and @var{n} (exclusive). The values returned by +@code{random} are uniformly distributed from 0 to @var{n}. The optional argument @var{state} must be of the type returned by -@code{(seed->random-state)} or @code{(make-random-state)}. It defaults -to the value of the variable @code{*random-state*}. This object is used -to maintain the state of the pseudo-random-number generator and is -altered as a side effect of calls to @code{random}. +@code{(seed->random-state)} or @code{(make-random-state)}. It +defaults to the value of the variable @code{*random-state*}. This +object is used to maintain the state of the pseudo-random-number +generator and is altered as a side effect of calls to @code{random}. @end defun @defvar *random-state* Holds a data structure that encodes the internal state of the @@ -53,3 +59,5 @@ Scheme object; the first 50 characters of its printed representation will be used as the seed. Otherwise the value of @code{*random-state*} is used as the seed. @end defun + + @@ -1,5 +1,46 @@ ;;;; "ratize.scm" Find simplest number ratios +;;@code{(require 'rationalize)} +;;@ftindex rationalize + +;;The procedure @dfn{rationalize} is interesting because most programming +;;languages do not provide anything analogous to it. Thanks to Alan +;;Bawden for contributing this algorithm. + +;;@body +;;Computes the correct result for exact arguments (provided the +;;implementation supports exact rational numbers of unlimited precision); +;;and produces a reasonable answer for inexact arguments when inexact +;;arithmetic is implemented using floating-point. +;; +(define (rationalize x e) (apply / (find-ratio x e))) + +;;@code{Rationalize} has limited use in implementations lacking exact +;;(non-integer) rational numbers. The following procedures return a list +;;of the numerator and denominator. + +;;@body +;;@0 returns the list of the @emph{simplest} +;;numerator and denominator whose quotient differs from @1 by no more +;;than @2. +;; +;;@format +;;@t{(find-ratio 3/97 .0001) @result{} (3 97) +;;(find-ratio 3/97 .001) @result{} (1 32) +;;} +;;@end format +(define (find-ratio x e) (find-ratio-between (- x e) (+ x e))) + + +;;@body +;;@0 returns the list of the @emph{simplest} +;;numerator and denominator between @1 and @2. +;; +;;@format +;;@t{(find-ratio-between 2/7 3/5) @result{} (1 2) +;;(find-ratio-between -3/5 -2/7) @result{} (-1 2) +;;} +;;@end format (define (find-ratio-between x y) (define (sr x y) (let ((fx (inexact->exact (floor x))) (fy (inexact->exact (floor y)))) @@ -13,5 +54,3 @@ ((negative? y) (let ((rat (sr (- y) (- x)))) (list (- (car rat)) (cadr rat)))) (else '(0 1)))) -(define (find-ratio x e) (find-ratio-between (- x e) (+ x e))) -(define (rationalize x e) (apply / (find-ratio x e))) diff --git a/ratize.txi b/ratize.txi new file mode 100644 index 0000000..63b5917 --- /dev/null +++ b/ratize.txi @@ -0,0 +1,41 @@ +@code{(require 'rationalize)} +@ftindex rationalize + + +@defun rationalize x e + +Computes the correct result for exact arguments (provided the +implementation supports exact rational numbers of unlimited precision); +and produces a reasonable answer for inexact arguments when inexact +arithmetic is implemented using floating-point. + +@end defun +@code{Rationalize} has limited use in implementations lacking exact +(non-integer) rational numbers. The following procedures return a list +of the numerator and denominator. + + +@defun find-ratio x e + +@code{find-ratio} returns the list of the @emph{simplest} +numerator and denominator whose quotient differs from @var{x} by no more +than @var{e}. + +@format +@t{(find-ratio 3/97 .0001) @result{} (3 97) +(find-ratio 3/97 .001) @result{} (1 32) +} +@end format +@end defun + +@defun find-ratio-between x y + +@code{find-ratio-between} returns the list of the @emph{simplest} +numerator and denominator between @var{x} and @var{y}. + +@format +@t{(find-ratio-between 2/7 3/5) @result{} (1 2) +(find-ratio-between -3/5 -2/7) @result{} (-1 2) +} +@end format +@end defun @@ -1,5 +1,5 @@ ;;; "rdms.scm" rewrite 6 - the saga continues -; Copyright 1994, 1995, 1997, 2000 Aubrey Jaffer +; Copyright 1994, 1995, 1997, 2000, 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. ; @@ -22,10 +22,10 @@ (define rdms:columns-name '*columns*) (define catalog:init-cols - '((1 #t table-name #f atom) - (2 #f column-limit #f uint) - (3 #f coltab-name #f atom) - (4 #f bastab-id #f base-id) + '((1 #t table-name #f symbol) + (2 #f column-limit #f ordinal) + (3 #f coltab-name #f symbol) + (4 #f bastab-id #f ordinal) (5 #f user-integrity-rule #f expression) (6 #f view-procedure #f expression))) @@ -33,10 +33,10 @@ (define catalog:coltab-name-pos 3) (define catalog:bastab-id-pos 4) (define catalog:integrity-rule-pos 5) -(define catalog:view-proc-pos 6) +;;(define catalog:view-proc-pos 6) (define columns:init-cols - '((1 #t column-number #f uint) + '((1 #t column-number #f ordinal) (2 #f primary-key? #f boolean) (3 #f column-name #f symbol) (4 #f column-integrity-rule #f expression) @@ -48,7 +48,7 @@ (define columns:domain-name-pos 5) (define domains:init-cols - '((1 #t domain-name #f atom) + '((1 #t domain-name #f symbol) (2 #f foreign-table #f atom) (3 #f domain-integrity-rule #f expression) (4 #f type-id #f type) @@ -57,50 +57,44 @@ (define domains:foreign-pos 2) (define domains:integrity-rule-pos 3) (define domains:type-id-pos 4) -(define domains:type-param-pos 5) +;;(define domains:type-param-pos 5) (define domains:init-data - `((atom #f - (lambda (x) (or (not x) (symbol? x) (number? x))) - atom - #f) - (type #f - #f ;type checked when openning - symbol - #f) - (base-id #f - (lambda (x) (or (symbol? x) (number? x))) - base-id - #f) - (uint #f - (lambda (x) - (and (number? x) - (integer? x) - (not (negative? x)))) - number - #f) - (number #f number? number #f) - (expression #f #f expression #f) + `((type #f symbol? symbol #f) + (ordinal #f (lambda (x) (and (integer? x) (positive? x))) number #f) (boolean #f boolean? boolean #f) + (expression #f #f expression #f) (symbol #f symbol? symbol #f) (string #f string? string #f) - (domain ,rdms:domains-name #f atom #f))) - -(define rdms:warn slib:warn) -(define rdms:error slib:error) + (atom #f (lambda (x) (or (not x) (symbol? x))) atom #f) ; (number? x) + (domain ,rdms:domains-name #f atom #f) + ;; Legacy types + (number #f number? number #f) + (base-id #f number? ordinal #f) + (uint #f (lambda (x) (and (integer? x) (not (negative? x)))) number #f) + )) +;@ (define (make-relational-system base) - (define basic - (lambda (name) - (let ((meth (base name))) - (cond ((not meth) (rdms:error 'make-relational-system - "essential method missing for:" name))) - meth))) + + (define (basic name) + (let ((meth (base name))) + (cond ((not meth) (slib:error 'make-relational-system + "essential method missing for:" name))) + meth)) (define (desc-row-type row) (let ((domain (assq (car (cddddr row)) domains:init-data))) (and domain (cadddr domain)))) + (define (itypes rows) + (map (lambda (row) + (let ((domrow (assq (car (cddddr row)) domains:init-data))) + (cond (domrow (cadddr domrow)) + (else (slib:error 'itypes "type not found for:" + (car (cddddr row))))))) + rows)) + (let ((make-base (base 'make-base)) (open-base (basic 'open-base)) (write-base (base 'write-base)) @@ -112,20 +106,14 @@ (base:open-table (basic 'open-table)) (base:kill-table (base 'kill-table)) (present? (basic 'present?)) - (base:ordered-for-each-key (basic 'ordered-for-each-key)) + (base:ordered-for-each-key (base 'ordered-for-each-key)) (base:for-each-primary-key (basic 'for-each-key)) (base:map-primary-key (basic 'map-key)) + (base:make-nexter (base 'make-nexter)) + (base:make-prever (base 'make-prever)) (base:catalog-id (basic 'catalog-id)) (cat:keyify-1 ((basic 'make-keyifier-1) - (desc-row-type (assv 1 catalog:init-cols)))) - (itypes - (lambda (rows) - (map (lambda (row) - (let ((domrow (assq (car (cddddr row)) domains:init-data))) - (cond (domrow (cadddr domrow)) - (else (rdms:error 'itypes "type not found for:" - (car (cddddr row))))))) - rows)))) + (desc-row-type (assv 1 catalog:init-cols))))) (define (init-tab lldb id descriptor rows) (let ((han (base:open-table lldb id 1 (itypes descriptor))) @@ -155,16 +143,15 @@ (des:getter bastab (des:keyify-1 key))))) (define (create-database filename) - ;;(cond ((and filename (file-exists? filename)) - ;;(rdms:warn 'create-database "file exists:" filename))) + ;;(cond ((and filename (file-exists? filename)) (slib:warn 'create-database "file exists:" filename))) (let* ((lldb (make-base filename 1 (itypes catalog:init-cols))) (cattab (and lldb (base:open-table lldb base:catalog-id 1 (itypes catalog:init-cols))))) (cond - ((not lldb) (rdms:error 'make-base "failed.") #f) - ((not cattab) (rdms:error 'make-base "catalog missing.") - (close-base lldb) - #f) + ((not lldb) (slib:error 'make-base "failed.") #f) + ((not cattab) (slib:error 'make-base "catalog missing.") + (close-base lldb) + #f) (else (let ((desdes-id (base:make-table lldb 1 (itypes columns:init-cols))) (domdes-id (base:make-table lldb 1 (itypes columns:init-cols))) @@ -173,7 +160,7 @@ ) (cond ((not (and catdes-id domdes-id domtab-id desdes-id)) - (rdms:error 'create-database "make-table failed.") + (slib:error 'create-database "make-table failed.") (close-base lldb) #f) (else @@ -216,20 +203,35 @@ (define (init-database rdms:filename mutable lldb base:catalog base:domains rdms:catalog) - (define (write-database filename) - (let ((ans (write-base lldb filename))) - (and ans (set! rdms:filename filename)) - ans)) + (define write-database + (and mutable + (lambda (filename) + (let ((ans (write-base lldb filename))) + (and ans (set! rdms:filename filename)) + ans)))) - (define (sync-database) - (sync-base lldb)) + (define sync-database + (and mutable + (lambda () + (sync-base lldb)))) + + (define (solidify-database) + (cond ((sync-base lldb) + (set! mutable #f) + (set! sync-database #f) + (set! write-database #f) + (set! delete-table #f) + (set! create-table #f) + #t) + (else #f))) (define (close-database) - (close-base lldb) - (set! rdms:filename #f) - (set! base:catalog #f) - (set! base:domains #f) - (set! rdms:catalog #f)) + (define ans (close-base lldb)) + (cond (ans (set! rdms:filename #f) + (set! base:catalog #f) + (set! base:domains #f) + (set! rdms:catalog #f))) + ans) (define row-ref (lambda (row pos) (list-ref row (+ -2 pos)))) (define row-eval (lambda (row pos) @@ -239,9 +241,9 @@ (define (open-table table-name writable) (define cat:row (cat:get-row base:catalog table-name)) (cond ((not cat:row) - (rdms:error "can't open-table:" table-name)) + (slib:error "can't open-table:" table-name)) ((and writable (not mutable)) - (rdms:error "can't open-table for writing:" table-name))) + (slib:error "can't open-table for writing:" table-name))) (let ((column-limit (row-ref cat:row catalog:column-limit-pos)) (desc-table (base:open-table @@ -265,8 +267,8 @@ (list->key #f) (key->list #f)) - (if (not desc-table) - (rdms:error "descriptor table doesn't exist for:" table-name)) + (or desc-table + (slib:error "descriptor table doesn't exist for:" table-name)) (do ((ci column-limit (+ -1 ci))) ((zero? ci)) (let* ((des:row (des:get-row desc-table ci)) @@ -301,24 +303,24 @@ (p? (and tab (tab 'get 1)))) (cond ((not tab) - (rdms:error "foreign key table missing for:" + (slib:error "foreign key table missing for:" foreign-name)) ((not (= (tab 'primary-limit) 1)) - (rdms:error "foreign key table wrong type:" + (slib:error "foreign key table wrong type:" foreign-name)) (else p?))))) column-foreign-check-list)))) (else - (rdms:error "missing domain for column:" ci column-name))) + (slib:error "missing domain for column:" ci column-name))) (cond ((row-ref des:row columns:primary?-pos) (set! primary-limit (max primary-limit ci)) (cond ((base:supported-key-type? (car column-type-list))) - (else (rdms:error "key type not supported by base tables:" + (else (slib:error "key type not supported by base tables:" (car column-type-list))))) ((base:supported-type? (car column-type-list))) - (else (rdms:error "type not supported by base tables:" + (else (slib:error "type not supported by base tables:" (car column-type-list)))))) (set! base-table (base:open-table lldb (row-ref cat:row catalog:bastab-id-pos) @@ -332,7 +334,7 @@ (lambda (name proc) (set! export-alist (cons (cons name proc) export-alist)))) - (ckey:retrieve ;ckey gets whole row (assumes exists) + (ckey:retrieve ;ckey gets whole row (assumes exists) (if (= primary-limit column-limit) key->list (lambda (ckey) (append (key->list ckey) (base:get base-table ckey))))) @@ -346,7 +348,7 @@ (lambda (mkeys) (define mlim (length mkeys)) (cond ((> mlim primary-limit) - (rdms:error "too many keys:" mkeys)) + (slib:error "too many keys:" mkeys)) ((= mlim primary-limit) mkeys) (else (append mkeys @@ -371,10 +373,20 @@ (let ((r (if (= primary-limit column-limit) key->list ckey:retrieve))) (lambda (proc . mkeys) - (base:ordered-for-each-key + (base:for-each-primary-key base-table (lambda (ckey) (proc (r ckey))) primary-limit column-type-list (norm-mkeys mkeys))))) + (and base:ordered-for-each-key + (export-method + 'for-each-row-in-order + (let ((r (if (= primary-limit column-limit) key->list + ckey:retrieve))) + (lambda (proc . mkeys) + (base:ordered-for-each-key + base-table (lambda (ckey) (proc (r ckey))) + primary-limit column-type-list + (norm-mkeys mkeys)))))) (cond ((and mutable writable) (letrec @@ -394,36 +406,35 @@ ((3) (lambda (row) (list->key (list (car row) (cadr row) (caddr row))))) - ((4) (lambda (row) - (list->key - (list (car row) (cadr row) - (caddr row) (cadddr row))))) - (else (rdms:error 'combine-primary-keys - "bad number of primary keys" - primary-limit)))))) + (else (lambda (row) + (do ((rw row (cdr rw)) + (nrw '() (cons (car rw) nrw)) + (pl (+ -1 primary-limit) (+ -1 pl))) + ((negative? pl) + (list->key (reverse nrw)))))))))) (uir (row-eval cat:row catalog:integrity-rule-pos)) (check-rules (lambda (row) (if (= column-limit (length row)) #t - (rdms:error "bad row length:" row)) + (slib:error "bad row length:" row)) (for-each (lambda (cir dir value column-name column-domain foreign) (cond ((and dir (not (dir value))) - (rdms:error "violated domain integrity rule:" + (slib:error "violated domain integrity rule:" table-name column-name column-domain value)) ((and cir (not (cir value))) - (rdms:error "violated column integrity rule:" + (slib:error "violated column integrity rule:" table-name column-name value)) ((and foreign (not (foreign value))) - (rdms:error "foreign key missing:" + (slib:error "foreign key missing:" table-name column-name value)))) cirs dirs row column-name-alist column-domain-list column-foreign-check-list) (cond ((and uir (not (uir row))) - (rdms:error "violated user integrity rule:" + (slib:error "violated user integrity rule:" row))))) (putter ((basic 'make-putter) primary-limit column-type-list)) @@ -432,7 +443,7 @@ (check-rules row) (let ((ckey (combine-primary-keys row))) (if (present? base-table ckey) - (rdms:error 'row:insert "row present:" row)) + (slib:error 'row:insert "row present:" row)) (putter base-table ckey (list-tail row primary-limit))))) (row:update @@ -485,21 +496,31 @@ ;;(print 'translate-column column column-name-alist) (let ((colp (assq column column-name-alist))) (cond (colp (cdr colp)) - ((and (number? column) - (integer? column) + ((and (integer? column) (<= 1 column column-limit)) column) - (else (rdms:error "column not in table:" + (else (slib:error "column not in table:" column table-name))))))) (lambda args (cond - ((null? args) - #f) + ((null? args) #f) + ((and base:make-nexter (eq? 'isam-next (car args))) + (base:make-nexter + base-table primary-limit column-type-list + (if (null? (cdr args)) + primary-limit + (translate-column (cadr args))))) + ((and base:make-prever (eq? 'isam-prev (car args))) + (base:make-prever + base-table primary-limit column-type-list + (if (null? (cdr args)) + primary-limit + (translate-column (cadr args))))) ((null? (cdr args)) (let ((pp (assq (car args) export-alist))) (and pp (cdr pp)))) ((not (null? (cddr args))) - (rdms:error "too many arguments to methods:" args)) + (slib:error "too many arguments to methods:" args)) (else (let ((ci (translate-column (cadr args)))) (cond @@ -514,36 +535,51 @@ (lambda mkeys (base:map-primary-key base-table - (lambda (ckey) (key-extractor ckey)) + key-extractor primary-limit column-type-list (norm-mkeys mkeys))))) (else #f))) (else - (let ((index (- ci (+ 1 primary-limit)))) - (case (car args) - ((get) (lambda keys - (let ((row (base:get base-table - (list->key keys)))) - (and row (list-ref row index))))) - ((get*) (lambda mkeys - (base:map-primary-key - base-table - (lambda (ckey) - (list-ref (base:get base-table ckey) - index)) - primary-limit column-type-list - (norm-mkeys mkeys)))) - (else #f))))))))))))) + (let ((index (- ci primary-limit 1)) + (get-1 (base 'make-getter-1))) + (cond + (get-1 + (set! get-1 + (get-1 primary-limit column-type-list ci)) + (case (car args) + ((get) (lambda keys + (get-1 base-table (list->key keys)))) + ((get*) (lambda mkeys + (base:map-primary-key + base-table + (lambda (ckey) (get-1 base-table ckey)) + primary-limit column-type-list + (norm-mkeys mkeys)))))) + (else + (case (car args) + ((get) (lambda keys + (let ((row (base:get base-table + (list->key keys)))) + (and row (list-ref row index))))) + ((get*) (lambda mkeys + (base:map-primary-key + base-table + (lambda (ckey) + (list-ref (base:get base-table ckey) + index)) + primary-limit column-type-list + (norm-mkeys mkeys)))) + (else #f))))))))))))))) (define create-table (and mutable (lambda (table-name . desc) - (if (not rdms:catalog) - (set! rdms:catalog (open-table rdms:catalog-name #t)) #f) + (or rdms:catalog + (set! rdms:catalog (open-table rdms:catalog-name #t))) (cond ((table-exists? table-name) - (rdms:error "table already exists:" table-name) #f) + (slib:error "table already exists:" table-name) #f) ((null? desc) (let ((colt-id (base:make-table lldb 1 (itypes columns:init-cols)))) @@ -576,11 +612,11 @@ ((coltable 'get* 'column-number)) ((coltable 'get* 'primary-key?)) ((coltable 'get* 'domain-name))) - (cond (colerr (rdms:error "some column lacks a number.") #f) + (cond (colerr (slib:error "some column lacks a number.") #f) ((or (< prilimit 1) (and (> prilimit 4) (not (= prilimit colimit)))) - (rdms:error "unreasonable number of primary keys:" + (slib:error "unreasonable number of primary keys:" prilimit)) (else ((rdms:catalog 'row:insert) @@ -588,8 +624,8 @@ (base:make-table lldb prilimit types) #f #f)) (open-table table-name #t))))) (else - (rdms:error "table descriptor not found for:" desc) #f)))) - (else (rdms:error 'create-table "too many args:" + (slib:error "table descriptor not found for:" desc) #f)))) + (else (slib:error 'create-table "too many args:" (cons table-name desc)) #f))))) @@ -599,8 +635,7 @@ (define delete-table (and mutable (lambda (table-name) - ;;(if (not rdms:catalog) - ;;(set! rdms:catalog (open-table rdms:catalog-name #t)) #f) + ;;(or rdms:catalog (set! rdms:catalog (open-table rdms:catalog-name #t))) (let* ((table (open-table table-name #t)) (row ((rdms:catalog 'row:remove) table-name))) (and row (base:kill-table @@ -615,10 +650,12 @@ ((close-database) close-database) ((write-database) write-database) ((sync-database) sync-database) + ((solidify-database) solidify-database) ((open-table) open-table) ((delete-table) delete-table) ((create-table) create-table) ((table-exists?) table-exists?) + ((filename) rdms:filename) (else #f))) ) (lambda (operation-name) @@ -5,13 +5,14 @@ (require 'object) (require 'common-list-functions) - +(define field:position position) +;@ (define record-type-name (make-generic-method)) (define record-accessor (make-generic-method)) (define record-modifier (make-generic-method)) (define record? (make-generic-predicate)) (define record-constructor (make-generic-method)) - +;@ (define (make-record-type type-name field-names) (define self (make-object)) @@ -20,7 +21,7 @@ type-name)) (make-method! self record-accessor (lambda (self field-name) - (let ((index (comlist:position field-name field-names))) + (let ((index (field:position field-name field-names))) (if (not index) (slib:error "record-accessor: invalid field-name argument." field-name)) @@ -29,7 +30,7 @@ (make-method! self record-modifier (lambda (self field-name) - (let ((index (comlist:position field-name field-names))) + (let ((index (field:position field-name field-names))) (if (not index) (slib:error "record-accessor: invalid field-name argument." field-name)) @@ -54,4 +55,4 @@ self) (provide 'record-object) -(provide 'record)
\ No newline at end of file +(provide 'record) @@ -1,6 +1,6 @@ ; "record.scm" record data types ; Written by David Carlton, carlton@husc.harvard.edu. -; Re-Written by Aubrey Jaffer, jaffer@ai.mit.edu, 1996, 1997 +; Re-Written by Aubrey Jaffer, agj @ alum.mit.edu, 1996, 1997 ; ; This code is in the public domain. @@ -22,14 +22,19 @@ (define vector->list vector->list) (define display display) (define write write) - +;@ (define record-modifier #f) (define record-accessor #f) (define record-constructor #f) (define record-predicate #f) (define make-record-type #f) -(let (;; Need to close these to keep magic-cookie hidden. +(let (;; protect CL functions against redefinition. + (has-duplicates? has-duplicates?) + (notevery notevery) + (position position) + + ;; Need to close these to keep magic-cookie hidden. (make-vect make-vector) (vect vector) @@ -89,8 +94,8 @@ (if (not (or (symbol? type-name) (string? type-name))) (slib:error 'make-record-type "non-string type-name argument." type-name)) - (if (or (and (list? field-names) (comlist:has-duplicates? field-names)) - (comlist:notevery symbol? field-names)) + (if (or (and (list? field-names) (has-duplicates? field-names)) + (notevery symbol? field-names)) (slib:error 'make-record-type "illegal field-names argument." field-names)) (let* ((augmented-length (+ 1 (length field-names))) @@ -136,15 +141,15 @@ (let ((rec-vfields (rtd-vfields rtd)) (corrected-rec-length (rtd-length rtd)) (field-names (car field-names))) - (if (or (and (list? field-names) (comlist:has-duplicates? field-names)) - (comlist:notevery (lambda (x) (memq x rec-vfields)) + (if (or (and (list? field-names) (has-duplicates? field-names)) + (notevery (lambda (x) (memq x rec-vfields)) field-names)) (slib:error 'record-constructor "invalid field-names argument." (cdr rec-vfields))) (let ((field-length (length field-names)) (offsets - (map (lambda (field) (comlist:position field rec-vfields)) + (map (lambda (field) (position field rec-vfields)) field-names))) (lambda elts (if (= (length elts) field-length) #t @@ -163,7 +168,7 @@ (lambda (rtd field-name) (if (not (rtd? rtd)) (slib:error 'record-accessor "invalid rtd argument." rtd)) - (let ((index (comlist:position field-name (rtd-vfields rtd))) + (let ((index (position field-name (rtd-vfields rtd))) (augmented-length (rtd-length rtd))) (if (not index) (slib:error 'record-accessor "invalid field-name argument." @@ -180,7 +185,7 @@ (lambda (rtd field-name) (if (not (rtd? rtd)) (slib:error 'record-modifier "invalid rtd argument." rtd)) - (let ((index (comlist:position field-name (rtd-vfields rtd))) + (let ((index (position field-name (rtd-vfields rtd))) (augmented-length (rtd-length rtd))) (if (not index) (slib:error 'record-modifier "invalid field-name argument." @@ -209,7 +214,7 @@ (cond ((rec? vct) (vec:error 'vector-set! nvt vct)) (else (vect-set! vct k obj))))) (set! vector-fill! - (lambda (vector fill) + (lambda (vct fill) (cond ((rec? vct) (vec:error 'vector-fill! nvt vct)) (else (vect-fill! vct fill))))) @@ -1,5 +1,5 @@ ; "repl.scm", read-eval-print-loop for 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. ; @@ -17,9 +17,13 @@ ;promotional, or sales literature without prior written consent in ;each case. +(require 'values) (require 'dynamic-wind) +(require-if 'compiling 'qp) +(require-if 'compiling 'debug) +;@ (define (repl:quit) (slib:error "not in repl:repl")) - +;@ (define (repl:top-level repl:eval) (repl:repl (lambda () (display "> ") (force-output (current-output-port)) @@ -49,44 +53,41 @@ (repl:eval o)) (set! *load-pathname* old-load-pathname)))))) (repl:restart #f) - (values? (provided? 'values)) (has-char-ready? (provided? 'char-ready?)) (repl:error (lambda args (require 'debug) (apply qpn args) (repl:restart #f)))) (dynamic-wind - (lambda () - (set! load repl:load) - (set! slib:eval repl:eval) - (set! slib:error repl:error) - (set! repl:quit - (lambda () (let ((cont repl:restart)) - (set! repl:restart #f) - (cont #t))))) - (lambda () - (do () ((call-with-current-continuation - (lambda (cont) - (set! repl:restart cont) - (do ((obj (repl:read) (repl:read))) - ((eof-object? obj) (repl:quit)) - (cond - (has-char-ready? - (let loop () - (cond ((char-ready?) - (let ((c (peek-char))) - (cond - ((eof-object? c)) - ((char=? #\newline c) (read-char)) - ((char-whitespace? c) - (read-char) (loop)) - (else (newline))))))))) - (if values? - (call-with-values (lambda () (repl:eval obj)) - repl:print) - (repl:print (repl:eval obj))))))))) - (lambda () (cond (repl:restart - (display ">>ERROR<<") (newline) - (repl:restart #f))) - (set! load old-load) - (set! slib:eval old-eval) - (set! slib:error old-error) - (set! repl:quit old-quit))))) + (lambda () + (set! load repl:load) + (set! slib:eval repl:eval) + (set! slib:error repl:error) + (set! repl:quit + (lambda () (let ((cont repl:restart)) + (set! repl:restart #f) + (cont #t))))) + (lambda () + (do () ((call-with-current-continuation + (lambda (cont) + (set! repl:restart cont) + (do ((obj (repl:read) (repl:read))) + ((eof-object? obj) (repl:quit)) + (cond + (has-char-ready? + (let loop () + (cond ((char-ready?) + (let ((c (peek-char))) + (cond + ((eof-object? c)) + ((char=? #\newline c) (read-char)) + ((char-whitespace? c) + (read-char) (loop)) + (else (newline))))))))) + (call-with-values (lambda () (repl:eval obj)) + repl:print))))))) + (lambda () (cond (repl:restart + (display ">>ERROR<<") (newline) + (repl:restart #f))) + (set! load old-load) + (set! slib:eval old-eval) + (set! slib:error old-error) + (set! repl:quit old-quit))))) diff --git a/report.scm b/report.scm deleted file mode 100644 index 2c44a23..0000000 --- a/report.scm +++ /dev/null @@ -1,116 +0,0 @@ -;;; "report.scm" relational-database-utility -; Copyright 1995 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 warrantee 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. - -;;;; Considerations for report generation: -; * columnar vs. fixed-multi-line vs. variable-multi-line -; * overflow lines within column boundaries. -; * break overflow across page? -; * Page headers and footers (need to know current/previous record-number -; and next record-number). -; * Force page break on general expression (needs next row as arg). -; * Hierachical reports. - -;================================================================ - -(require 'format) -(require 'database-utilities) - -(define (dbutil:database arg) - (cond ((procedure? arg) arg) - ((string? arg) (dbutil:open-database arg)) - ((symbol? arg) (slib:eval arg)) - (else (slib:error "can't coerce to database: " arg)))) - -(define (dbutil:table arg) - (cond ((procedure? arg) arg) - ((and (list? arg) (= 2 (length arg))) - (((dbutil:database (car arg)) 'open-table) (cadr arg) #f)))) - -(define (dbutil:print-report table header reporter footer . args) - (define output-port (and (pair? args) (car args))) - (define page-height (and (pair? args) (pair? (cdr args)) (cadr args))) - (define minimum-break - (and (pair? args) (pair? (cdr args)) (pair? (cddr args)) (caddr args))) - (set! table (dbutil:table table)) - ((lambda (fun) - (cond ((output-port? output-port) - (fun output-port)) - ((string? output-port) - (call-with-output-file output-port fun)) - ((or (boolean? output-port) (null? output-port)) - (fun (current-output-port))) - (else (slib:error "can't coerce to output-port: " arg)))) - (lambda (output-port) - (set! page-height (or page-height (output-port-height output-port))) - (set! minimum-break (or minimum-break 0)) - (let ((output-page 0) - (output-line 0) - (nth-newline-index - (lambda (str n) - (define len (string-length str)) - (do ((i 0 (+ i 1))) - ((or (zero? n) (> i len)) (+ -1 i)) - (cond ((char=? #\newline (string-ref str i)) - (set! n (+ -1 n))))))) - (count-newlines - (lambda (str) - (define cnt 0) - (do ((i (+ -1 (string-length str)) (+ -1 i))) - ((negative? i) cnt) - (cond ((char=? #\newline (string-ref str i)) - (set! cnt (+ 1 cnt))))))) - (format (let ((oformat format)) - (lambda (dest fmt arg) - (cond ((not (procedure? fmt)) (oformat dest fmt arg)) - ((output-port? dest) (fmt dest arg)) - ((eq? #t dest) (fmt (current-output-port) arg)) - ((eq? #f dest) (call-with-output-string - (lambda (port) (fmt port arg)))) - (else (oformat dest fmt arg))))))) - (define column-names (table 'column-names)) - (define (do-header) - (let ((str (format #f header column-names))) - (display str output-port) - (set! output-line (count-newlines str)))) - (define (do-lines str inc) - (cond - ((< (+ output-line inc) page-height) - (display str output-port) - (set! output-line (+ output-line inc))) - (else ;outputting footer - (cond ((and (not (zero? minimum-break)) - (> cnt (* 2 minimum-break)) - (> (- page-height output-line) minimum-break)) - (let ((break (nth-newline-index - str (- page-height output-line)))) - (display (substring str 0 (+ 1 break) output-port)) - (set! str (substring str (+ 1 break) (string-length str))) - (set! inc (- inc (- page-height output-line)))))) - (format output-port footer column-names) - (display slib:form-feed output-port) - (set! output-page (+ 1 output-page)) - (do-header) - (do-lines str inc)))) - - (do-header) - ((table 'for-each-row) - (lambda (row) - (let ((str (format #f reporter row))) - (do-lines str (count-newlines str))))) - output-page)))) diff --git a/require.scm b/require.scm index e5d919d..a11cbf5 100644 --- a/require.scm +++ b/require.scm @@ -1,5 +1,5 @@ ;;;; Implementation of VICINITY and MODULES for Scheme -;Copyright (C) 1991, 1992, 1993, 1994, 1997 Aubrey Jaffer +;Copyright (C) 1991, 1992, 1993, 1994, 1997, 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. ; @@ -16,21 +16,16 @@ ;material, there shall be no use of my name in any advertising, ;promotional, or sales literature without prior written consent in ;each case. - -(define *SLIB-VERSION* "2d2") - -;;; Standardize msdos -> ms-dos. -(define software-type - (cond ((eq? 'msdos (software-type)) - (lambda () 'ms-dos)) - (else software-type))) - +;@ +(define *SLIB-VERSION* "3a1") +;@ (define (user-vicinity) (case (software-type) ((VMS) "[.]") (else ""))) - +;@ (define *load-pathname* #f) +;@ (define vicinity:suffix? (let ((suffi (case (software-type) @@ -38,18 +33,21 @@ ((MACOS THINKC) '(#\:)) ((MS-DOS WINDOWS ATARIST OS/2) '(#\\ #\/)) ((NOSVE) '(#\: #\.)) - ((UNIX COHERENT) '(#\/)) + ((UNIX COHERENT PLAN9) '(#\/)) ((VMS) '(#\: #\]))))) - (lambda (chr) (memv chr suffi)))) + (lambda (chr) (and (memv chr suffi) #t)))) +;@ +(define (pathname->vicinity pathname) + (let loop ((i (- (string-length pathname) 1))) + (cond ((negative? i) "") + ((vicinity:suffix? (string-ref pathname i)) + (substring pathname 0 (+ i 1))) + (else (loop (- i 1)))))) (define (program-vicinity) (if *load-pathname* - (let loop ((i (- (string-length *load-pathname*) 1))) - (cond ((negative? i) "") - ((vicinity:suffix? (string-ref *load-pathname* i)) - (substring *load-pathname* 0 (+ i 1))) - (else (loop (- i 1))))) + (pathname->vicinity *load-pathname*) (slib:error 'program-vicinity " called; use slib:load to load"))) - +;@ (define sub-vicinity (case (software-type) ((VMS) (lambda @@ -65,10 +63,10 @@ ((NOSVE) ".") ((MACOS THINKC) ":") ((MS-DOS WINDOWS ATARIST OS/2) "\\") - ((UNIX COHERENT AMIGA) "/")))) + ((UNIX COHERENT PLAN9 AMIGA) "/")))) (lambda (vic name) (string-append vic name *vicinity-suffix*)))))) - +;@ (define (make-vicinity <pathname>) <pathname>) (define (slib:pathnameize-load *old-load*) @@ -76,7 +74,6 @@ (let ((old-load-pathname *load-pathname*)) (set! *load-pathname* <pathname>) (apply *old-load* (cons <pathname> extra)) - (require:provide <pathname>) (set! *load-pathname* old-load-pathname)))) (set! slib:load-source @@ -85,11 +82,11 @@ (slib:pathnameize-load slib:load)) ;;;; MODULES - +;@ (define *catalog* #f) -(define *modules* '()) - -(define (require:version path) +(define *base-table-implementations* '()) +;@ +(define (slib:version path) (let ((expr (and (file-exists? path) (call-with-input-file path (lambda (port) (read port)))))) (and (list? expr) (= 3 (length expr)) @@ -100,7 +97,7 @@ (let* ((apair (assq '*SLIB-VERSION* slibcat)) (req (in-vicinity (library-vicinity) (string-append "require" (scheme-file-suffix)))) - (reqvers (require:version req))) + (reqvers (slib:version req))) (cond ((not (file-exists? req)) (slib:warn "can't find " req) #f) ((not apair) #f) @@ -121,6 +118,21 @@ ((eof-object? expr) (apply append lst)))))))) '())) +;@ +(define (catalog:resolve vicinity catlist) + (define (res1 e) (if (string? e) (in-vicinity vicinity e) e)) + (define (resolve p) + (cond ((symbol? (cdr p)) p) + ((not (list? p)) (cons (car p) (res1 (cdr p)))) + ((null? (cddr p)) (cons (car p) (res1 (cadr p)))) + (else (map res1 p)))) + (map resolve catlist)) +;@ +(define (catalog:read vicinity cat) + (catalog:get #f) ; make sure *catalog* exists + (set! *catalog* + (append (catalog:resolve vicinity (catalog:try-read vicinity cat)) + *catalog*))) (define (catalog:get feature) (if (not *catalog*) @@ -139,124 +151,136 @@ (set! *catalog* (append (catalog:try-read (user-vicinity) "usercat") *catalog*)))) (and feature *catalog* (cdr (or (assq feature *catalog*) '(#f . #f))))) +;@ +(define (slib:in-catalog? feature) + (let ((path (catalog:get feature))) + (if (symbol? path) (slib:in-catalog? path) path))) -(define (require:provided? feature) - (if (symbol? feature) - (if (memq feature *features*) #t - (and *catalog* - (let ((path (catalog:get feature))) - (cond ((symbol? path) (require:provided? path)) - ((member (if (pair? path) (cdr path) path) *modules*) - #t) - (else #f))))) - (and (member feature *modules*) #t))) - -(define (require:feature->path feature) - (and (symbol? feature) - (let ((path (catalog:get feature))) - (if (symbol? path) (require:feature->path path) path)))) - -(define (require:require feature) - (or (require:provided? feature) - (let ((path (catalog:get feature))) - (cond ((and (not path) (string? feature) (file-exists? feature)) - (set! path feature))) - (cond ((not feature) (set! *catalog* #f)) - ((not path) - (slib:error ";required feature not supported: " feature)) - ((symbol? path) (require:require path) (require:provide feature)) - ((not (pair? path)) ;simple name - (slib:load path) - (and (not (eq? 'new-catalog feature)) (require:provide feature))) - (else ;special loads - (require:require (car path)) - (apply (case (car path) - ((macro) macro:load) - ((syntactic-closures) synclo:load) - ((syntax-case) syncase:load) - ((macros-that-work) macwork:load) - ((macro-by-example) defmacro:load) - ((defmacro) defmacro:load) - ((source) slib:load-source) - ((compiled) slib:load-compiled) - (else (slib:error "unknown package loader" path))) - (if (list? path) (cdr path) (list (cdr path)))) - (require:provide feature)))))) - -(define (require:provide feature) - (if (symbol? feature) - (if (not (memq feature *features*)) - (set! *features* (cons feature *features*))) - (if (not (member feature *modules*)) - (set! *modules* (cons feature *modules*))))) - -(require:provide 'vicinity) +;@ +(define (feature-eval expression provided?) + (define (bail expression) + (slib:error 'invalid 'feature 'expression expression)) + (define (feval expression) + (cond ((not expression) expression) + ((symbol? expression) (provided? expression)) + ((and (list? expression) (pair? expression)) + (case (car expression) + ((not) (case (length expression) + ((2) (not (feval (cadr expression)))) + (else (bail expression)))) + ((or) (case (length expression) + ((1) #f) + ;;((2) (feval (cadr expression))) + (else (or (feval (cadr expression)) + (feval (cons 'or (cddr expression))))))) + ((and) (case (length expression) + ((1) #t) + ;;((2) (feval (cadr expression))) + (else (and (feval (cadr expression)) + (feval (cons 'and (cddr expression))))))) + (else (bail expression)))) + (else (bail expression)))) + (feval expression)) +;@ +(define (provided? expression) + (define feature-list (cons (software-type) *features*)) + (define (provided? expression) + (if (memq expression feature-list) #t + (and *catalog* + (let ((path (catalog:get expression))) + (cond ((symbol? path) (provided? path)) + (else #f)))))) + (feature-eval expression provided?)) +;@ +(define (require feature) + (cond + ((not feature) (set! *catalog* #f)) + ((slib:provided? feature)) + (else + (let ((path (catalog:get feature))) + (cond ((not path) + (slib:error 'slib:require 'unsupported 'feature feature)) + ((symbol? path) (slib:provide feature) (slib:require path)) + ((string? path) ;simple name + (and (not (eq? 'new-catalog feature)) (slib:provide feature)) + (slib:load path)) + (else ;dispatched loads + (slib:provide feature) + (slib:require (car path)) + (apply (case (car path) + ((macro) macro:load) + ((syntactic-closures) synclo:load) + ((syntax-case) syncase:load) + ((macros-that-work) macwork:load) + ((macro-by-example) defmacro:load) + ((defmacro) defmacro:load) + ((source) slib:load-source) + ((compiled) slib:load-compiled) + ((aggregate) + (lambda feature (for-each slib:require feature))) + ((spectral-tristimulus-values) load-ciexyz) + ((color-names) + (lambda (filename) + (load-color-dictionary feature filename))) + (else (slib:error "unknown package loader" path))) + (if (list? path) (cdr path) (list (cdr path)))))))))) +;@ +(define (require-if feature? feature) + (if (slib:provided? feature?) (slib:require feature))) +;@ +(define (provide feature) + (if (not (memq feature *features*)) + (set! *features* (cons feature *features*)))) -(define provide require:provide) -(define provided? require:provided?) -(define require require:require) +;@ +(define slib:provide provide) +(define slib:provided? provided?) +(define slib:require require) +(define slib:require-if require-if) +;;; Legacy +(define require:provide provide) +(define require:provided? provided?) +(define require:require require) +(slib:provide 'vicinity) (if (and (string->number "0.0") (inexact? (string->number "0.0"))) - (require:provide 'inexact)) -(if (rational? (string->number "1/19")) (require:provide 'rational)) -(if (real? (string->number "0.0")) (require:provide 'real)) -(if (complex? (string->number "1+i")) (require:provide 'complex)) + (slib:provide 'inexact)) +(if (rational? (string->number "1/19")) (slib:provide 'rational)) +(if (real? (string->number "0.0")) (slib:provide 'real)) +(if (complex? (string->number "1+i")) (slib:provide 'complex)) (let ((n (string->number "9999999999999999999999999999999"))) - (if (and n (exact? n)) (require:provide 'bignum))) + (if (and n (exact? n)) (slib:provide 'bignum))) (cond - ((provided? 'srfi) - (cond-expand (srfi-0 (provide 'srfi-0)) (else #f)) - (cond-expand (srfi-1 (provide 'srfi-1)) (else #f)) - (cond-expand (srfi-2 (provide 'srfi-2)) (else #f)) - (cond-expand (srfi-3 (provide 'srfi-3)) (else #f)) - (cond-expand (srfi-4 (provide 'srfi-4)) (else #f)) - (cond-expand (srfi-5 (provide 'srfi-5)) (else #f)) - (cond-expand (srfi-6 (provide 'srfi-6)) (else #f)) - (cond-expand (srfi-7 (provide 'srfi-7)) (else #f)) - (cond-expand (srfi-8 (provide 'srfi-8)) (else #f)) - (cond-expand (srfi-9 (provide 'srfi-9)) (else #f)) - (cond-expand (srfi-10 (provide 'srfi-10)) (else #f)) - (cond-expand (srfi-11 (provide 'srfi-11)) (else #f)) - (cond-expand (srfi-12 (provide 'srfi-12)) (else #f)) - (cond-expand (srfi-13 (provide 'srfi-13)) (else #f)) - (cond-expand (srfi-14 (provide 'srfi-14)) (else #f)) - (cond-expand (srfi-15 (provide 'srfi-15)) (else #f)) - (cond-expand (srfi-16 (provide 'srfi-16)) (else #f)) - (cond-expand (srfi-17 (provide 'srfi-17)) (else #f)) - (cond-expand (srfi-18 (provide 'srfi-18)) (else #f)) - (cond-expand (srfi-19 (provide 'srfi-19)) (else #f)) - (cond-expand (srfi-20 (provide 'srfi-20)) (else #f)) - (cond-expand (srfi-21 (provide 'srfi-21)) (else #f)) - (cond-expand (srfi-22 (provide 'srfi-22)) (else #f)) - (cond-expand (srfi-23 (provide 'srfi-23)) (else #f)) - (cond-expand (srfi-24 (provide 'srfi-24)) (else #f)) - (cond-expand (srfi-25 (provide 'srfi-25)) (else #f)) - (cond-expand (srfi-26 (provide 'srfi-26)) (else #f)) - (cond-expand (srfi-27 (provide 'srfi-27)) (else #f)) - (cond-expand (srfi-28 (provide 'srfi-28)) (else #f)) - (cond-expand (srfi-29 (provide 'srfi-29)) (else #f)) - (cond-expand (srfi-30 (provide 'srfi-30)) (else #f)))) + ((slib:provided? 'srfi) + (do ((idx 0 (+ 1 idx)) + (srfis (symbol->string 'srfi-))) + ((> idx 100)) + (let ((srfi (string->symbol (string-append srfis (number->string idx))))) + (if (slib:eval `(cond-expand (,srfi #t) (else #f))) + (slib:provide srfi)))))) (define report:print (lambda args (for-each (lambda (x) (write x) (display #\ )) args) (newline))) +;@ (define slib:report (let ((slib:report (lambda () (slib:report-version) (slib:report-locations)))) (lambda args (cond ((null? args) (slib:report)) ((not (string? (car args))) (slib:report-version) (slib:report-locations #t)) - ((require:provided? 'transcript) + ((slib:provided? 'transcript) (transcript-on (car args)) (slib:report) (transcript-off)) - ((require:provided? 'with-file) + ((slib:provided? 'with-file) (with-output-to-file (car args) slib:report)) (else (slib:report)))))) +;@ (define slib:report-version (lambda () (report:print @@ -266,13 +290,13 @@ (define slib:report-locations (let ((features *features*)) (lambda args + (define sit (scheme-implementation-type)) + (define siv (string->symbol (scheme-implementation-version))) (report:print '(IMPLEMENTATION-VICINITY) 'is (implementation-vicinity)) (report:print '(LIBRARY-VICINITY) 'is (library-vicinity)) (report:print '(SCHEME-FILE-SUFFIX) 'is (scheme-file-suffix)) (cond (*load-pathname* (report:print '*LOAD-PATHNAME* 'is *load-pathname*))) - (cond ((not (null? *modules*)) - (report:print 'Loaded '*MODULES* 'are: *modules*))) (let* ((i (+ -1 5))) (cond ((eq? (car features) (car *features*))) (else (report:print 'loaded '*FEATURES* ':) (display slib:tab))) @@ -280,14 +304,14 @@ (lambda (x) (cond ((eq? (car features) x) (if (not (eq? (car features) (car *features*))) (newline)) - (report:print 'Implementation '*FEATURES* ':) + (report:print sit siv '*FEATURES* ':) (display slib:tab) (set! i (+ -1 5))) ((zero? i) (newline) (display slib:tab) (set! i (+ -1 5))) ((not (= (+ -1 5) i)) (display #\ ))) (write x) (set! i (+ -1 i))) *features*)) (newline) - (report:print 'Implementation '*CATALOG* ':) + (report:print sit siv '*CATALOG* ':) (catalog:get #f) (cond ((pair? args) (for-each (lambda (x) (display slib:tab) (report:print x)) @@ -296,9 +320,9 @@ (display slib:tab) (report:print '...))) (newline)))) -(let ((sit (scheme-implementation-version))) - (cond ((zero? (string-length sit))) - ((or (not (string? sit)) (char=? #\? (string-ref sit 0))) +(let ((siv (scheme-implementation-version))) + (cond ((zero? (string-length siv))) + ((or (not (string? siv)) (char=? #\? (string-ref siv 0))) (newline) (slib:report-version) (report:print 'edit (scheme-implementation-type) ".init" diff --git a/resenecolours.txt b/resenecolours.txt new file mode 100644 index 0000000..702e987 --- /dev/null +++ b/resenecolours.txt @@ -0,0 +1,1410 @@ +"Resene RGB Values List" +"For further information refer to http://www.resene.co.nz" +"Copyright Resene Paints Ltd 2001" + +"Permission to copy this dictionary, 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 text copy made of this dictionary must include this copyright" +"notice in full." + +"2. Any redistribution in binary form must reproduce this copyright" +"notice in the documentation or other materials provided with the" +"distribution." + +"3. Resene Paints Ltd makes no warranty or representation that this" +"dictionary is error-free, and is under no obligation to provide any" +"services, by way of maintenance, update, or otherwise." + +"4. There shall be no use of the name of Resene or Resene Paints Ltd" +"in any advertising, promotional, or sales literature without prior" +"written consent in each case." + +"5. These RGB colour formulations may not be used to the detriment of" +"Resene Paints Ltd." + +"Colour Name" "R" "G" "B" +"Abbey" 76 79 86 +"Acadia" 27 20 4 +"Acapulco" 124 176 161 +"Acorn" 106 93 27 +"Aero Blue" 201 255 229 +"Affair" 113 70 147 +"Afghan Tan" 134 86 10 +"Akaroa" 212 196 168 +"Alabaster" 255 255 255 +"Albescent White" 245 233 211 +"Alert Tan" 155 71 3 +"Allports" 0 118 163 +"Almond Frost" 144 123 113 +"Alpine" 175 143 44 +"Alto" 219 219 219 +"Aluminium" 169 172 182 +"Amazon" 59 122 87 +"Americano" 135 117 110 +"Amethyst Smoke" 163 151 180 +"Amour" 249 234 243 +"Amulet" 123 159 128 +"Anakiwa" 157 229 255 +"Antique Brass" 112 74 7 +"Anzac" 224 182 70 +"Apache" 223 190 111 +"Apple" 79 168 61 +"Apple Blossom" 175 77 67 +"Apple Green" 226 243 236 +"Apricot" 235 147 115 +"Apricot White" 255 254 236 +"Aqua" 161 218 215 +"Aqua Haze" 237 245 245 +"Aqua Spring" 234 249 245 +"Aqua Squeeze" 232 245 242 +"Aquamarine" 1 75 67 +"Arapawa" 17 12 108 +"Armadillo" 67 62 55 +"Arrowtown" 148 135 113 +"Ash" 198 195 181 +"Ash Brown" 46 25 5 +"Asphalt" 19 10 6 +"Astra" 250 234 185 +"Astral" 50 125 160 +"Astronaut" 40 58 119 +"Astronaut Blue" 1 62 98 +"Athens Grey" 238 240 243 +"Aths Special" 236 235 206 +"Atlantis" 151 205 45 +"Atoll" 10 111 117 +"Atomic" 49 68 89 +"Au Chico" 151 96 93 +"Aubergine" 59 9 16 +"Australian Mint" 245 255 190 +"Avocado" 136 141 101 +"Axolotl" 78 102 73 +"Azalea" 247 200 218 +"Aztec" 13 28 25 +"Azure" 49 91 161 +"Bahama Blue" 2 99 149 +"Bahia" 165 203 12 +"Baja White" 255 248 209 +"Bali Hai" 133 159 175 +"Baltic Sea" 42 38 48 +"Bamboo" 218 99 4 +"Bandicoot" 133 132 112 +"Banjul" 19 10 6 +"Barberry" 222 215 23 +"Barley Corn" 166 139 91 +"Barley White" 255 244 206 +"Barossa" 68 1 45 +"Bastille" 41 33 48 +"Battleship Grey" 130 143 114 +"Bay Leaf" 125 169 141 +"Bay of Many" 39 58 129 +"Bazaar" 152 119 123 +"Bean " 61 12 2 +"Beauty Bush" 238 193 190 +"Beeswax" 254 242 199 +"Bermuda" 125 216 198 +"Bermuda Grey" 107 139 162 +"Beryl Green" 222 229 192 +"Bianca" 252 251 243 +"Big Stone" 22 42 64 +"Bilbao" 50 124 20 +"Biloba Flower" 178 161 234 +"Birch" 55 48 33 +"Bird Flower" 212 205 22 +"Biscay" 27 49 98 +"Bismark" 73 113 131 +"Bison Hide" 193 183 164 +"Bitter" 134 137 116 +"Bitter Lemon" 202 224 13 +"Bizarre" 238 222 218 +"Black Bean" 8 25 16 +"Black Forest" 11 19 4 +"Black Haze" 246 247 247 +"Black Magic" 37 23 6 +"Black Marlin" 62 44 28 +"Black Pearl" 4 19 34 +"Black Pepper" 14 14 24 +"Black Rock" 13 3 50 +"Black Rose" 103 3 45 +"Black Russian" 10 0 28 +"Black Squeeze" 242 250 250 +"Black White" 255 254 246 +"Blackberry" 77 1 53 +"Blackcurrant" 50 41 58 +"Blackwood" 38 17 5 +"Blanc" 245 233 211 +"Bleach White" 254 243 216 +"Bleached Cedar" 44 33 51 +"Blossom" 220 180 188 +"Blue Bark" 4 19 34 +"Blue Bayoux" 73 102 121 +"Blue Bell" 34 8 120 +"Blue Chalk" 241 233 255 +"Blue Charcoal" 1 13 26 +"Blue Chill" 12 137 144 +"Blue Diamond" 56 4 116 +"Blue Dianne" 32 72 82 +"Blue Gem" 44 14 140 +"Blue Haze" 191 190 216 +"Blue Lagoon" 1 121 135 +"Blue Marguerite" 118 102 198 +"Blue Romance" 210 246 222 +"Blue Smoke" 116 136 129 +"Blue Stone" 1 97 98 +"Blue Whale" 4 46 76 +"Blue Zodiac" 19 38 77 +"Blumine" 24 88 122 +"Blush" 180 70 104 +"Bokara Grey" 28 18 8 +"Bombay" 175 177 184 +"Bon Jour" 229 224 225 +"Bondi Blue" 2 71 142 +"Bone" 228 209 192 +"Bordeaux" 92 1 32 +"Bossanova" 78 42 90 +"Boston Blue" 59 145 180 +"Botticelli" 199 221 229 +"Bottle Green" 9 54 36 +"Boulder" 122 122 122 +"Bouquet" 174 128 158 +"Bourbon" 186 111 30 +"Bracken" 74 42 4 +"Brandy" 222 193 150 +"Brandy Punch" 205 132 41 +"Brandy Rose" 187 137 131 +"Brazil" 136 98 33 +"Breaker Bay" 93 161 159 +"Bridal Heath" 255 250 244 +"Bridesmaid" 254 240 236 +"Bright Grey" 60 65 81 +"Bright Red" 177 0 0 +"Bright Sun" 254 211 60 +"Bronco" 171 161 150 +"Bronze" 63 33 9 +"Bronze Olive" 78 66 12 +"Bronzetone" 77 64 15 +"Broom" 255 236 19 +"Brown Bramble" 89 40 4 +"Brown Derby" 73 38 21 +"Brown Pod" 64 24 1 +"Bubbles" 231 254 255 +"Buccaneer" 98 47 48 +"Bud" 168 174 156 +"Buddha Gold" 193 160 4 +"Bulgarian Rose" 72 6 7 +"Bull Shot" 134 77 30 +"Bunker" 13 17 23 +"Bunting" 21 31 76 +"Burgundy" 119 15 5 +"Burnham" 0 46 32 +"Burning Sand" 217 147 118 +"Burnt Crimson" 101 0 11 +"Bush" 13 46 28 +"Buttercup" 243 173 22 +"Buttered Rum" 161 117 13 +"Butterfly Bush" 98 78 154 +"Buttermilk" 255 241 181 +"Buttery White" 255 252 234 +"Cab Sav" 77 10 24 +"Cabaret" 217 73 114 +"Cabbage Pont" 63 76 58 +"Cactus" 88 113 86 +"Cadillac" 176 76 106 +"Cafe Royale" 111 68 12 +"Calico" 224 192 149 +"California" 254 157 4 +"Calypso" 49 114 141 +"Camarone" 0 88 26 +"Camelot" 137 52 86 +"Cameo" 217 185 155 +"Camouflage" 60 57 16 +"Can Can" 213 145 164 +"Canary" 243 251 98 +"Candlelight" 252 217 23 +"Cannon Black" 37 23 6 +"Cannon Pink" 137 67 103 +"Canvas" 168 165 137 +"Cape Cod" 60 68 67 +"Cape Honey" 254 229 172 +"Cape Palliser" 162 102 69 +"Caper" 220 237 180 +"Capri" 6 42 120 +"Caramel" 255 221 175 +"Cararra" 238 238 232 +"Cardin Green" 1 54 28 +"Cardinal" 140 5 94 +"Careys Pink" 210 158 170 +"Carissma" 234 136 168 +"Carla" 243 255 216 +"Carnaby Tan" 92 46 1 +"Carousel Pink" 249 224 237 +"Casablanca" 248 184 83 +"Casal" 47 97 104 +"Cascade" 139 169 165 +"Cashmere" 230 190 165 +"Casper" 173 190 209 +"Castro" 82 0 31 +"Catalina Blue" 6 42 120 +"Catskill White" 238 246 247 +"Cavern Pink" 227 190 190 +"Ce Soir" 151 113 181 +"Cedar" 62 28 20 +"Cedar Wood Finish" 113 26 0 +"Celery" 184 194 93 +"Celeste" 209 210 202 +"Cello" 30 56 91 +"Celtic" 22 50 34 +"Cement" 141 118 98 +"Ceramic" 252 255 249 +"Chablis" 255 244 243 +"Chalet Green" 81 110 61 +"Chalky" 238 215 148 +"Chambray" 53 78 140 +"Chamois" 237 220 177 +"Champagne" 250 236 204 +"Chantilly" 248 195 223 +"Charade" 41 41 55 +"Chardon" 255 243 241 +"Chardonnay" 255 205 140 +"Charlotte" 186 238 249 +"Charm" 212 116 148 +"Chateau Green" 64 168 96 +"Chatelle" 189 179 199 +"Chathams Blue" 23 85 121 +"Chelsea Cucumber" 131 170 93 +"Chelsea Gem" 158 83 2 +"Chenin" 223 205 111 +"Cherokee" 252 218 152 +"Cherry Pie" 42 3 89 +"Cherrywood" 101 26 20 +"Cherub" 248 217 233 +"Chetwode Blue" 133 129 217 +"Chicago" 93 92 88 +"Chiffon" 241 255 200 +"Chilean Fire" 247 119 3 +"Chilean Heath" 255 253 230 +"China Ivory" 252 255 231 +"Chino" 206 199 167 +"Chinook" 168 227 189 +"Chocolate" 55 2 2 +"Christalle" 51 3 107 +"Christi" 103 167 18 +"Christine" 231 115 10 +"Chrome White" 232 241 212 +"Cigar" 119 63 26 +"Cinder" 14 14 24 +"Cinderella" 253 225 220 +"Cinnamon" 123 63 0 +"Cioccolato" 85 40 12 +"Citrine White" 250 247 214 +"Citron" 158 169 31 +"Citrus" 161 197 10 +"Clairvoyant" 72 6 86 +"Clam Shell" 212 182 175 +"Claret" 127 23 52 +"Classic Rose" 251 204 231 +"Clay Creek" 138 131 96 +"Clear Day" 233 255 253 +"Clementine" 233 110 0 +"Clinker" 55 29 9 +"Cloud" 199 196 191 +"Cloud Burst" 32 46 84 +"Cloudy" 172 165 159 +"Clover" 56 73 16 +"Cobalt" 6 42 120 +"Cocoa Bean" 72 28 28 +"Cocoa Brown" 48 31 30 +"Coconut Cream" 248 247 220 +"Cod Grey" 11 11 11 +"Coffee" 112 101 85 +"Coffee Bean" 42 20 14 +"Cognac" 159 56 29 +"Cola" 63 37 0 +"Cold Purple" 171 160 217 +"Cold Turkey" 206 186 186 +"Colonial White" 255 237 188 +"Comet" 92 93 117 +"Como" 81 124 102 +"Conch" 201 217 210 +"Concord" 124 123 122 +"Concrete" 242 242 242 +"Confetti" 233 215 90 +"Congo Brown" 89 55 55 +"Conifer" 172 221 77 +"Contessa" 198 114 107 +"Copper Canyon" 126 58 21 +"Copper Rust" 148 71 71 +"Coral" 199 188 162 +"Coral Candy" 255 220 214 +"Coral Tree" 168 107 107 +"Corduroy" 96 110 104 +"Coriander" 196 208 176 +"Cork" 64 41 29 +"Corn" 231 191 5 +"Corn Field" 248 250 205 +"Corn Harvest" 139 107 11 +"Cornflower" 255 176 172 +"Corvette" 250 211 162 +"Cosmic" 118 57 93 +"Cosmos" 255 216 217 +"Costa Del Sol" 97 93 48 +"Cotton Seed" 194 189 182 +"County Green" 1 55 26 +"Cove Grey" 5 22 87 +"Cowboy" 77 40 45 +"Crab Apple" 160 39 18 +"Crail" 185 81 64 +"Cranberry" 182 49 108 +"Crater Brown" 70 36 37 +"Cream Brulee" 255 229 160 +"Cream Can" 245 200 92 +"Creme De Banane" 255 252 153 +"Creole" 30 15 4 +"Crete" 115 120 41 +"Crocodile" 115 109 88 +"Crown of Thorns" 119 31 31 +"Crowshead" 28 18 8 +"Cruise" 181 236 223 +"Crusoe" 0 72 22 +"Crusta" 253 123 51 +"Cuban Tan" 42 20 14 +"Cumin" 146 67 33 +"Cumulus" 253 255 213 +"Cupid" 251 190 218 +"Curious Blue" 37 150 209 +"Cutty Sark" 80 118 114 +"Cyprus" 0 62 64 +"Daintree" 1 39 49 +"Dairy Cream" 249 228 188 +"Daisy Bush" 79 35 152 +"Dallas" 110 75 38 +"Danube" 96 147 209 +"Dark Ebony" 60 32 5 +"Dark Oak" 97 39 24 +"Dark Rimu" 95 61 38 +"Dark Rum" 65 32 16 +"Dark Slate" 57 72 81 +"Dark Tan" 102 16 16 +"Dawn" 166 162 154 +"Dawn Pink" 243 233 229 +"De York" 122 196 136 +"Deco" 210 218 151 +"Deep Blush" 228 118 152 +"Deep Bronze" 74 48 4 +"Deep Cove" 5 16 64 +"Deep Fir" 0 41 0 +"Deep Koamaru" 27 18 123 +"Deep Oak" 65 32 16 +"Deep Sea" 1 130 107 +"Deep Teal" 0 53 50 +"Del Rio" 176 154 149 +"Dell" 57 100 19 +"Delta" 164 164 157 +"Deluge" 117 99 168 +"Derby" 255 238 216 +"Desert" 174 96 32 +"Desert Storm" 248 248 247 +"Dew" 234 255 254 +"Di Serria" 219 153 94 +"Diesel" 19 0 0 +"Dingley" 93 119 71 +"Disco" 135 21 80 +"Dixie" 226 148 24 +"Dolly" 249 255 139 +"Dolphin" 100 96 119 +"Domino" 142 119 94 +"Don Juan" 93 76 81 +"Donkey Brown" 166 146 121 +"Dorado" 107 87 85 +"Double Colonial White" 238 227 173 +"Double Pearl Lusta" 252 244 208 +"Double Spanish White" 230 215 185 +"Dove Grey" 109 108 108 +"Downriver" 9 34 86 +"Downy" 111 208 197 +"Driftwood" 175 135 81 +"Drover" 253 247 173 +"Dune" 56 53 51 +"Dust Storm" 229 204 201 +"Dusty Grey" 168 152 155 +"Dutch White" 255 248 209 +"Eagle" 182 186 164 +"Earls Green" 201 185 59 +"Early Dawn" 255 249 230 +"East Bay" 65 76 125 +"East Side" 172 145 206 +"Eastern Blue" 30 154 176 +"Ebb" 233 227 227 +"Ebony" 12 11 29 +"Ebony Clay" 38 40 59 +"Echo Blue" 175 189 217 +"Eclipse" 49 28 23 +"Ecru White" 245 243 229 +"Ecstasy" 250 120 20 +"Eden" 16 88 82 +"Edgewater" 200 227 215 +"Edward" 162 174 171 +"Egg Sour" 255 244 221 +"Egg White" 255 239 193 +"El Paso" 30 23 8 +"El Salva" 143 62 51 +"Elephant" 18 52 71 +"Elf Green" 8 131 112 +"Elm" 28 124 125 +"Embers" 160 39 18 +"Eminence" 108 48 130 +"Emperor" 81 70 73 +"Empress" 129 115 119 +"Endeavour" 0 86 167 +"Energy Yellow" 248 221 92 +"English Holly" 2 45 21 +"English Walnut" 62 43 35 +"Envy" 139 166 144 +"Equator" 225 188 100 +"Espresso" 97 39 24 +"Eternity" 33 26 14 +"Eucalyptus" 39 138 91 +"Eunry" 207 163 157 +"Evening Sea" 2 78 70 +"Everglade" 28 64 46 +"Fair Pink" 255 239 236 +"Falcon" 127 98 109 +"Fantasy" 250 243 240 +"Fedora" 121 106 120 +"Feijoa" 159 221 140 +"Fern" 10 72 13 +"Fern Frond" 101 114 32 +"Ferra" 112 79 80 +"Festival" 251 233 108 +"Feta" 240 252 234 +"Fiery Orange" 179 82 19 +"Fiji Green" 101 114 32 +"Finch" 98 102 73 +"Finlandia" 85 109 86 +"Finn" 105 45 84 +"Fiord" 64 81 105 +"Fire" 170 66 3 +"Fire Bush" 232 153 40 +"Firefly" 14 42 48 +"Flame Pea" 218 91 56 +"Flame Red" 199 3 30 +"Flamenco" 255 125 7 +"Flamingo" 242 85 42 +"Flax" 123 130 101 +"Flint" 111 106 97 +"Flirt" 162 0 109 +"Foam" 216 252 250 +"Fog" 215 208 255 +"Foggy Grey" 203 202 182 +"Forest Green" 24 45 9 +"Forget Me Not" 255 241 238 +"Fountain Blue" 86 180 190 +"Frangipani" 255 222 179 +"French Grey" 189 189 198 +"French Lilac" 236 199 238 +"French Pass" 189 237 253 +"Friar Grey" 128 126 121 +"Fringy Flower" 177 226 193 +"Froly" 245 117 132 +"Frost" 237 245 221 +"Frosted Mint" 219 255 248 +"Frostee" 228 246 231 +"Fruit Salad" 79 157 93 +"Fuchsia" 122 88 193 +"Fuego" 190 222 13 +"Fuel Yellow" 236 169 39 +"Fun Blue" 25 89 168 +"Fun Green" 1 109 57 +"Fuscous Grey" 84 83 77 +"Gable Green" 22 53 49 +"Gallery" 239 239 239 +"Galliano" 220 178 12 +"Geebung" 209 143 27 +"Genoa" 21 115 107 +"Geraldine" 251 137 137 +"Geyser" 212 223 226 +"Ghost" 199 201 213 +"Gigas" 82 60 148 +"Gimblet" 184 181 106 +"Gin" 232 242 235 +"Gin Fizz" 255 249 226 +"Givry" 248 228 191 +"Glacier" 128 179 196 +"Glade Green" 97 132 95 +"Go Ben" 114 109 78 +"Goblin" 61 125 82 +"Gold Drop" 241 130 0 +"Gold Tips" 222 186 19 +"Golden Bell" 226 137 19 +"Golden Dream" 240 213 45 +"Golden Fizz" 245 251 61 +"Golden Glow" 253 226 149 +"Golden Sand" 240 219 125 +"Golden Tainoi" 255 204 92 +"Gondola" 38 20 20 +"Gordons Green" 11 17 7 +"Gorse" 255 241 79 +"Gossamer" 6 155 129 +"Gossip" 210 248 176 +"Gothic" 109 146 161 +"Governor Bay" 47 60 179 +"Grain Brown" 228 213 183 +"Grandis" 255 211 140 +"Granite Green" 141 137 116 +"Granny Apple" 213 246 227 +"Granny Smith" 132 160 160 +"Grape" 56 26 81 +"Graphite" 37 22 7 +"Grass Hopper" 124 118 49 +"Gravel" 74 68 75 +"Green House" 36 80 15 +"Green Kelp" 37 49 28 +"Green Leaf" 67 106 13 +"Green Mist" 203 211 176 +"Green Pea" 29 97 66 +"Green Smoke" 164 175 110 +"Green Spring" 184 193 177 +"Green Vogue" 3 43 82 +"Green Waterloo" 16 20 5 +"Green White" 232 235 224 +"Greenstone" 0 62 64 +"Grenadier" 213 70 0 +"Grey Chateau" 162 170 179 +"Grey Green" 69 73 54 +"Grey Nickel" 195 195 189 +"Grey Nurse" 231 236 230 +"Grey Olive" 169 164 145 +"Grey Suit" 193 190 205 +"Guardsman Red" 186 1 1 +"Gulf Blue" 5 22 87 +"Gulf Stream" 128 179 174 +"Gull Grey" 157 172 183 +"Gum Leaf" 182 211 191 +"Gumbo" 124 161 166 +"Gun Powder" 65 66 87 +"Gunmetal" 2 13 21 +"Gunsmoke" 130 134 133 +"Gurkha" 154 149 119 +"Hacienda" 152 129 27 +"Hairy Heath" 107 42 20 +"Haiti" 27 16 53 +"Half and Half" 255 254 225 +"Half Baked" 133 196 204 +"Half Colonial White" 253 246 211 +"Half Dutch White" 254 247 222 +"Half Pearl Lusta" 255 252 234 +"Half Spanish White" 254 244 219 +"Hampton" 229 216 175 +"Harp" 230 242 234 +"Harvest Gold" 224 185 116 +"Havana" 52 21 21 +"Havelock Blue" 85 144 217 +"Hawaiian Tan" 157 86 22 +"Hawkes Blue" 212 226 252 +"Heath" 84 16 18 +"Heather" 183 195 208 +"Heathered Grey" 182 176 149 +"Heavy Metal" 43 50 40 +"Hemlock" 94 93 59 +"Hemp" 144 120 116 +"Hibiscus" 182 49 108 +"Highball" 144 141 57 +"Highland" 111 142 99 +"Hillary" 172 165 134 +"Himalaya" 106 93 27 +"Hint of Green" 230 255 233 +"Hint of Grey" 252 255 249 +"Hint of Red" 249 249 249 +"Hint of Yellow" 250 253 228 +"Hippie Blue" 88 154 175 +"Hippie Green" 83 130 75 +"Hippie Pink" 174 69 96 +"Hit Grey" 161 173 181 +"Hit Pink" 255 171 129 +"Hokey Pokey" 200 165 40 +"Hoki" 101 134 159 +"Holly" 1 29 19 +"Honey Flower" 79 28 112 +"Honeysuckle" 237 252 132 +"Hopbush" 208 109 161 +"Horizon" 90 135 160 +"Horses Neck" 96 73 19 +"Hot Chile" 139 7 35 +"Hot Curry" 136 98 33 +"Hot Purple" 72 6 86 +"Hot Toddy" 179 128 7 +"Humming Bird" 207 249 243 +"Hunter Green" 22 29 16 +"Hurricane" 135 124 123 +"Husk" 183 164 88 +"Ice Cold" 177 244 231 +"Iceberg" 218 244 240 +"Illusion" 246 164 201 +"Indian Tan" 77 30 1 +"Indochine" 194 107 3 +"Irish Coffee" 95 61 38 +"Iroko" 67 49 32 +"Iron" 212 215 217 +"Ironbark" 65 31 16 +"Ironside Grey" 103 102 98 +"Ironstone" 134 72 60 +"Island Spice" 255 252 238 +"Jacaranda" 46 3 41 +"Jacarta" 58 42 106 +"Jacko Bean" 46 25 5 +"Jacksons Purple" 32 32 141 +"Jade" 66 121 119 +"Jaffa" 239 134 63 +"Jagged Ice" 194 232 229 +"Jagger" 53 14 87 +"Jaguar" 8 1 16 +"Jambalaya" 91 48 19 +"Janna" 244 235 211 +"Japanese Laurel" 10 105 6 +"Japanese Maple" 120 1 9 +"Japonica" 216 124 99 +"Jarrah" 52 21 21 +"Java" 31 194 194 +"Jazz" 120 1 9 +"Jelly Bean" 41 123 154 +"Jet Stream" 181 210 206 +"Jewel" 18 107 64 +"Joanna" 245 243 229 +"Jon" 59 31 31 +"Jonquil" 238 255 154 +"Jordy Blue" 138 185 241 +"Judge Grey" 84 67 51 +"Jumbo" 124 123 130 +"Jungle Green" 40 30 21 +"Jungle Mist" 180 207 211 +"Juniper" 109 146 146 +"Just Right" 236 205 185 +"Kabul" 94 72 62 +"Kaitoke Green" 0 70 32 +"Kangaroo" 198 200 189 +"Karaka" 30 22 9 +"Karry" 255 234 212 +"Kashmir Blue" 80 112 150 +"Kelp" 69 73 54 +"Kenyan Copper" 124 28 5 +"Keppel" 58 176 158 +"Kidnapper" 225 234 212 +"Kilamanjaro" 36 12 2 +"Killarney" 58 106 71 +"Kimberly" 115 108 159 +"Kingfisher Daisy" 62 4 128 +"Kobi" 231 159 196 +"Kokoda" 110 109 87 +"Korma" 143 75 14 +"Koromiko" 255 189 95 +"Kournikova" 255 231 114 +"Kumera" 136 98 33 +"La Palma" 54 135 22 +"La Rioja" 179 193 16 +"Las Palmas" 198 230 16 +"Laser" 200 181 104 +"Laurel" 116 147 120 +"Lavender" 168 153 230 +"Leather" 150 112 89 +"Lemon" 244 216 28 +"Lemon Ginger" 172 158 34 +"Lemon Grass" 155 158 143 +"Licorice" 9 34 86 +"Lightning Yellow" 252 192 30 +"Lilac Bush" 152 116 211 +"Lily" 200 170 191 +"Lily White" 231 248 255 +"Lima" 118 189 23 +"Lime" 191 201 33 +"Limeade" 111 157 2 +"Limed Ash" 116 125 99 +"Limed Gum" 66 57 33 +"Limed Oak" 172 138 86 +"Limed Spruce" 57 72 81 +"Limerick" 157 194 9 +"Linen" 230 228 212 +"Link Water" 217 228 245 +"Lipstick" 171 5 99 +"Lisbon Brown" 66 57 33 +"Livid Brown" 77 40 46 +"Loafer" 238 244 222 +"Loblolly" 189 201 206 +"Lochinvar" 44 140 132 +"Lochmara" 0 126 199 +"Locust" 168 175 142 +"Log Cabin" 36 42 29 +"Logan" 170 169 205 +"Lola" 223 207 219 +"London Hue" 190 166 195 +"Lonestar" 109 1 1 +"Lotus" 134 60 60 +"Loulou" 70 11 65 +"Lucky" 175 159 28 +"Lucky Point" 26 26 104 +"Lunar Green" 60 73 58 +"Lusty" 153 27 7 +"Luxor Gold" 167 136 44 +"Lynch" 105 126 154 +"Mabel" 217 247 255 +"Madang" 183 240 190 +"Madison" 9 37 93 +"Madras" 63 48 2 +"Magnolia" 248 244 255 +"Mahogany" 78 6 6 +"Mai Tai" 176 102 8 +"Maire" 19 10 6 +"Maize" 245 213 160 +"Makara" 137 125 109 +"Mako" 68 73 84 +"Malachite Green" 136 141 101 +"Malibu" 125 200 247 +"Mallard" 35 52 24 +"Malta" 189 178 161 +"Mamba" 142 129 144 +"Mandalay" 173 120 27 +"Mandy" 226 84 101 +"Mandys Pink" 242 195 178 +"Manhattan" 245 201 153 +"Mantis" 116 195 101 +"Mantle" 139 156 144 +"Manz" 238 239 120 +"Mardi Gras" 53 0 54 +"Marigold" 185 141 40 +"Mariner" 40 106 205 +"Marlin" 42 20 14 +"Maroon" 66 3 3 +"Marshland" 11 15 8 +"Martini" 175 160 158 +"Martinique" 54 48 80 +"Marzipan" 248 219 157 +"Masala" 64 59 56 +"Mash" 64 41 29 +"Matisse" 27 101 157 +"Matrix" 176 93 84 +"Matterhorn" 78 59 65 +"Maverick" 216 194 213 +"McKenzie" 175 135 81 +"Melanie" 228 194 213 +"Melanzane" 48 5 41 +"Melrose" 199 193 255 +"Meranti" 93 30 15 +"Mercury" 229 229 229 +"Merino" 246 240 230 +"Merlin" 65 60 55 +"Merlot" 131 25 35 +"Metallic Bronze" 73 55 27 +"Metallic Copper" 113 41 29 +"Meteor" 208 125 18 +"Meteorite" 60 31 118 +"Mexican Red" 167 37 37 +"Mid Grey" 95 95 110 +"Midnight" 1 22 53 +"Midnight Express" 0 7 65 +"Midnight Moss" 4 16 4 +"Mikado" 45 37 16 +"Milan" 250 255 164 +"Milano Red" 184 17 4 +"Milk Punch" 255 246 212 +"Milk White" 246 240 230 +"Millbrook" 89 68 51 +"Mimosa" 248 253 211 +"Mindaro" 227 249 136 +"Mine Shaft" 50 50 50 +"Mineral Green" 63 93 83 +"Ming" 54 116 125 +"Minsk" 63 48 127 +"Mint Julep" 241 238 193 +"Mint Tulip" 196 244 235 +"Mirage" 22 25 40 +"Mischka" 209 210 221 +"Mist Grey" 196 196 188 +"Mobster" 127 117 137 +"Moccaccino" 110 29 20 +"Mocha" 120 45 25 +"Mojo" 192 71 55 +"Mona Lisa" 255 161 148 +"Monarch" 139 7 35 +"Mondo" 74 60 48 +"Mongoose" 181 162 127 +"Monsoon" 138 131 137 +"Montana" 41 30 48 +"Monte Carlo" 131 208 198 +"Monza" 199 3 30 +"Moody Blue" 127 118 211 +"Moon Glow" 252 254 218 +"Moon Mist" 220 221 204 +"Moon Raker" 214 206 246 +"Moon Yellow" 252 217 23 +"Morning Glory" 158 222 224 +"Morocco Brown" 68 29 0 +"Mortar" 80 67 81 +"Mosaic" 18 52 71 +"Mosque" 3 106 110 +"Mountain Mist" 149 147 150 +"Muddy Waters" 183 142 92 +"Muesli" 170 139 91 +"Mulberry" 92 5 54 +"Mule Fawn" 140 71 47 +"Mulled Wine" 78 69 98 +"Mustard" 116 100 13 +"My Pink" 214 145 136 +"My Sin" 255 179 31 +"Mystic" 226 235 237 +"Nandor" 75 93 82 +"Napa" 172 164 148 +"Narvik" 237 249 241 +"Natural" 134 86 10 +"Nebula" 203 219 214 +"Negroni" 255 226 197 +"Nepal" 142 171 193 +"Neptune" 124 183 187 +"Nero" 20 6 0 +"Neutral Green" 172 165 134 +"Nevada" 100 110 117 +"New Amber" 123 56 1 +"New Orleans" 243 214 157 +"New York Pink" 215 131 127 +"Niagara" 6 161 137 +"Night Rider" 31 18 15 +"Night Shadz" 170 55 90 +"Nightclub" 102 0 69 +"Nile Blue" 25 55 81 +"Nobel" 183 177 177 +"Nomad" 186 177 162 +"Nordic" 1 39 49 +"Norway" 168 189 159 +"Nugget" 197 153 34 +"Nutmeg" 129 66 44 +"Nutmeg Wood Finish" 104 54 0 +"Oasis" 254 239 206 +"Observatory" 2 134 111 +"Ocean Green" 65 170 120 +"Off Green" 230 248 243 +"Off Yellow" 254 249 227 +"Oil" 40 30 21 +"Oiled Cedar" 124 28 5 +"Old Brick" 144 30 30 +"Old Copper" 114 74 47 +"Olive Green" 36 46 22 +"Olive Haze" 139 132 112 +"Olivetone" 113 110 16 +"Onahau" 205 244 255 +"Onion" 47 39 14 +"Opal" 169 198 194 +"Opium" 142 111 112 +"Oracle" 55 116 117 +"Orange Roughy" 196 87 25 +"Orange White" 254 252 237 +"Orchid White" 255 253 243 +"Oregon" 155 71 3 +"Orient" 1 94 133 +"Oriental Pink" 198 145 145 +"Orinoco" 243 251 212 +"Oslo Grey" 135 141 145 +"Ottoman" 233 248 237 +"Outer Space" 5 16 64 +"Oxford Blue" 56 69 85 +"Oxley" 119 158 134 +"Oyster Bay" 218 250 255 +"Oyster Pink" 233 206 205 +"Paarl" 166 85 41 +"Pablo" 119 111 97 +"Pacifika" 119 129 32 +"Paco" 65 31 16 +"Padua" 173 230 196 +"Pale Leaf" 192 211 185 +"Pale Oyster" 152 141 119 +"Pale Prim" 253 254 184 +"Pale Rose" 255 225 242 +"Pale Sky" 110 119 131 +"Pale Slate" 195 191 193 +"Palm Green" 9 35 15 +"Palm Leaf" 25 51 14 +"Pampas" 244 242 238 +"Panache" 234 246 238 +"Pancho" 237 205 171 +"Panda" 66 57 33 +"Paprika" 141 2 38 +"Paradiso" 49 125 130 +"Parchment" 241 233 210 +"Paris Daisy" 255 244 110 +"Paris M" 38 5 106 +"Paris White" 202 220 212 +"Parsley" 19 79 25 +"Patina" 99 154 143 +"Pattens Blue" 222 245 255 +"Paua" 38 3 104 +"Pavlova" 215 196 152 +"Pea Soup" 207 229 210 +"Peach" 255 240 219 +"Peach Schnapps" 255 220 214 +"Peanut" 120 47 22 +"Pearl Bush" 232 224 213 +"Pearl Lusta" 252 244 220 +"Peat" 113 107 86 +"Pelorous" 62 171 191 +"Peppermint" 227 245 225 +"Perano" 169 190 242 +"Perfume" 208 190 248 +"Periglacial Blue" 225 230 214 +"Persian Plum" 112 28 28 +"Persian Red" 82 12 23 +"Persimmon" 255 107 83 +"Peru Tan" 127 58 2 +"Pesto" 124 118 49 +"Petite Orchid" 219 150 144 +"Pewter" 150 168 161 +"Pharlap" 163 128 123 +"Picasso" 255 243 157 +"Pickled Aspen" 63 76 58 +"Pickled Bean" 110 72 38 +"Pickled Bluewood" 49 68 89 +"Picton Blue" 69 177 232 +"Pigeon Post" 175 189 217 +"Pine Cone" 109 94 84 +"Pine Glade" 199 205 144 +"Pine Tree" 23 31 4 +"Pink Flare" 225 192 200 +"Pink Lace" 255 221 244 +"Pink Lady" 255 241 216 +"Pink Swan" 190 181 183 +"Piper" 201 99 35 +"Pipi" 254 244 204 +"Pippin" 255 225 223 +"Pirate Gold" 186 127 3 +"Pistachio" 157 194 9 +"Pixie Green" 192 216 182 +"Pizazz" 255 144 0 +"Pizza" 201 148 21 +"Plantation" 39 80 75 +"Planter" 97 93 48 +"Plum" 65 0 86 +"Pohutukawa" 143 2 28 +"Polar" 229 249 246 +"Polo Blue" 141 168 204 +"Pompadour" 102 0 69 +"Porcelain" 239 242 243 +"Porsche" 234 174 105 +"Port Gore" 37 31 79 +"Portafino" 255 255 180 +"Portage" 139 159 238 +"Portica" 249 230 99 +"Pot Pourri" 245 231 226 +"Potters Clay" 140 87 56 +"Powder Blue" 188 201 194 +"Prairie Sand" 154 56 32 +"Prelude" 208 192 229 +"Prim" 240 226 236 +"Primrose" 237 234 153 +"Promenade" 252 255 231 +"Provincial Pink" 254 245 241 +"Prussian Blue" 0 49 83 +"Pueblo" 125 44 20 +"Puerto Rico" 63 193 170 +"Pumice" 194 202 196 +"Pumpkin" 177 97 11 +"Punch" 220 67 51 +"Punga" 77 61 20 +"Putty" 231 205 140 +"Quarter Pearl Lusta" 255 253 244 +"Quarter Spanish White" 247 242 225 +"Quicksand" 189 151 142 +"Quill Grey" 214 214 209 +"Quincy" 98 63 45 +"Racing Green" 12 25 17 +"Raffia" 234 218 184 +"Rain Forest" 119 129 32 +"Raincloud" 123 124 148 +"Rainee" 185 200 172 +"Rajah" 247 182 104 +"Rangitoto" 46 50 34 +"Rangoon Green" 28 30 19 +"Raven" 114 123 137 +"Rebel" 60 18 6 +"Red Beech" 123 56 1 +"Red Berry" 142 0 0 +"Red Damask" 218 106 65 +"Red Devil" 134 1 17 +"Red Oxide" 110 9 2 +"Red Robin" 128 52 31 +"Red Stage" 208 95 4 +"Redwood" 93 30 15 +"Reef" 201 255 162 +"Reef Gold" 159 130 28 +"Regal Blue" 1 63 106 +"Regent Grey" 134 148 159 +"Regent St Blue" 170 214 230 +"Remy" 254 235 243 +"Reno Sand" 168 101 21 +"Resolution Blue" 0 35 135 +"Revolver" 44 22 50 +"Rhino" 46 63 98 +"Ribbon" 102 0 69 +"Rice Cake" 255 254 240 +"Rice Flower" 238 255 226 +"Rich Gold" 168 83 7 +"Rio Grande" 187 208 9 +"Riptide" 139 230 216 +"River Bed" 67 76 89 +"Rob Roy" 234 198 116 +"Robins Egg Blue" 189 200 179 +"Rock" 77 56 51 +"Rock Blue" 158 177 205 +"Rock Salt" 255 255 255 +"Rock Spray" 186 69 12 +"Rodeo Dust" 201 178 155 +"Rolling Stone" 116 125 131 +"Roman" 222 99 96 +"Roman Coffee" 121 93 76 +"Romance" 255 254 253 +"Romantic" 255 210 183 +"Ronchi" 236 197 78 +"Roof Terracotta" 166 47 32 +"Rope" 142 77 30 +"Rose" 231 188 180 +"Rose Bud" 251 178 163 +"Rose Bud Cherry" 128 11 71 +"Rose of Sharon" 191 85 0 +"Rose White" 255 246 245 +"Rosewood" 101 0 11 +"Roti" 198 168 75 +"Rouge" 162 59 108 +"Royal Heath" 171 52 114 +"Rum" 121 105 137 +"Rum Swizzle" 249 248 228 +"Russett" 117 90 87 +"Rustic Red" 72 4 4 +"Rusty Nail" 134 86 10 +"Saddle" 76 48 36 +"Saddle Brown" 88 52 1 +"Saffron" 249 191 88 +"Sage" 158 165 135 +"Sahara" 183 162 20 +"Sail" 184 224 249 +"Salem" 9 127 75 +"Salomie" 254 219 141 +"Salt Box" 104 94 110 +"Saltpan" 241 247 242 +"Sambuca" 58 32 16 +"San Felix" 11 98 7 +"San Juan" 48 75 106 +"San Marino" 69 108 172 +"Sand Dune" 130 111 101 +"Sandal" 170 141 111 +"Sandrift" 171 145 122 +"Sandstone" 121 109 98 +"Sandwisp" 245 231 162 +"Sandy Beach" 255 234 200 +"Sangria" 146 0 10 +"Sanguine Brown" 141 61 56 +"Santa Fe" 177 109 82 +"Santas Grey" 159 160 177 +"Sapling" 222 212 164 +"Sapphire" 47 81 158 +"Saratoga" 85 91 16 +"Sauvignon" 255 245 243 +"Sazerac" 255 244 224 +"Scampi" 103 95 166 +"Scandal" 207 250 244 +"Scarlet Gum" 67 21 96 +"Scarlett" 149 0 21 +"Scarpa Flow" 88 85 98 +"Schist" 169 180 151 +"Schooner" 139 132 126 +"Scooter" 46 191 212 +"Scorpion" 105 95 98 +"Scotch Mist" 255 251 220 +"Scrub" 46 50 34 +"Sea Buckthorn" 251 161 41 +"Sea Fog" 252 255 249 +"Sea Green" 9 88 89 +"Sea Mist" 197 219 202 +"Sea Nymph" 120 163 156 +"Sea Pink" 237 152 158 +"Seagull" 128 204 234 +"Seance" 115 30 143 +"Seashell" 241 241 241 +"Seaweed" 27 47 17 +"Selago" 240 238 253 +"Sepia" 43 2 2 +"Serenade" 255 244 232 +"Shadow Green" 154 194 184 +"Shady Lady" 170 165 169 +"Shakespeare" 78 171 209 +"Shalimar" 251 255 186 +"Shark" 37 39 44 +"Sherpa Blue" 0 73 80 +"Sherwood Green" 2 64 44 +"Shilo" 232 185 179 +"Shingle Fawn" 107 78 49 +"Ship Cove" 120 139 186 +"Ship Grey" 62 58 68 +"Shiraz" 178 9 49 +"Shocking" 226 146 192 +"Shuttle Grey" 95 102 114 +"Siam" 100 106 84 +"Sidecar" 243 231 187 +"Silk" 189 177 168 +"Silver Chalice" 172 172 172 +"Silver Sand" 191 193 194 +"Silver Tree" 102 181 143 +"Sinbad" 159 215 211 +"Siren" 122 1 58 +"Sirocco" 113 128 128 +"Sisal" 211 203 186 +"Skeptic" 202 230 218 +"Slugger" 65 32 16 +"Smalt Blue" 81 128 143 +"Smoke Tree" 218 99 4 +"Smokey Ash" 65 60 55 +"Smoky" 96 91 115 +"Snow Drift" 247 250 247 +"Snow Flurry" 228 255 209 +"Snowy Mint" 214 255 219 +"Snuff" 226 216 237 +"Soapstone" 255 251 249 +"Soft Amber" 209 198 180 +"Soft Peach" 245 237 239 +"Solid Pink" 137 56 67 +"Solitaire" 254 248 226 +"Solitude" 234 246 255 +"Sorbus" 253 124 7 +"Sorrell Brown" 206 185 143 +"Sour Dough" 209 190 168 +"Soya Bean" 106 96 81 +"Space Shuttle" 67 49 32 +"Spanish Green" 129 152 133 +"Spanish White" 244 235 211 +"Spectra" 47 90 87 +"Spice" 106 68 46 +"Spicy Mix" 136 83 66 +"Spicy Pink" 129 110 113 +"Spindle" 182 209 234 +"Splash" 255 239 193 +"Spray" 121 222 236 +"Spring Green" 87 131 99 +"Spring Rain" 172 203 177 +"Spring Sun" 246 255 220 +"Spring Wood" 248 246 241 +"Sprout" 193 215 176 +"Spun Pearl" 170 171 183 +"Squirrel" 143 129 118 +"St Tropaz" 45 86 155 +"Stack" 138 143 138 +"Star Dust" 159 159 156 +"Stark White" 229 215 189 +"Starship" 236 242 69 +"Steel Grey" 38 35 53 +"Stiletto" 156 51 54 +"Stinger" 139 107 11 +"Stonewall" 146 133 115 +"Storm Dust" 100 100 99 +"Storm Grey" 113 116 134 +"Stratos" 0 7 65 +"Straw" 212 191 141 +"Strikemaster" 149 99 135 +"Stromboli" 50 93 82 +"Studio" 113 74 178 +"Submarine" 186 199 201 +"Sugar Cane" 249 255 246 +"Sulu" 193 240 124 +"Summer Green" 150 187 171 +"Sun" 251 172 19 +"Sundance" 201 179 91 +"Sundown" 255 177 179 +"Sunflower" 228 212 34 +"Sunglo" 225 104 101 +"Sunset" 220 67 51 +"Sunshade" 255 158 44 +"Supernova" 255 201 1 +"Surf" 187 215 193 +"Surf Crest" 207 229 210 +"Surfie Green" 12 122 121 +"Sushi" 135 171 57 +"Suva Grey" 136 131 135 +"Swamp" 0 27 28 +"Swans Down" 220 240 234 +"Sweet Corn" 251 234 140 +"Sweet Pink" 253 159 162 +"Swirl" 211 205 197 +"Swiss Coffee" 221 214 213 +"Sycamore" 144 141 57 +"Tabasco" 160 39 18 +"Tacao" 237 179 129 +"Tacha" 214 197 98 +"Tahiti Gold" 233 124 7 +"Tahuna Sands" 238 240 200 +"Tall Poppy" 179 45 41 +"Tallow" 168 165 137 +"Tamarillo" 153 22 19 +"Tamarind" 52 21 21 +"Tana" 217 220 193 +"Tangaroa" 3 22 60 +"Tangerine" 233 110 0 +"Tango" 237 122 28 +"Tapa" 123 120 116 +"Tapestry" 176 94 129 +"Tara" 225 246 232 +"Tarawera" 7 58 80 +"Tasman" 207 220 207 +"Taupe Grey" 179 175 149 +"Tawny Port" 105 37 69 +"Tax Break" 81 128 143 +"Te Papa Green" 30 67 60 +"Tea" 193 186 176 +"Teak" 177 148 97 +"Teak Wood Finish" 107 42 20 +"Teal Blue" 4 66 89 +"Temptress" 59 0 11 +"Tequila" 255 230 199 +"Texas" 248 249 156 +"Texas Rose" 255 181 85 +"Thatch" 182 157 152 +"Thatch Green" 64 61 25 +"Thistle" 204 202 168 +"Thunder" 51 41 47 +"Thunderbird" 192 43 24 +"Tia Maria" 193 68 14 +"Tiara" 195 209 209 +"Tiber" 6 53 55 +"Tidal" 241 255 173 +"Tide" 191 184 176 +"Timber Green" 22 50 44 +"Titan White" 240 238 255 +"Toast" 154 110 97 +"Tobacco Brown" 113 93 71 +"Tobago" 62 43 35 +"Toledo" 58 0 32 +"Tolopea" 27 2 69 +"Tom Thumb" 63 88 59 +"Tonys Pink" 231 159 140 +"Topaz" 124 119 138 +"Torea Bay" 15 45 158 +"Tory Blue" 20 80 170 +"Tosca" 141 63 63 +"Totem Pole" 153 27 7 +"Touch Wood" 55 48 33 +"Tower Grey" 169 189 191 +"Tradewind" 95 179 172 +"Tranquil" 230 255 255 +"Travertine" 255 253 232 +"Tree Poppy" 252 156 29 +"Treehouse" 59 40 32 +"Trendy Green" 124 136 26 +"Trendy Pink" 140 100 149 +"Trinidad" 230 78 3 +"Tropical Blue" 195 221 249 +"Trout" 74 78 90 +"True V" 138 115 214 +"Tuatara" 54 53 52 +"Tuft Bush" 255 221 205 +"Tulip Tree" 234 179 59 +"Tumbleweed" 55 41 14 +"Tuna" 53 53 66 +"Tundora" 74 66 68 +"Turbo" 250 230 0 +"Turkish Rose" 181 114 129 +"Turmeric" 202 187 72 +"Turtle Green" 42 56 11 +"Tuscany" 189 94 46 +"Tusk" 238 243 195 +"Tussock" 197 153 75 +"Tutu" 255 241 249 +"Twilight" 228 207 222 +"Twilight Blue" 238 253 255 +"Twine" 194 149 93 +"Valencia" 216 68 55 +"Valentino" 53 14 66 +"Valhalla" 43 25 79 +"Van Cleef" 73 23 12 +"Vanilla" 209 190 168 +"Vanilla Ice" 243 217 223 +"Varden" 255 246 223 +"Venetian Red" 114 1 15 +"Venice Blue" 5 89 137 +"Venus" 146 133 144 +"Verdigris" 93 94 55 +"Verdun Green" 73 84 0 +"Vesuvius" 177 74 11 +"Victoria" 83 68 145 +"Vida Loca" 84 144 25 +"Viking" 100 204 219 +"Vin Rouge" 152 61 97 +"Viola" 203 143 169 +"Violent Violet" 41 12 94 +"Violet" 36 10 64 +"Viridian Green" 103 137 117 +"Vis Vis" 255 239 161 +"Vista Blue" 143 214 180 +"Vista White" 252 248 247 +"Volcano" 101 26 20 +"Voodoo" 83 52 85 +"Vulcan" 16 18 29 +"Wafer" 222 203 198 +"Waikawa Grey" 90 110 156 +"Waiouru" 54 60 13 +"Walnut" 119 63 26 +"Wan White" 252 255 249 +"Wasabi" 120 138 37 +"Water Leaf" 161 233 222 +"Watercourse" 5 111 87 +"Waterloo " 123 124 148 +"Wattle" 220 215 71 +"Watusi" 255 221 207 +"Wax Flower" 255 192 168 +"We Peep" 247 219 230 +"Wedgewood" 78 127 158 +"Well Read" 180 51 50 +"West Coast" 98 81 25 +"West Side" 255 145 15 +"Westar" 220 217 210 +"Western Red" 139 7 35 +"Wewak" 241 155 171 +"Wheatfield" 243 237 207 +"Whiskey" 213 154 111 +"Whiskey Sour" 219 153 94 +"Whisper" 247 245 250 +"White Ice" 221 249 241 +"White Lilac" 248 247 252 +"White Linen" 248 240 232 +"White Nectar" 252 255 231 +"White Pointer" 254 248 255 +"White Rock" 234 232 212 +"Wild Rice" 236 224 144 +"Wild Sand" 244 244 244 +"Wild Willow" 185 196 106 +"William" 58 104 108 +"Willow Brook" 223 236 218 +"Willow Grove" 101 116 93 +"Windsor" 60 8 120 +"Wine Berry" 89 29 53 +"Winter Hazel" 213 209 149 +"Wisp Pink" 254 244 248 +"Wisteria" 151 113 181 +"Wistful" 164 166 211 +"Witch Haze" 255 252 153 +"Wood Bark" 38 17 5 +"Woodburn" 60 32 5 +"Woodland" 77 83 40 +"Woodrush" 48 42 15 +"Woodsmoke" 12 13 15 +"Woody Bay" 41 33 48 +"Woody Brown" 72 49 49 +"Xanadu" 115 134 120 +"Yellow Metal" 113 99 56 +"Yellow Sea" 254 169 4 +"Your Pink" 255 195 192 +"Yukon Gold" 123 102 8 +"Yuma" 206 194 145 +"Zambezi" 104 85 88 +"Zanah" 218 236 214 +"Zest" 229 132 27 +"Zeus" 41 35 25 +"Ziggurat" 191 219 226 +"Zircon" 244 248 255 +"Zombie" 228 214 155 +"Zorba" 165 155 145 +"Zuccini" 4 64 34 +"Zumthor" 237 246 255 +"Zydeco" 2 64 44 @@ -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,7 @@ ;;; D. E. Knuth, "The Art of Computer Programming", Vol 2 / ;;; Seminumerical Algorithms, Reading Massachusetts, Addison-Wesley ;;; Publishing Company, 2nd Edition, p. 510 - +;@ (define (newton:find-integer-root f df/dx x_0) (let loop ((x x_0) (fx (f x_0))) (cond @@ -40,12 +40,12 @@ (next-fx (f next-x))) (cond ((>= (abs next-fx) (abs fx)) x) (else (loop next-x next-fx))))))))))) - +;@ (define (integer-sqrt y) (newton:find-integer-root (lambda (x) (- (* x x) y)) (lambda (x) (* 2 x)) (ash 1 (quotient (integer-length y) 2)))) - +;@ (define (newton:find-root f df/dx x_0 prec) (if (and (negative? prec) (integer? prec)) (let loop ((x x_0) (fx (f x_0)) (count prec)) @@ -71,7 +71,7 @@ ;;; H. J. Orchard, "The Laguerre Method for Finding the Zeros of ;;; Polynomials", IEEE Transactions on Circuits and Systems, Vol. 36, ;;; No. 11, November 1989, pp 1377-1381. - +;@ (define (laguerre:find-root f df/dz ddf/dz^2 z_0 prec) (if (and (negative? prec) (integer? prec)) (let loop ((z z_0) (fz (f z_0)) (count prec)) @@ -114,7 +114,7 @@ ((and delta-z (>= next-delta-z delta-z)) z) (else (loop next-z (f next-z) next-delta-z))))))))))) - +;@ (define (laguerre:find-polynomial-root deg f df/dz ddf/dz^2 z_0 prec) (if (and (negative? prec) (integer? prec)) (let loop ((z z_0) (fz (f z_0)) (count prec)) @@ -210,7 +210,7 @@ (fnew (f xnew)) (fmax (max (abs f1) (abs fnew)))) (secant-iter x1 f1 xnew fnew (+ count 1))))))))))) - +;@ (define (secant:find-root f x0 x1 prec) (secant:find-root-1 f x0 x1 prec #f)) (define (secant:find-bracketed-root f x0 x1 prec) diff --git a/s48-0_57.init b/s48-0_57.init index 1654cca..672d559 100644 --- a/s48-0_57.init +++ b/s48-0_57.init @@ -33,23 +33,19 @@ ;;; (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) 'Scheme48) ;;; (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://s48.org/") ;;; (scheme-implementation-version) should return a string describing ;;; the version of the scheme implementation loading this file. - (define scheme-implementation-version (let ((version (getenv "S48_VERSION"))) (lambda () version))) @@ -57,14 +53,12 @@ ;;; (implementation-vicinity) should be defined to be the pathname of ;;; the directory where any auxiliary files to your Scheme ;;; implementation reside. - (define implementation-vicinity (let ((vic (getenv "S48_VICINITY"))) (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 ((vic (getenv "SCHEME_LIBRARY_PATH"))) (lambda () vic))) @@ -72,21 +66,20 @@ ;;; (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))) - -(let* ((siv (scheme-implementation-version)) - (num-ver (and siv (string->number siv)))) - (cond ((not num-ver)) - ((>= num-ver 0.54) - (set! system #f)))) +;;; +;;; Ivan Shmakov points out that evaluating (getenv "HOME") when +;;; compiling captures the installer's home directory. So delay until +;;; HOME-VICINITY is called. +(define (home-vicinity) + (let ((home (getenv "HOME"))) + (and home + (if (eqv? #\/ (string-ref home (+ -1 (string-length home)))) + home + (string-append 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 @@ -96,7 +89,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 @@ -110,11 +103,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!, @@ -125,7 +118,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 @@ -193,6 +186,37 @@ (s48-force-output (if (null? arg) (current-output-port) (car 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'"))) + ;;; "rationalize" adjunct procedures. (define (find-ratio x e) (let ((rat (rationalize x e))) @@ -221,11 +245,21 @@ (define (atan y . x) (if (null? x) (two-arg:atan y 1) (two-arg:atan y (car x)))) +;;; Workaround inexact->exact and exact->inexact bugs. +(define inexact->exact + (let ((i->e inexact->exact)) + (lambda (z) + (if (exact? z) z (i->e z))))) +(define exact->inexact + (let ((e->i exact->inexact)) + (lambda (z) + (if (inexact? z) z (e->i z))))) + ;;; MOST-POSITIVE-FIXNUM is used in modular.scm (define most-positive-fixnum #x1FFFFFFF) ;;; Return argument -(define (identity x) x) +(define identity values) ;;; SLIB:EVAL is single argument eval using the top-level (user) environment. (define slib:eval @@ -294,7 +328,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) @@ -331,17 +365,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 (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 load) ;;; At this point SLIB:LOAD must be able to load SLIB files. - (define slib:load slib:load-source) ;;; Scheme48 complains that these are not defined (even though they @@ -377,5 +408,5 @@ ,collect ,batch off -,dump slib.image "(slib 2d2)" +,dump slib.image "(slib 3a1)" ,exit diff --git a/saturate.txt b/saturate.txt new file mode 100644 index 0000000..63aa693 --- /dev/null +++ b/saturate.txt @@ -0,0 +1,39 @@ +;"saturate.txt" Saturated-Colors Dictionary. +;Copyright 2002 Aubrey Jaffer +; +;Permission to copy this dictionary, 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 dictionary must include this copyright notice +;in full. +; +;2. I have made no warranty or representation that this data is +;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. + +;Saturated colors from "Approximate Colors on CIE Chromaticity Diagram" + +"reddish orange" CIEXYZ:0.658471/0.341258/0.000271188 +"orange" CIEXYZ:0.602933/0.396497/0.000570581 +"yellowish orange" CIEXYZ:0.531897/0.467256/0.000847751 +"yellow" CIEXYZ:0.505818/0.493217/0.000965024 +"greenish yellow" CIEXYZ:0.465098/0.5338/0.00110199 +"yellow green" CIEXYZ:0.380466/0.617256/0.00227802 +"yellowish green" CIEXYZ:0.337396/0.658848/0.00375544 +"green" CIEXYZ:0.0388518/0.812016/0.149132 +"bluish green" CIEXYZ:0.00816803/0.538423/0.453409 +"blue green" CIEXYZ:0.0234599/0.412703/0.563837 +"greenish blue" CIEXYZ:0.0833989/0.156445/0.760156 +"blue" CIEXYZ:0.116102/0.0738583/0.81004 +"purplish blue" CIEXYZ:0.150985/0.0227402/0.826274 +"bluish purple" CIEXYZ:0.174724/0.00520914/0.820067 +"purple" CIEXYZ:0.180159/0.00770975/0.812132 +"reddish purple" CIEXYZ:0.195341/0.0146953/0.789964 +"red purple" CIEXYZ:0.224491/0.0281085/0.7474 +"purplish red" CIEXYZ:0.292779/0.0595298/0.647691 +"red" CIEXYZ:0.639974/0.219285/0.140741 @@ -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,29 +17,30 @@ ;promotional, or sales literature without prior written consent in ;each case. +;@ (define (substring-move-left! string1 start1 end1 string2 start2) (do ((i start1 (+ i 1)) (j start2 (+ j 1)) (l (- end1 start1) (- l 1))) ((<= l 0)) (string-set! string2 j (string-ref string1 i)))) - +;@ (define (substring-move-right! string1 start1 end1 string2 start2) (do ((i (+ start1 (- end1 start1) -1) (- i 1)) (j (+ start2 (- end1 start1) -1) (- j 1)) (l (- end1 start1) (- l 1))) ((<= l 0)) (string-set! string2 j (string-ref string1 i)))) - +;@ (define (substring-fill! string start end char) (do ((i start (+ i 1)) (l (- end start) (- l 1))) ((<= l 0)) (string-set! string i char))) - +;@ (define (string-null? str) (= 0 (string-length str))) - +;@ (define append! (lambda args (cond ((null? args) '()) @@ -51,14 +52,14 @@ (car args))))) ;;;; need to add code for OBJECT-HASH and OBJECT-UNHASH - +;@ (define 1+ (let ((+ +)) (lambda (n) (+ n 1)))) (define -1+ (let ((+ +)) (lambda (n) (+ n -1)))) - +;@ (define <? <) (define <=? <=) (define =? =) @@ -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,30 +23,31 @@ ;;; This code conforms to: William Clinger and Jonathan Rees, editors. ;;; Revised^4 Report on the Algorithmic Language Scheme. +;@ (define (list-tail l p) (if (< p 1) l (list-tail (cdr l) (- p 1)))) - +;@ (define (string->list s) (do ((i (- (string-length s) 1) (- i 1)) (l '() (cons (string-ref s i) l))) ((< i 0) l))) - +;@ (define (list->string l) (apply string l)) - +;@ (define string-copy string-append) - +;@ (define (string-fill! s obj) (do ((i (- (string-length s) 1) (- i 1))) ((< i 0)) (string-set! s i obj))) - +;@ (define (list->vector l) (apply vector l)) - +;@ (define (vector->list s) (do ((i (- (vector-length s) 1) (- i 1)) (l '() (cons (vector-ref s i) l))) ((< i 0) l))) - +;@ (define (vector-fill! s obj) (do ((i (- (vector-length s) 1) (- i 1))) ((< i 0)) @@ -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/scainit.scm b/scainit.scm index 93fed1e..dd779e9 100644 --- a/scainit.scm +++ b/scainit.scm @@ -18,7 +18,7 @@ ;;; 92/06/18 (require 'common-list-functions) ;to pick up EVERY -(define syncase:andmap comlist:every) +(define syncase:andmap every) ; In Chez Scheme "(syncase:void)" returns an object that is ignored by the ; REP loop. It is returned whenever a "nonspecified" value is specified @@ -67,33 +67,34 @@ (define impl-error slib:error) (define base:eval slib:eval) +;@ (define syncase:eval base:eval) (define macro:eval base:eval) (define syncase:expand #f) (define macro:expand #f) + (define (syncase:expand-install-hook expand) (set! syncase:eval (lambda (x) (base:eval (expand x)))) (set! macro:eval syncase:eval) (set! syncase:expand expand) (set! macro:expand syncase:expand)) ;;; We Need This for bootstrapping purposes: +;@ (define (syncase:load <pathname>) (slib:eval-load <pathname> syncase:eval)) (define macro:load syncase:load) - +;@ (define syncase:sanity-check #f) + ;;; LOADING THE SYSTEM ITSELF: -(let ((here (lambda (file) - (in-vicinity (library-vicinity) file))) - (scmhere (lambda (file) - (in-vicinity (library-vicinity) - (string-append file (scheme-file-suffix)))))) - (for-each (lambda (file) (slib:load (here file))) - '("scaoutp" - "scaglob" - "scaexpp")) +(slib:load (in-vicinity (program-vicinity) "scaoutp")) +(slib:load (in-vicinity (program-vicinity) "scaglob")) +(slib:load (in-vicinity (program-vicinity) "scaexpp")) + +(let ((scmhere (lambda (file) + (in-vicinity (library-vicinity) file)))) (syncase:expand-install-hook expand-syntax) - (syncase:load (here "scamacr")) + (syncase:load (scmhere "scamacr")) (set! syncase:sanity-check (lambda () (syncase:load (scmhere "sca-exp")) diff --git a/scamacr.scm b/scamacr.scm index 016d7fb..d7db6c8 100644 --- a/scamacr.scm +++ b/scamacr.scm @@ -79,7 +79,7 @@ ((let* () e1 e2 ...) (syntax (let () e1 e2 ...))) ((let* ((x1 v1) (x2 v2) ...) e1 e2 ...) - (comlist:every identifier? (syntax (x1 x2 ...))) + (syncase:every identifier? (syntax (x1 x2 ...))) (syntax (let ((x1 v1)) (let* ((x2 v2) ...) e1 e2 ...))))))) (define-syntax case @@ -1,5 +1,5 @@ -;;;;"scanf.scm" implemenation of formated input -;Copyright (C) 1996, 1997 Aubrey Jaffer +;;;;"scanf.scm" implemenation of formatted input +;Copyright (C) 1996, 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. ; @@ -23,281 +23,274 @@ ;;; functions starting from the POSIX man pages. (require 'string-port) +(require 'rev2-procedures) +(require 'rev4-optional-procedures) (define (stdio:scan-and-set format-string input-port . args) - (define setters args) - (if (equal? '(#f) args) (set! args #f)) + (define setters (if (equal? '(#f) args) #f args)) + (define assigned-count 0) + (define chars-scanned 0) + (define items '()) + (define (return) + (cond ((and (zero? chars-scanned) + (eof-object? (peek-char input-port))) + (peek-char input-port)) + (setters assigned-count) + (else (reverse items)))) (cond - ((not (equal? "" format-string)) + ((equal? "" format-string) (return)) + ((string? input-port) (call-with-input-string - format-string - (lambda (format-port) - - (define items '()) - (define chars-scanned 0) - (define assigned-count 0) + input-port + (lambda (str-port) + (apply stdio:scan-and-set format-string str-port args)))) + (else + (call-with-input-string + format-string + (lambda (format-port) - (define (char-non-numeric? c) (not (char-numeric? c))) + (define (char-non-numeric? c) (not (char-numeric? c))) - (define (flush-whitespace port) - (do ((c (peek-char port) (peek-char port)) - (i 0 (+ 1 i))) - ((or (eof-object? c) (not (char-whitespace? c))) i) - (read-char port))) + (define (flush-whitespace port) + (do ((c (peek-char port) (peek-char port)) + (i 0 (+ 1 i))) + ((or (eof-object? c) (not (char-whitespace? c))) i) + (read-char port))) - (define (flush-whitespace-input) - (set! chars-scanned (+ (flush-whitespace input-port) chars-scanned))) + (define (flush-whitespace-input) + (set! chars-scanned (+ (flush-whitespace input-port) chars-scanned))) - (define (read-input-char) - (set! chars-scanned (+ 1 chars-scanned)) - (read-char input-port)) + (define (read-input-char) + (set! chars-scanned (+ 1 chars-scanned)) + (read-char input-port)) - (define (add-item report-field? next-item) - (cond (args - (cond ((and report-field? (null? setters)) - (slib:error 'scanf "not enough variables for format" - format-string)) - ((not next-item) (return)) - ((not report-field?) (loop1)) - (else - (let ((suc ((car setters) next-item))) - (cond ((not (boolean? suc)) - (slib:warn 'scanf "setter returned non-boolean" - suc))) - (set! setters (cdr setters)) - (cond ((not suc) (return)) - ((eqv? -1 report-field?) (loop1)) - (else - (set! assigned-count (+ 1 assigned-count)) - (loop1))))))) - ((not next-item) (return)) - (report-field? (set! items (cons next-item items)) - (loop1)) - (else (loop1)))) + (define (add-item report-field? next-item) + (cond (setters + (cond ((and report-field? (null? setters)) + (slib:error 'scanf "not enough variables for format" + format-string)) + ((not next-item) (return)) + ((not report-field?) (loop1)) + (else + (let ((suc ((car setters) next-item))) + (cond ((not (boolean? suc)) + (slib:warn 'scanf "setter returned non-boolean" + suc))) + (set! setters (cdr setters)) + (cond ((not suc) (return)) + ((eqv? -1 report-field?) (loop1)) + (else + (set! assigned-count (+ 1 assigned-count)) + (loop1))))))) + ((not next-item) (return)) + (report-field? (set! items (cons next-item items)) + (loop1)) + (else (loop1)))) - (define (return) - (cond ((and (zero? chars-scanned) - (eof-object? (peek-char input-port))) - (peek-char input-port)) - (args assigned-count) - (else (reverse items)))) + (define (read-string width separator?) + (cond (width + (let ((str (make-string width))) + (do ((i 0 (+ 1 i))) + ((>= i width) + str) + (let ((c (peek-char input-port))) + (cond ((eof-object? c) + (set! str (substring str 0 i)) + (set! i width)) + ((separator? c) + (set! str (if (zero? i) "" (substring str 0 i))) + (set! i width)) + (else + (string-set! str i (read-input-char)))))))) + (else + (do ((c (peek-char input-port) (peek-char input-port)) + (l '() (cons c l))) + ((or (eof-object? c) (separator? c)) + (list->string (reverse l))) + (read-input-char))))) - (define (read-string width separator?) - (cond (width - (let ((str (make-string width))) - (do ((i 0 (+ 1 i))) - ((>= i width) - str) - (let ((c (peek-char input-port))) - (cond ((eof-object? c) - (set! str (substring str 0 i)) - (set! i width)) - ((separator? c) - (set! str (if (zero? i) "" (substring str 0 i))) - (set! i width)) - (else - (string-set! str i (read-input-char)))))))) - (else - (do ((c (peek-char input-port) (peek-char input-port)) - (l '() (cons c l))) - ((or (eof-object? c) (separator? c)) - (list->string (reverse l))) - (read-input-char))))) + (define (read-word width separator?) + (let ((l (read-string width separator?))) + (if (zero? (string-length l)) #f l))) - (define (read-word width separator?) - (let ((l (read-string width separator?))) - (if (zero? (string-length l)) #f l))) + (define (loop1) + (define fc (read-char format-port)) + (cond + ((eof-object? fc) + (return)) + ((char-whitespace? fc) + (flush-whitespace format-port) + (flush-whitespace-input) + (loop1)) + ((eqv? #\% fc) ; interpret next format + (set! fc (read-char format-port)) + (let ((report-field? (not (eqv? #\* fc))) + (width #f)) - (define (loop1) - (define fc (read-char format-port)) - (cond - ((eof-object? fc) - (return)) - ((char-whitespace? fc) - (flush-whitespace format-port) - (flush-whitespace-input) - (loop1)) - ((eqv? #\% fc) ; interpret next format - (set! fc (read-char format-port)) - (let ((report-field? (not (eqv? #\* fc))) - (width #f)) + (define (width--) (if width (set! width (+ -1 width)))) - (define (width--) (if width (set! width (+ -1 width)))) + (define (read-u) + (string->number (read-string width char-non-numeric?))) - (define (read-u) - (string->number (read-string width char-non-numeric?))) + (define (read-o) + (string->number + (read-string + width + (lambda (c) + (not (memv c '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7))))) + 8)) - (define (read-o) - (string->number - (read-string - width - (lambda (c) (not (memv c '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7))))) - 8)) + (define (read-x) + (string->number + (read-string + width + (lambda (c) (not (memv (char-downcase c) + '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 + #\9 #\a #\b #\c #\d #\e #\f))))) + 16)) - (define (read-x) - (string->number - (read-string - width - (lambda (c) (not (memv (char-downcase c) - '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 - #\9 #\a #\b #\c #\d #\e #\f))))) - 16)) + (define (read-radixed-unsigned) + (let ((c (peek-char input-port))) + (case c + ((#\0) (read-input-char) (width--) + (set! c (peek-char input-port)) + (case c + ((#\x #\X) (read-input-char) (width--) (read-x)) + (else (read-o)))) + (else (read-u))))) - (define (read-radixed-unsigned) - (let ((c (peek-char input-port))) - (case c - ((#\0) (read-input-char) + (define (read-ui) + (let* ((dot? #f) + (mantissa + (read-word + width + (lambda (c) + (not (or (char-numeric? c) + (cond (dot? #f) + ((eqv? #\. c) (set! dot? #t) #t) + (else #f))))))) + (exponent + (cond + ((not mantissa) #f) + ((and (or (not width) (> width 1)) + (memv (peek-char input-port) '(#\E #\e))) + (read-input-char) (width--) - (set! c (peek-char input-port)) - (case c - ((#\x #\X) (read-input-char) - (width--) - (read-x)) - (else (read-o)))) - (else (read-u))))) + (let* ((expsign + (case (peek-char input-port) + ((#\-) (read-input-char) + (width--) "-") + ((#\+) (read-input-char) + (width--) "+") + (else ""))) + (expint + (and (or (not width) (positive? width)) + (read-word width char-non-numeric?)))) + (and expint (string-append "e" expsign expint)))) + (else #f)))) + (and mantissa + (string->number + (string-append + "#i" (or mantissa "") (or exponent "")))))) - (define (read-ui) - (let* ((dot? #f) - (mantissa (read-word - width - (lambda (c) - (not (or (char-numeric? c) - (cond (dot? #f) - ((eqv? #\. c) - (set! dot? #t) - #t) - (else #f))))))) - (exponent (cond - ((not mantissa) #f) - ((and (or (not width) (> width 1)) - (memv (peek-char input-port) '(#\E #\e))) - (read-input-char) - (width--) - (let* ((expsign - (case (peek-char input-port) - ((#\-) (read-input-char) - (width--) - "-") - ((#\+) (read-input-char) - (width--) - "+") - (else ""))) - (expint - (and - (or (not width) (positive? width)) - (read-word width char-non-numeric?)))) - (and expint (string-append - "e" expsign expint)))) - (else #f)))) - (and mantissa - (string->number - (string-append - "#i" (or mantissa "") (or exponent "")))))) + (define (read-signed proc) + (case (peek-char input-port) + ((#\-) (read-input-char) (width--) + (let ((ret (proc))) (and ret (- ret)))) + ((#\+) (read-input-char) (width--) (proc)) + (else (proc)))) - (define (read-signed proc) - (case (peek-char input-port) - ((#\-) (read-input-char) - (width--) - (let ((ret (proc))) - (and ret (- ret)))) - ((#\+) (read-input-char) - (width--) - (proc)) - (else (proc)))) + ;;(trace read-word read-signed read-ui read-radixed-unsigned read-x read-o read-u) - ;;(trace read-word read-signed read-ui read-radixed-unsigned read-x read-o read-u) + (cond ((not report-field?) (set! fc (read-char format-port)))) + (if (char-numeric? fc) (set! width 0)) + (do () ((or (eof-object? fc) (char-non-numeric? fc))) + (set! width (+ (* 10 width) (string->number (string fc)))) + (set! fc (read-char format-port))) + (case fc ;ignore h,l,L modifiers. + ((#\h #\l #\L) (set! fc (read-char format-port)))) + (case fc + ((#\n) (if (not report-field?) + (slib:error 'scanf "not saving %n??")) + (add-item -1 chars-scanned)) ;-1 is special flag. + ((#\c #\C) + (if (not width) (set! width 1)) + (let ((str (make-string width))) + (do ((i 0 (+ 1 i)) + (c (peek-char input-port) (peek-char input-port))) + ((or (>= i width) + (eof-object? c)) + (add-item report-field? (substring str 0 i))) + (string-set! str i (read-input-char))))) + ((#\s #\S) + ;;(flush-whitespace-input) + (add-item report-field? (read-word width char-whitespace?))) + ((#\[) + (set! fc (read-char format-port)) + (let ((allbut #f)) + (case fc + ((#\^) (set! allbut #t) + (set! fc (read-char format-port)))) - (cond ((not report-field?) (set! fc (read-char format-port)))) - (if (char-numeric? fc) (set! width 0)) - (do () ((or (eof-object? fc) (char-non-numeric? fc))) - (set! width (+ (* 10 width) (string->number (string fc)))) - (set! fc (read-char format-port))) - (case fc ;ignore h,l,L modifiers. - ((#\h #\l #\L) (set! fc (read-char format-port)))) - (case fc - ((#\n) (if (not report-field?) - (slib:error 'scanf "not saving %n??")) - (add-item -1 chars-scanned)) ;-1 is special flag. - ((#\c #\C) - (if (not width) (set! width 1)) - (let ((str (make-string width))) - (do ((i 0 (+ 1 i)) - (c (peek-char input-port) (peek-char input-port))) - ((or (>= i width) - (eof-object? c)) - (add-item report-field? (substring str 0 i))) - (string-set! str i (read-input-char))))) - ((#\s #\S) - ;;(flush-whitespace-input) - (add-item report-field? (read-word width char-whitespace?))) - ((#\[) - (set! fc (read-char format-port)) - (let ((allbut #f)) - (case fc - ((#\^) (set! allbut #t) - (set! fc (read-char format-port)))) - - (let scanloop ((scanset (list fc))) - (set! fc (read-char format-port)) - (case fc - ((#\-) - (set! fc (peek-char format-port)) - (cond - ((and (char<? (car scanset) fc) - (not (eqv? #\] fc))) - (set! fc (char->integer fc)) - (do ((i (char->integer (car scanset)) (+ 1 i))) - ((> i fc) (scanloop scanset)) - (set! scanset (cons (integer->char i) scanset)))) - (else (scanloop (cons #\- scanset))))) - ((#\]) - (add-item report-field? - (read-word - width - (if allbut (lambda (c) (memv c scanset)) - (lambda (c) (not (memv c scanset))))))) - (else (cond - ((eof-object? fc) - (slib:error 'scanf "unmatched [ in format")) - (else (scanloop (cons fc scanset))))))))) - ((#\o #\O) - ;;(flush-whitespace-input) - (add-item report-field? (read-o))) - ((#\u #\U) - ;;(flush-whitespace-input) - (add-item report-field? (read-u))) - ((#\d #\D) - ;;(flush-whitespace-input) - (add-item report-field? (read-signed read-u))) - ((#\x #\X) - ;;(flush-whitespace-input) - (add-item report-field? (read-x))) - ((#\e #\E #\f #\F #\g #\G) - ;;(flush-whitespace-input) - (add-item report-field? (read-signed read-ui))) - ((#\i) - ;;(flush-whitespace-input) - (add-item report-field? (read-signed read-radixed-unsigned))) - ((#\%) - (cond ((or width (not report-field?)) - (slib:error 'SCANF "%% has modifiers?")) - ((eqv? #\% (read-input-char)) - (loop1)) - (else (return)))) - (else (slib:error 'SCANF - "Unknown format directive:" fc))))) - ((eqv? (peek-char input-port) fc) - (read-input-char) - (loop1)) - (else (return)))) - ;;(trace flush-whitespace-input flush-whitespace add-item return read-string read-word loop1) - (loop1)))) - (args 0) - (else '()))) + (let scanloop ((scanset (list fc))) + (set! fc (read-char format-port)) + (case fc + ((#\-) + (set! fc (peek-char format-port)) + (cond + ((and (char<? (car scanset) fc) + (not (eqv? #\] fc))) + (set! fc (char->integer fc)) + (do ((i (char->integer (car scanset)) (+ 1 i))) + ((> i fc) (scanloop scanset)) + (set! scanset (cons (integer->char i) scanset)))) + (else (scanloop (cons #\- scanset))))) + ((#\]) + (add-item report-field? + (read-word + width + (if allbut (lambda (c) (memv c scanset)) + (lambda (c) (not (memv c scanset))))))) + (else (cond + ((eof-object? fc) + (slib:error 'scanf "unmatched [ in format")) + (else (scanloop (cons fc scanset))))))))) + ((#\o #\O) + ;;(flush-whitespace-input) + (add-item report-field? (read-o))) + ((#\u #\U) + ;;(flush-whitespace-input) + (add-item report-field? (read-u))) + ((#\d #\D) + ;;(flush-whitespace-input) + (add-item report-field? (read-signed read-u))) + ((#\x #\X) + ;;(flush-whitespace-input) + (add-item report-field? (read-x))) + ((#\e #\E #\f #\F #\g #\G) + ;;(flush-whitespace-input) + (add-item report-field? (read-signed read-ui))) + ((#\i) + ;;(flush-whitespace-input) + (add-item report-field? (read-signed read-radixed-unsigned))) + ((#\%) + (cond ((or width (not report-field?)) + (slib:error 'SCANF "%% has modifiers?")) + ((eqv? #\% (read-input-char)) + (loop1)) + (else (return)))) + (else (slib:error 'SCANF + "Unknown format directive:" fc))))) + ((eqv? (peek-char input-port) fc) + (read-input-char) + (loop1)) + (else (return)))) + ;;(trace flush-whitespace-input flush-whitespace add-item return read-string read-word loop1) + (loop1)))))) ;;;This implements a Scheme-oriented version of SCANF: returns a list of ;;;objects read (rather than set!-ing values). - +;@ (define (scanf-read-list format-string . optarg) (define input-port (cond ((null? optarg) (current-input-port)) @@ -308,8 +301,8 @@ (stdio:scan-and-set format-string input-port #f)) ((string? input-port) (call-with-input-string - input-port (lambda (input-port) - (stdio:scan-and-set format-string input-port #f)))) + input-port (lambda (input-port) + (stdio:scan-and-set format-string input-port #f)))) (else (slib:error 'scanf-read-list "argument 2 not a port" input-port)))) @@ -322,29 +315,26 @@ (case (car sexp) ((vector-ref) `(lambda (,v) (vector-set! ,@(cdr sexp) ,v) #t)) ((substring) - (require 'rev2-procedures) `(lambda (,v) (substring-move-left! ,v 0 (min (string-length ,v) (- ,(cadddr sexp) ,(caddr sexp))) ,(cadr sexp) ,(caddr sexp)) #t)) ((list-ref) - (require 'rev4-optional-procedures) `(lambda (,v) (set-car! (list-tail ,@(cdr sexp)) ,v) #t)) ((car) `(lambda (,v) (set-car! ,@(cdr sexp) ,v) #t)) ((cdr) `(lambda (,v) (set-cdr! ,@(cdr sexp) ,v) #t)) (else (slib:error 'scanf "setter not known" sexp))))))) +;@ (defmacro scanf (format-string . args) `(stdio:scan-and-set ,format-string (current-input-port) ,@(map stdio:setter-procedure args))) - +;@ (defmacro sscanf (str format-string . args) - `(call-with-input-string - ,str (lambda (input-port) - (stdio:scan-and-set ,format-string input-port - ,@(map stdio:setter-procedure args))))) - + `(stdio:scan-and-set ,format-string ,str + ,@(map stdio:setter-procedure args))) +;@ (defmacro fscanf (input-port format-string . args) `(stdio:scan-and-set ,format-string ,input-port ,@(map stdio:setter-procedure args))) diff --git a/scheme2c.init b/scheme2c.init index f1d9fe6..a9dbab9 100644 --- a/scheme2c.init +++ b/scheme2c.init @@ -13,23 +13,20 @@ ;; Of course, if you make serious use of library functions you'll want ;; to compile them and use Scheme->C modules. - (define (software-type) 'UNIX) ;;; (scheme-implementation-type) should return the name of the scheme ;;; implementation loading this file. - (define (scheme-implementation-type) 'Scheme->C) ;;; (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) +(define (scheme-implementation-home-page) + "http://www-2.cs.cmu.edu/afs/cs/project/ai-repository/ai/lang/scheme/impl/scheme2c/0.html") ;;; (scheme-implementation-version) should return a string describing ;;; the version the scheme implementation loading this file. - (define (scheme-implementation-version) "?01nov91") (define (implementation-vicinity) @@ -40,7 +37,6 @@ ;;; (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 (case (software-type) @@ -53,15 +49,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 @@ -71,7 +71,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,14 +85,14 @@ ;STRING-FILL!, LIST->VECTOR, ;VECTOR->LIST, and VECTOR-FILL! - rev4-report ;conforms to + r4rs ;conforms to ;; Follows rev4 as far as I can tell, modulo '() being false, ;; number syntax (see doc), incomplete tail recursion (see ;; docs) and a couple of bugs in some versions -- see below. ; ieee-p1178 ;conforms to - rev3-report ;conforms to + r3rs ;conforms to ; rev2-procedures ;SUBSTRING-MOVE-LEFT!, ;SUBSTRING-MOVE-RIGHT!, @@ -103,7 +103,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 @@ -184,6 +184,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))) @@ -254,7 +285,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) @@ -271,7 +302,6 @@ (define slib:form-feed (integer->char 12)) ;;; bug fixes for Scheme->C (versions 28sep90, 23feb90, 01nov91): - (let ((vers (substring (cadr (implementation-information)) 0 7))) (if (or (string=? vers "28sep90") (string=? vers "23feb90") (string=? vers "01nov91")) @@ -299,12 +329,11 @@ ;; DEFINE as shown by test.scm -- not fixed here. ))) -(define promise:force force) +;;(define force force) ;;; (implementation-vicinity) should be defined to be the pathname of ;;; the directory where any auxillary files to your Scheme ;;; implementation reside. - (define in-vicinity string-append) ;;; Define SLIB:EXIT to be the implementation procedure to exit or @@ -320,17 +349,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 (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 load) ;;; 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/scheme48.init b/scheme48.init index 75ab0f5..0640120 100644 --- a/scheme48.init +++ b/scheme48.init @@ -38,23 +38,19 @@ ;;; (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) 'Scheme48) ;;; (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://s48.org/") ;;; (scheme-implementation-version) should return a string describing ;;; the version of the scheme implementation loading this file. - (define scheme-implementation-version (let ((version (getenv "S48_VERSION"))) (lambda () version))) @@ -62,14 +58,12 @@ ;;; (implementation-vicinity) should be defined to be the pathname of ;;; the directory where any auxiliary files to your Scheme ;;; implementation reside. - (define implementation-vicinity (let ((vic (getenv "S48_VICINITY"))) (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 ((vic (getenv "SCHEME_LIBRARY_PATH"))) (lambda () vic))) @@ -77,10 +71,15 @@ ;;; (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))))) (let* ((siv (scheme-implementation-version)) (num-ver (and siv (string->number siv)))) @@ -91,7 +90,6 @@ ;;; *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 @@ -101,7 +99,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 @@ -115,11 +113,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!, @@ -130,7 +128,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 @@ -200,6 +198,37 @@ (s48-force-output (if (null? arg) (current-output-port) (car 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'"))) + ;;; "rationalize" adjunct procedures. (define (find-ratio x e) (let ((rat (rationalize x e))) @@ -227,12 +256,24 @@ (define two-arg:atan atan) (define (atan y . x) (if (null? x) (two-arg:atan y 1) (two-arg:atan y (car x)))) +;;; asin is totally busted +(define (asin y) (two-arg:atan y (sqrt (- 1 (* y y))))) + +;;; Workaround inexact->exact and exact->inexact bugs. +(define inexact->exact + (let ((i->e inexact->exact)) + (lambda (z) + (if (exact? z) z (i->e z))))) +(define exact->inexact + (let ((e->i exact->inexact)) + (lambda (z) + (if (inexact? z) z (e->i z))))) ;;; MOST-POSITIVE-FIXNUM is used in modular.scm (define most-positive-fixnum #x1FFFFFFF) ;;; Return argument -(define (identity x) x) +(define identity values) ;;; SLIB:EVAL is single argument eval using the top-level (user) environment. (define slib:eval @@ -301,7 +342,13 @@ (let ((cep (current-error-port))) (if (provided? 'trace) (print-call-stack cep)) (display "Warn: " cep) - (for-each (lambda (x) (display x cep)) args)))) + (write (car args) cep) + (newline cep) + (for-each (lambda (x) + (display " " cep) + (write x cep) + (newline cep)) + (cdr args))))) ;;; define an error procedure for the library (define (slib:error . args) @@ -344,11 +391,9 @@ ;;; (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) ;;; Scheme48 complains that these are not defined (even though they @@ -384,5 +429,5 @@ ,collect ,batch off -,dump slib.image "(slib 2d2)" +,dump slib.image "(slib 3a1)" ,exit diff --git a/schmooz.scm b/schmooz.scm index e9950d2..f50a397 100644 --- a/schmooz.scm +++ b/schmooz.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,14 @@ ;promotional, or sales literature without prior written consent in ;each case. +(require 'common-list-functions) ;some +(require 'string-search) +(require 'fluid-let) +(require 'line-i/o) ;read-line +(require 'filename) + +;;(require 'debug) (set! *qp-width* 100) (define qreport qpn) + ;;; REPORT an error or warning (define report (lambda args @@ -37,14 +45,6 @@ (for-each (lambda (x) (write x) (display #\ )) args) (newline))) -(require 'common-list-functions) ;some -(require 'string-search) -(require 'fluid-let) -(require 'line-i/o) ;read-line -(require 'filename) -(require 'scanf) -;;(require 'debug) (set! *qp-width* 100) (define qreport qpn) - ;;; This allows us to test without generating files (define *scheme-source* (current-input-port)) (define *scheme-source-name* "stdin") @@ -225,7 +225,11 @@ ((DEFINE) (if (pair? name) name (form (caddr sexp)))) - ((DEFINE-SYNTAX) '()) + ((DEFINE-SYNTAX) + (case (caaddr sexp) + ((SYNTAX-RULES) + (caaddr (caddr sexp))) + (else '()))) ((DEFMACRO) (cons (cadr sexp) (caddr sexp))) ((DEFVAR DEFCONST) #f) (else (slib:error 'schmooz "doesn't look like definition" sexp)))) @@ -291,13 +295,21 @@ (else (slib:error 'schmooz-fun args)))))) (let* ((mac-list (scheme-args->macros args)) (ops (case defop - ((DEFINE-SYNTAX) '("defspec" . "defspecx")) - ((DEFMACRO) '("defmac" . "defmacx")) - (else '("defun" . "defunx"))))) + ((DEFINE-SYNTAX) '("defspec" "defspecx" "defspec")) + ((DEFMACRO) '("defmac" "defmacx" "defmac")) + (else + (if (and (symbol? (car args)) + (char=? (string-ref + (symbol->string (car args)) + (+ -1 (string-length (symbol->string + (car args))))) + #\!)) + '("deffn {Procedure}" "deffnx {Procedure}" "deffn") + '("defun" "defunx" "defun")))))) (out-header args (car ops)) (let loop ((xdefs xdefs)) (cond ((pair? xdefs) - (out-header (car xdefs) (cdr ops)) + (out-header (car xdefs) (cadr ops)) (loop (cdr xdefs))))) (for-each (lambda (subl) (out 0 (car subl)) @@ -308,12 +320,12 @@ ((@args) (out-header (cons (car args) (cdr l)) - (cdr ops))))) + (cadr ops))))) (cdr subl))) (map (lambda (bl) (substitute-macs bl mac-list)) body)) - (out 0 "@end " (car ops)) + (out 0 "@end " (caddr ops)) (out 0))) (define (schmooz-var defop name body xdefs) @@ -337,7 +349,16 @@ (out 0 "@end defvar") (out 0))) -;;; SCHMOOZ files. +(define (schmooz:read-word port) + (do ((chr (peek-char port) (peek-char port))) + ((not (and (char? chr) (char-whitespace? chr)))) + (read-char port)) + (do ((chr (peek-char port) (peek-char port)) + (str "" (string-append str (string chr)))) + ((not (and (char? chr) (not (char-whitespace? chr)))) str) + (read-char port))) + +;;;@ SCHMOOZ files. (define schmooz (let* ((scheme-file? (filename:match-ci?? "*??scm")) (txi-file? (filename:match-ci?? "*??txi")) @@ -354,8 +375,8 @@ (do ((pos (find-string-from-port? "@include" port) (find-string-from-port? "@include" port))) ((not pos)) - (let ((fname #f)) - (cond ((not (eqv? 1 (fscanf port " %s" fname)))) + (let ((fname (schmooz:read-word port))) + (cond ((equal? "" fname)) ((not (txi-file? fname))) ((not (file-exists? (txi->scm fname)))) (else (schmooz (txi->scm fname))))))))) @@ -384,176 +405,178 @@ files)))) ;;; SCHMOOZ-TOPS - schmooz top level forms. -(define (schmooz-tops schmooz-top) - (let ((doc-lines '()) - (doc-args #f)) - (define (skip-ws line istrt) - (do ((i istrt (+ i 1))) - ((or (>= i (string-length line)) - (not (memv (string-ref line i) - '(#\space #\tab #\;)))) - (substring line i (string-length line))))) - - (define (tok1 line) - (let loop ((i 0)) - (cond ((>= i (string-length line)) line) - ((or (char-whitespace? (string-ref line i)) - (memv (string-ref line i) '(#\; #\( #\{))) - (substring line 0 i)) - (else (loop (+ i 1)))))) - - (define (read-cmt-line) - (cond ((eqv? #\; (peek-char *scheme-source*)) - (read-char *scheme-source*) - (read-cmt-line)) - (else (read-line *scheme-source*)))) - - (define (read-meta-cmt) - (let skip ((metarg? #f)) - (let ((c (read-char *scheme-source*))) - (case c - ((#\newline) (if metarg? (skip #t))) - ((#\\) (skip #t)) - ((#\!) (cond ((eqv? #\# (peek-char *scheme-source*)) - (read-char *scheme-source*) - (if #f #f)) +(define schmooz-tops + (let ((semispaces (cons slib:tab '(#\space #\;)))) + (lambda (schmooz-top) + (let ((doc-lines '()) + (doc-args #f)) + (define (skip-ws line istrt) + (do ((i istrt (+ i 1))) + ((or (>= i (string-length line)) + (not (memv (string-ref line i) semispaces))) + (substring line i (string-length line))))) + + (define (tok1 line) + (let loop ((i 0)) + (cond ((>= i (string-length line)) line) + ((or (char-whitespace? (string-ref line i)) + (memv (string-ref line i) '(#\; #\( #\{))) + (substring line 0 i)) + (else (loop (+ i 1)))))) + + (define (read-cmt-line) + (cond ((eqv? #\; (peek-char *scheme-source*)) + (read-char *scheme-source*) + (read-cmt-line)) + (else (read-line *scheme-source*)))) + + (define (read-meta-cmt) + (let skip ((metarg? #f)) + (let ((c (read-char *scheme-source*))) + (case c + ((#\newline) (if metarg? (skip #t))) + ((#\\) (skip #t)) + ((#\!) (cond ((eqv? #\# (peek-char *scheme-source*)) + (read-char *scheme-source*) + (if #f #f)) + (else + (skip metarg?)))) + (else + (if (char? c) (skip metarg?) c)))))) + + (define (lp c) + (cond ((eof-object? c) + (cond ((pair? doc-lines) + (report "No definition found for @body doc lines" + (reverse doc-lines))))) + ((eqv? c #\newline) + (read-char *scheme-source*) + (set! *output-line* (+ 1 *output-line*)) + ;;(newline *derived-txi*) + (lp (peek-char *scheme-source*))) + ((char-whitespace? c) + (write-char (read-char *scheme-source*) *derived-txi*) + (lp (peek-char *scheme-source*))) + ((char=? c #\;) + (c-cmt c)) + ((char=? c #\#) + (read-char *scheme-source*) + (if (eqv? #\! (peek-char *scheme-source*)) + (read-meta-cmt) + (report "misread sharp object" (peek-char *scheme-source*))) + (lp (peek-char *scheme-source*))) + (else + (sx)))) + + (define (sx) + (let* ((s1 (read *scheme-source*)) + ;;Read all forms separated only by single newlines + ;;and trailing whitespace. + (ss (let recur () + (let ((c (peek-char *scheme-source*))) + (cond ((eof-object? c) '()) + ((eqv? c #\newline) + (read-char *scheme-source*) + (if (eqv? #\( (peek-char *scheme-source*)) + (let ((s (read *scheme-source*))) + (cons s (recur))) + '())) + ((char-whitespace? c) + (read-char *scheme-source*) + (recur)) + (else '())))))) + (cond ((eof-object? s1)) + (else + (schmooz-top s1 ss (reverse doc-lines) doc-args) + (set! doc-lines '()) + (set! doc-args #f) + (lp (peek-char *scheme-source*)))))) + + (define (out-cmt line) + (let ((subl (substitute-macs line '()))) + (display (car subl) *derived-txi*) + (for-each + (lambda (l) + (case (car l) + ((@dfn) + (out-cindex (cadr l))) + (else + (report "bad macro" line)))) + (cdr subl)) + (newline *derived-txi*))) + + ;;Comments not transcribed to generated Texinfo files. + (define (c-cmt c) + (cond ((eof-object? c) (lp c)) + ((eqv? #\; c) + (read-char *scheme-source*) + (c-cmt (peek-char *scheme-source*))) + ;; Escape to start Texinfo comments + ((eqv? #\@ c) + (let* ((line (read-line *scheme-source*)) + (tok (tok1 line))) + (cond ((or (string=? tok "@body") + (string=? tok "@text")) + (set! doc-lines + (cons (skip-ws line (string-length tok)) + doc-lines)) + (body-cmt (peek-char *scheme-source*))) + ((string=? tok "@args") + (let ((args + (parse-args line (string-length tok)))) + (set! doc-args (cdr args)) + (set! doc-lines + (cons (skip-ws line (car args)) + doc-lines))) + (body-cmt (peek-char *scheme-source*))) (else - (skip metarg?)))) - (else - (if (char? c) (skip metarg?) c)))))) - - (define (lp c) - (cond ((eof-object? c) - (cond ((pair? doc-lines) - (report "No definition found for @body doc lines" - (reverse doc-lines))))) - ((eqv? c #\newline) - (read-char *scheme-source*) - (set! *output-line* (+ 1 *output-line*)) - ;;(newline *derived-txi*) - (lp (peek-char *scheme-source*))) - ((char-whitespace? c) - (write-char (read-char *scheme-source*) *derived-txi*) - (lp (peek-char *scheme-source*))) - ((char=? c #\;) - (c-cmt c)) - ((char=? c #\#) - (read-char *scheme-source*) - (if (eqv? #\! (peek-char *scheme-source*)) - (read-meta-cmt) - (report "misread sharp object" (peek-char *scheme-source*))) - (lp (peek-char *scheme-source*))) - (else - (sx)))) - - (define (sx) - (let* ((s1 (read *scheme-source*)) - ;;Read all forms separated only by single newlines - ;;and trailing whitespace. - (ss (let recur () - (let ((c (peek-char *scheme-source*))) - (cond ((eqv? c #\newline) - (read-char *scheme-source*) - (if (eqv? #\( (peek-char *scheme-source*)) - (let ((s (read *scheme-source*))) - (cons s (recur))) - '())) - ((char-whitespace? c) - (read-char *scheme-source*) - (recur)) - (else '())))))) - (cond ((eof-object? s1)) - (else - (schmooz-top s1 ss (reverse doc-lines) doc-args) - (set! doc-lines '()) - (set! doc-args #f) - (lp (peek-char *scheme-source*)))))) - - (define (out-cmt line) - (let ((subl (substitute-macs line '()))) - (display (car subl) *derived-txi*) - (for-each - (lambda (l) - (case (car l) - ((@dfn) - (out-cindex (cadr l))) - (else - (report "bad macro" line)))) - (cdr subl)) - (newline *derived-txi*))) - - ;;Comments not transcribed to generated Texinfo files. - (define (c-cmt c) - (cond ((eof-object? c) (lp c)) - ((eqv? #\; c) - (read-char *scheme-source*) - (c-cmt (peek-char *scheme-source*))) - ;; Escape to start Texinfo comments - ((eqv? #\@ c) - (let* ((line (read-line *scheme-source*)) - (tok (tok1 line))) - (cond ((or (string=? tok "@body") - (string=? tok "@text")) - (set! doc-lines - (cons (skip-ws line (string-length tok)) - doc-lines)) - (body-cmt (peek-char *scheme-source*))) - ((string=? tok "@args") - (let ((args - (parse-args line (string-length tok)))) - (set! doc-args (cdr args)) - (set! doc-lines - (cons (skip-ws line (car args)) - doc-lines))) - (body-cmt (peek-char *scheme-source*))) - (else - (out-cmt (if (string=? tok "@") - (skip-ws line 1) - line)) - (doc-cmt (peek-char *scheme-source*)))))) - ;; Transcribe the comment line to C source file. - (else - (read-line *scheme-source*) - (lp (peek-char *scheme-source*))))) - - ;;Comments incorporated in generated Texinfo files. - ;;Continue adding lines to DOC-LINES until a non-comment - ;;line is reached (may be a blank line). - (define (body-cmt c) - (cond ((eof-object? c) (lp c)) - ((eqv? #\; c) - (set! doc-lines (cons (read-cmt-line) doc-lines)) - (body-cmt (peek-char *scheme-source*))) - ((eqv? c #\newline) - (read-char *scheme-source*) - (lp (peek-char *scheme-source*))) - ;; Allow whitespace before ; in doc comments. - ((char-whitespace? c) - (read-char *scheme-source*) - (body-cmt (peek-char *scheme-source*))) - (else - (lp (peek-char *scheme-source*))))) - - ;;Comments incorporated in generated Texinfo files. - ;;Transcribe comments to current position in Texinfo file - ;;until a non-comment line is reached (may be a blank line). - (define (doc-cmt c) - (cond ((eof-object? c) (lp c)) - ((eqv? #\; c) - (out-cmt (read-cmt-line)) - (doc-cmt (peek-char *scheme-source*))) - ((eqv? c #\newline) - (read-char *scheme-source*) - (newline *derived-txi*) - (lp (peek-char *scheme-source*))) - ;; Allow whitespace before ; in doc comments. - ((char-whitespace? c) - (read-char *scheme-source*) - (doc-cmt (peek-char *scheme-source*))) - (else - (newline *derived-txi*) - (lp (peek-char *scheme-source*))))) - (lp (peek-char *scheme-source*)))) + (out-cmt (if (string=? tok "@") + (skip-ws line 1) + line)) + (doc-cmt (peek-char *scheme-source*)))))) + ;; Transcribe the comment line to C source file. + (else + (read-line *scheme-source*) + (lp (peek-char *scheme-source*))))) + + ;;Comments incorporated in generated Texinfo files. + ;;Continue adding lines to DOC-LINES until a non-comment + ;;line is reached (may be a blank line). + (define (body-cmt c) + (cond ((eof-object? c) (lp c)) + ((eqv? #\; c) + (set! doc-lines (cons (read-cmt-line) doc-lines)) + (body-cmt (peek-char *scheme-source*))) + ((eqv? c #\newline) + (read-char *scheme-source*) + (lp (peek-char *scheme-source*))) + ;; Allow whitespace before ; in doc comments. + ((char-whitespace? c) + (read-char *scheme-source*) + (body-cmt (peek-char *scheme-source*))) + (else + (lp (peek-char *scheme-source*))))) + + ;;Comments incorporated in generated Texinfo files. + ;;Transcribe comments to current position in Texinfo file + ;;until a non-comment line is reached (may be a blank line). + (define (doc-cmt c) + (cond ((eof-object? c) (lp c)) + ((eqv? #\; c) + (out-cmt (read-cmt-line)) + (doc-cmt (peek-char *scheme-source*))) + ((eqv? c #\newline) + (read-char *scheme-source*) + (newline *derived-txi*) + (lp (peek-char *scheme-source*))) + ;; Allow whitespace before ; in doc comments. + ((char-whitespace? c) + (read-char *scheme-source*) + (doc-cmt (peek-char *scheme-source*))) + (else + (newline *derived-txi*) + (lp (peek-char *scheme-source*))))) + (lp (peek-char *scheme-source*)))))) (define (schmooz-top-doc-begin def1 defs doc proc-args) (let ((op1 (sexp-def def1))) @@ -586,7 +609,7 @@ (cons (def->var-name (car ss)) smatch))))))))))))) -;;; SCHMOOZ-TOP - schmooz top level form sexp. +;;; SCHMOOZ-TOP - schmooz top level form sexp1 ... (define (schmooz-top sexp1 sexps doc proc-args) (cond ((not (pair? sexp1))) ((pair? sexps) @@ -621,5 +644,5 @@ (or (null? doc) (report "SCHMOOZ: no definition found for Texinfo documentation" - doc sexp)) + doc sexp1)) (set! *procedure* #f)) diff --git a/schmooz.texi b/schmooz.texi index 24c30d0..fc307e2 100644 --- a/schmooz.texi +++ b/schmooz.texi @@ -11,20 +11,20 @@ imported into the documentation using the Texinfo command used to process files. Files containing schmooz documentation should not contain @code{(require 'schmooz)}. -@deffn Procedure schmooz filename@r{scm} @dots{} -@var{Filename}scm should be a string ending with @samp{scm} naming an +@deffn Procedure schmooz filename@r{.scm} @dots{} +@var{Filename}.scm should be a string ending with @samp{.scm} naming an existing file containing Scheme source code. @code{schmooz} extracts -top-level comments containing schmooz commands from @var{filename}scm +top-level comments containing schmooz commands from @var{filename}.scm and writes the converted Texinfo source to a file named -@var{filename}txi. +@var{filename}.txi. -@deffnx Procedure schmooz filename@r{texi} @dots{} -@deffnx Procedure schmooz filename@r{tex} @dots{} -@deffnx Procedure schmooz filename@r{txi} @dots{} +@deffnx Procedure schmooz filename@r{.texi} @dots{} +@deffnx Procedure schmooz filename@r{.tex} @dots{} +@deffnx Procedure schmooz filename@r{.txi} @dots{} @var{Filename} should be a string naming an existing file containing Texinfo source code. For every occurrence of the string @samp{@@include -@var{filename}txi} within that file, @code{schmooz} calls itself with -the argument @samp{@var{filename}scm}. +@var{filename}.txi} within that file, @code{schmooz} calls itself with +the argument @samp{@var{filename}.scm}. @end deffn Schmooz comments are distinguished (from non-schmooz comments) by their @@ -2,5 +2,4 @@ ;;; SCM supports SLIB natively; no initialization file is actually ;;; required. So just stub this file: - (slib:load (in-vicinity (library-vicinity) "require")) diff --git a/scmacro.scm b/scmacro.scm index 97bb52f..debc38a 100644 --- a/scmacro.scm +++ b/scmacro.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. +(require 'promise) ; Portable support for force and delay. +(require 'record) +(require 'synchk) ; Syntax checker. + ;;;; Syntaxer Output Interface (define syntax-error slib:error) @@ -40,7 +44,7 @@ (string->symbol (string-append "." (symbol->string (identifier->symbol identifier)) - (promise:force suffix-promise)))))) + (force suffix-promise)))))) (define (output/variable name) name) @@ -80,10 +84,6 @@ (define (output/unspecific) `'*UNSPECIFIC*) -(require 'promise) ; Portable support for force and delay. -(require 'record) -(require 'synchk) ; Syntax checker. - ;;; This file is the macro expander proper. (slib:load (in-vicinity (library-vicinity) "synclo")) @@ -94,7 +94,7 @@ ;;; OK, time to build the databases. (initialize-scheme-syntactic-environment!) -;;; MACRO:EXPAND is for you to use. It takes an R4RS expression, macro-expands +;;@ MACRO:EXPAND is for you to use. It takes an R4RS expression, macro-expands ;;; it, and returns the result of the macro expansion. (define (synclo:expand expression) (set! *counter* 0) @@ -104,14 +104,13 @@ ;;; Here are EVAL, EVAL! and LOAD which expand macros. You can replace the ;;; implementation's eval and load with them if you like. (define base:eval slib:eval) -(define base:load load) - +;;(define base:load load) +;@ (define (synclo:eval x) (base:eval (macro:expand x))) (define macro:eval synclo:eval) - +;@ (define (synclo:load <pathname>) (slib:eval-load <pathname> synclo:eval)) - (define macro:load synclo:load) (provide 'syntactic-closures) @@ -5,58 +5,56 @@ ;;; (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) 'Scsh) ;;; (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://swissnet.ai.mit.edu/ftpdir/scsh/") + "http://www.scsh.net") ;;; (scheme-implementation-version) should return a string describing ;;; the version the scheme implementation loading this file. - (define (scheme-implementation-version) "0.5.1") ;;; (implementation-vicinity) should be defined to be the pathname of ;;; the directory where any auxillary files to your Scheme ;;; implementation reside. - (define (implementation-vicinity) "/home/tomas/src/scsh-0.5.1/") ;;; (library-vicinity) should be defined to be the pathname of the ;;; directory where files of Scheme library functions reside. - (define (library-vicinity) "/home/tomas/src/slib2b1/") ;;; (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 ;(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 @@ -76,7 +74,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 @@ -130,6 +128,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 scsh.init")) + ;;; "rationalize" adjunct procedures. (define (find-ratio x e) (let ((rat (rationalize x e))) @@ -145,7 +170,7 @@ (define most-positive-fixnum #x0FFFFFFF) ;;; Return argument -(define (identity x) x) +(define identity values) ;;; SLIB:EVAL is single argument eval using the top-level (user) environment. @@ -212,7 +237,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) @@ -232,7 +257,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+) @@ -252,17 +276,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) ;;; Scheme48 complains that these are not defined (even though they diff --git a/selfset.scm b/selfset.scm index 14fcd20..1d22b91 100644 --- a/selfset.scm +++ b/selfset.scm @@ -1,5 +1,5 @@ ;;"selfset.scm" Set single letter identifiers to their symbols. - +;@ (define a 'a) (define b 'b) (define c 'c) diff --git a/sierpinski.scm b/sierpinski.scm index 6300e8a..1096bd5 100644 --- a/sierpinski.scm +++ b/sierpinski.scm @@ -4,7 +4,7 @@ ; This code is in the public domain. ;Date: Fri, 6 May 94 13:22:34 -0500 - +;@ (define MAKE-SIERPINSKI-INDEXER (lambda (max-coordinate) (lambda (x y) diff --git a/simetrix.scm b/simetrix.scm index 3a3f16b..e187dd2 100644 --- a/simetrix.scm +++ b/simetrix.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,6 +22,7 @@ ;; http://swissnet.ai.mit.edu/~jaffer/MIXF.html (require 'precedence-parse) +(require 'string-port) ;;; Combine alists (define (SI:adjoin unitlst SIms) @@ -200,7 +201,7 @@ ((symbol? result) (SI:expand-unit result)) (else result))))) -;;;; advertised interface +;;;;@ advertised interface (define (SI:conversion-factor to-unit from-unit) (let ((funit (SI:expand-equivalence from-unit)) (tunit (SI:expand-equivalence to-unit))) @@ -1,4 +1,4 @@ -This is slib.info, produced by makeinfo version 4.0 from slib.texi. +This is slib.info, produced by makeinfo version 4.6 from slib.texi. INFO-DIR-SECTION The Algorithmic Language Scheme START-INFO-DIR-ENTRY @@ -8,8 +8,8 @@ END-INFO-DIR-ENTRY This file documents SLIB, the portable Scheme library. Copyright (C) 1993 Todd R. Eigenschink -Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000 Aubrey -Jaffer +Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, +2002 Aubrey Jaffer Permission is granted to make and distribute verbatim copies of this manual provided the copyright notice and this permission notice are @@ -38,6 +38,7 @@ implementation, user, or directory. * Menu: * The Library System:: How to use and customize. +* Universal SLIB Procedures:: Provided for all implementations. | * Scheme Syntax Extension Packages:: * Textual Conversion Packages:: * Mathematical Packages:: @@ -47,31 +48,32 @@ implementation, user, or directory. * Index:: -File: slib.info, Node: The Library System, Next: Scheme Syntax Extension Packages, Prev: Top, Up: Top - +File: slib.info, Node: The Library System, Next: Universal SLIB Procedures, Prev: Top, Up: Top + | The Library System ****************** * Menu: * Feature:: SLIB names. -* Requesting Features:: +* Require:: | * Library Catalogs:: -* Catalog Compilation:: -* Built-in Support:: -* About this manual:: +* Catalog Creation:: | +* Catalog Vicinities:: | +* Compiling Scheme:: | -File: slib.info, Node: Feature, Next: Requesting Features, Prev: The Library System, Up: The Library System - +File: slib.info, Node: Feature, Next: Require, Prev: The Library System, Up: The Library System + | Feature ======= SLIB denotes "features" by symbols. SLIB maintains a list of features -supported by the Scheme "session". The set of features provided by a -session may change over time. Some features are properties of the -Scheme implementation being used. The following features detail what -sort of numbers are available from an implementation. +supported by a Scheme "session". The set of features provided by a | +session may change during that session. Some features are properties | +of the Scheme implementation being used. The following "intrinsic | +feature"s detail what sort of numbers are available from an | +implementation: | * 'inexact @@ -83,29 +85,63 @@ sort of numbers are available from an implementation. * 'bignum -Other features correspond to the presence of sets of Scheme procedures -or syntax (macros). +SLIB initialization (in `require.scm') tests and "provide"s any of | +these numeric features which are appropriate. | + | +Other features correspond to the presence of packages of Scheme | +procedures or syntax (macros). | - Function: provided? feature - Returns `#t' if FEATURE is supported by the current Scheme session. + Returns `#t' if FEATURE is present in the current Scheme session; | + otherwise `#f'. More specifically, `provided?' returns `#t' if | + the symbol FEATURE is the `software-type' or if FEATURE has been | + provided by a module already loaded; and `#f' otherwise. | + | + In some implementations `provided?' tests whether a module has | + been `require'd by any module or in any thread; other | + implementations will have `provided?' reflect only the modules | + `require'd by that particular session or thread. | + | + To work portably in both scenarios, use `provided?' only to test | + whether intrinsic properties (like those above) are present. | + | + The FEATURE argument can also be an expression calling `and', | + `or', and `not' of features. The boolean result of the logical | + question asked by FEATURE is returned. | + | +The generalization of `provided?' for arbitrary features and catalog is | +`feature-eval': | + | + - Function: feature-eval expression provided? | + Evaluates `and', `or', and `not' forms in EXPRESSION, using the | + values returned by calling PROVIDED? on the leaf symbols. | + `feature-eval' returns the boolean result of the logical | + combinations. | - Procedure: provide feature - Informs SLIB that FEATURE is supported. Henceforth `(provided? - FEATURE)' will return `#t'. + Informs SLIB that FEATURE is supported in this session. | (provided? 'foo) => #f (provide 'foo) (provided? 'foo) => #t -File: slib.info, Node: Requesting Features, Next: Library Catalogs, Prev: Feature, Up: The Library System - -Requesting Features -=================== +File: slib.info, Node: Require, Next: Library Catalogs, Prev: Feature, Up: The Library System + | +Require | +======= | SLIB creates and maintains a "catalog" mapping features to locations of files introducing procedures and syntax denoted by those features. + - Variable: *catalog* | + Is an association list of features (symbols) and pathnames which | + will supply those features. The pathname can be either a string | + or a pair. If pathname is a pair then the first element should be | + a macro feature symbol, `source', `compiled', or one of the other | + cases described in *Note Library Catalogs::. The cdr of the | + pathname should be either a string or a list. | + | At the beginning of each section of this manual, there is a line like `(require 'FEATURE)'. The Scheme files comprising SLIB are cataloged so that these feature names map to the corresponding files. @@ -114,52 +150,55 @@ SLIB provides a form, `require', which loads the files providing the requested feature. - Procedure: require feature - * If `(provided? FEATURE)' is true, then `require' just returns - an unspecified value. + * If `(provided? FEATURE)' is true, then `require' just returns. | * Otherwise, if FEATURE is found in the catalog, then the - corresponding files will be loaded and an unspecified value - returned. - - Subsequently `(provided? FEATURE)' will return `#t'. + corresponding files will be loaded and `(provided? FEATURE)' | + will henceforth return `#t'. That FEATURE is thereafter | + `provided'. | * Otherwise (FEATURE not found in the catalog), an error is signaled. -The catalog can also be queried using `require:feature->path'. +There is a related form `require-if', used primarily for enabling | +compilers to statically include modules which would be dynamically | +loaded by interpreters. | - - Function: require:feature->path feature - * If FEATURE is already provided, then returns `#t'. + - Procedure: require-if condition feature | + Requires FEATURE if CONDITION is true. | - * Otherwise, if FEATURE is in the catalog, the path or list of - paths associated with FEATURE is returned. +The `random' module uses `require-if' to flag `object->string' as a | +(dynamic) required module. | - * Otherwise, returns `#f'. + (require 'byte) | + (require 'logical) | + (require-if 'compiling 'object->string) | - -File: slib.info, Node: Library Catalogs, Next: Catalog Compilation, Prev: Requesting Features, Up: The Library System +The `batch' module uses `require-if' to flag `posix-time' as a module | +to load if the implementation supports large precision exact integers. | -Library Catalogs -================ + (require-if '(and bignum compiling) 'posix-time) | -At the start of a session no catalog is present, but is created with the -first catalog inquiry (such as `(require 'random)'). Several sources -of catalog information are combined to produce the catalog: +The `commutative-ring' module uses `require-if' to ensure that it has | +an exponentiation routine, regardless of whether the implementation | +supports inexact numbers: | - * standard SLIB packages. + (require-if '(not inexact) 'logical) ;for integer-expt | + (define number^ (if (provided? 'inexact) expt integer-expt)) | - * additional packages of interest to this site. +The catalog can also be queried using `slib:in-catalog?'. | - * packages specifically for the variety of Scheme which this session - is running. + - Function: slib:in-catalog? feature | + Returns a `CDR' of the catalog entry if one was found for the | + symbol FEATURE in the alist `*catalog*' (and transitively through | + any symbol aliases encountered). Otherwise, returns `#f'. The | + format of catalog entries is explained in *Note Library Catalogs::. | - * packages this user wants to always have available. This catalog - is the file `homecat' in the user's "HOME" directory. - - * packages germane to working in this (current working) directory. - This catalog is the file `usercat' in the directory to which it - applies. One would typically `cd' to this directory before - starting the Scheme session. + +File: slib.info, Node: Library Catalogs, Next: Catalog Creation, Prev: Require, Up: The Library System + | +Library Catalogs | +================ | Catalog files consist of one or more "association list"s. In the circumstance where a feature symbol appears in more than one list, the @@ -178,6 +217,9 @@ for elements of catalog lists: `(FEATURE compiled "<path>" ...)' `slib:load-compiled's the files <path> .... +`(FEATURE aggregate <symbol> ...)' + `slib:require's the features <symbol> .... | + The various macro styles first `require' the named macro package, then just load <path> or load-and-macro-expand <path> as appropriate for the implementation. @@ -200,22 +242,33 @@ implementation. `(FEATURE syntactic-closures "<path>")' `macro:load's the Scheme source file <path>. -Here is an example of a `usercat' catalog. A Program in this directory -can invoke the `run' feature with `(require 'run)'. + +File: slib.info, Node: Catalog Creation, Next: Catalog Vicinities, Prev: Library Catalogs, Up: The Library System + | +Catalog Creation | +================ | - ;;; "usercat": SLIB catalog additions for SIMSYNCH. -*-scheme-*- - - ( - (simsynch . "../synch/simsynch.scm") - (run . "../synch/run.scm") - (schlep . "schlep.scm") - ) +At the start of an interactive session no catalog is present, but is | +created with the first catalog inquiry (such as `(require 'random)'). | +Several sources of catalog information are combined to produce the | +catalog: | - -File: slib.info, Node: Catalog Compilation, Next: Built-in Support, Prev: Library Catalogs, Up: The Library System + * standard SLIB packages. | -Catalog Compilation -=================== + * additional packages of interest to this site. | + | + * packages specifically for the variety of Scheme which this session | + is running. | + | + * packages this user wants to always have available. This catalog | + is the file `homecat' in the user's "HOME" directory. | + | + * packages germane to working in this (current working) directory. | + This catalog is the file `usercat' in the directory to which it | + applies. One would typically `cd' to this directory before | + starting the Scheme session. | + | + * packages which are part of an application program. | SLIB combines the catalog information which doesn't vary per user into the file `slibcat' in the implementation-vicinity. Therefore `slibcat' @@ -226,27 +279,34 @@ is used with. The definition of `*SLIB-VERSION*' in SLIB file `require.scm' is checked against the catalog association of `*SLIB-VERSION*' to -ascertain when versions have changed. I recommend that the definition -of `*SLIB-VERSION*' be changed whenever the library is changed. If -multiple implementations of Scheme use SLIB, remember that recompiling -one `slibcat' will fix only that implementation's catalog. +ascertain when versions have changed. It is a reasonable practice to | +change the definition of `*SLIB-VERSION*' whenever the library is | +changed. If multiple implementations of Scheme use SLIB, remember that | +recompiling one `slibcat' will update only that implementation's | +catalog. | The compilation scripts of Scheme implementations which work with SLIB can automatically trigger catalog compilation by deleting `slibcat' or -by invoking a special form of `require': +by invoking `require' of a special feature: | - Procedure: require 'new-catalog This will load `mklibcat', which compiles and writes a new `slibcat'. -Another special form of `require' erases SLIB's catalog, forcing it to -be reloaded the next time the catalog is queried. +Another special feature of `require' erases SLIB's catalog, forcing it | +to be reloaded the next time the catalog is queried. | - Procedure: require #f Removes SLIB's catalog information. This should be done before saving an executable image so that, when restored, its catalog will be loaded afresh. + +File: slib.info, Node: Catalog Vicinities, Next: Compiling Scheme, Prev: Catalog Creation, Up: The Library System + | +Catalog Vicinities | +================== | + | Each file in the table below is descibed in terms of its file-system independent "vicinity" (*note Vicinity::). The entries of a catalog in the table override those of catalogs above it in the table. @@ -279,101 +339,381 @@ the table override those of catalogs above it in the table. This file contains the associations specific to an SLIB user. `user-vicinity' `usercat' - This file contains associations effecting only those sessions whose + This file contains associations affecting only those sessions whose | "working directory" is `user-vicinity'. - -File: slib.info, Node: Built-in Support, Next: About this manual, Prev: Catalog Compilation, Up: The Library System -Built-in Support +Here is an example of a `usercat' catalog. A program in this directory | +can invoke the `run' feature with `(require 'run)'. | + | + ;;; "usercat": SLIB catalog additions for SIMSYNCH. -*-scheme-*- | + ( | + (simsynch . "../synch/simsynch.scm") | + (run . "../synch/run.scm") | + (schlep . "schlep.scm") | + ) | + | +Copying `usercat' to many directories is inconvenient. Application | +programs which aren't always run in specially prepared directories can | +nonetheless register their features during initialization. | + | + - Procedure: catalog:read vicinity catalog | + Reads file named by string CATALOG in VICINITY, resolving all | + paths relative to VICINITY, and adds those feature associations to | + *CATALOG*. | + | + `catalog:read' would typically be used by an application program | + having dynamically loadable modules. For instance, to register | + factoring and other modules in *CATALOG*, JACAL does: | + | + (catalog:read (program-vicinity) "jacalcat") | + | + | +For an application program there are three appropriate venues for | +registering its catalog associations: | + | + * in a `usercat' file in the directory where the program runs; or | + | + * in an `implcat' file in the `implementation-vicinity'; or | + | + * in an application program directory; loaded by calling | + `catalog:read'. | + | + +File: slib.info, Node: Compiling Scheme, Prev: Catalog Vicinities, Up: The Library System + | +Compiling Scheme | ================ -The procedures described in these sections are supported by all -implementations as part of the `*.init' files or by `require.scm'. +To use Scheme compilers effectively with SLIB the compiler needs to | +know which SLIB modules are to be compiled and which symbols are | +exported from those modules. | + | + The procedures in this section automate the extraction of this | +information from SLIB modules. They are guaranteed to work on SLIB | +modules; to use them on other sources, those sources should follow SLIB | +conventions. | * Menu: -* Require:: Module Management -* Vicinity:: Pathname Management -* Configuration:: Characteristics of Scheme Implementation -* Input/Output:: Things not provided by the Scheme specs. -* Legacy:: -* System:: LOADing, EVALing, ERRORing, and EXITing +* Module Conventions:: | +* Module Manifests:: | +* Module Semantics:: | +* Top-level Variable References:: | +* Module Analysis:: | -File: slib.info, Node: Require, Next: Vicinity, Prev: Built-in Support, Up: Built-in Support - -Require -------- - - - Variable: *features* - Is a list of symbols denoting features supported in this - implementation. *FEATURES* can grow as modules are `require'd. - *FEATURES* must be defined by all implementations (*note - Porting::). - - Here are features which SLIB (`require.scm') adds to *FEATURES* - when appropriate. +File: slib.info, Node: Module Conventions, Next: Module Manifests, Prev: Compiling Scheme, Up: Compiling Scheme + | +Module Conventions | +------------------ | - * 'inexact + * All the top-level `require' commands have one quoted argument and | + are positioned before other Scheme definitions and expressions in | + the file. | - * 'rational + * Any conditionally `require'd SLIB modules (1) also appear at the | + beginning of their files conditioned on the feature `compiling' | + using `require-if' (*note require-if: Require.). | - * 'real + (require 'logical) | + (require 'multiarg/and-) | + (require-if 'compiling 'sort) | + (require-if 'compiling 'ciexyz) | - * 'complex + * Schmooz-style comments preceding a definition, identify that | + definition as an exported identifier (*note Schmooz::). For | + non-schmooz files, putting `;@' at the beginning of the line | + immediately preceding the definition (`define', `define-syntax', | + or `defmacro') suffices. | - * 'bignum + ;@ | + (define (make-vicinity <pathname>) <pathname>) | - For each item, `(provided? 'FEATURE)' will return `#t' if that - feature is available, and `#f' if not. + * Syntax (macro) definitions are grouped at the end of a module file. | - - Variable: *modules* - Is a list of pathnames denoting files which have been loaded. + * Modules defining macros do not invoke those macros. SLIB macro | + implementations are exempt from this rule. | - - Variable: *catalog* - Is an association list of features (symbols) and pathnames which - will supply those features. The pathname can be either a string - or a pair. If pathname is a pair then the first element should be - a macro feature symbol, `source', or `compiled'. The cdr of the - pathname should be either a string or a list. + An example of how to expand macro invocations is: | -In the following functions if the argument FEATURE is not a symbol it -is assumed to be a pathname. + (require 'macros-that-work) | + (require 'yasos) | + (require 'pprint-file) | + (pprint-filter-file "collect.scm" macwork:expand) | + | - - Function: provided? feature - Returns `#t' if FEATURE is a member of `*features*' or `*modules*' - or if FEATURE is supported by a file already loaded and `#f' - otherwise. + ---------- Footnotes ---------- | - - Procedure: require feature - FEATURE is a symbol. If `(provided? FEATURE)' is true `require' - returns. Otherwise, if `(assq FEATURE *catalog*)' is not `#f', - the associated files will be loaded and `(provided? FEATURE)' will - henceforth return `#t'. An unspecified value is returned. If - FEATURE is not found in `*catalog*', then an error is signaled. + (1) There are some functions with internal `require' calls to delay | +loading modules until they are needed. While this reduces startup | +latency for interpreters, it can produce headaches for compilers. | - - Procedure: require pathname - PATHNAME is a string. If PATHNAME has not already been given as - an argument to `require', PATHNAME is loaded. An unspecified - value is returned. + +File: slib.info, Node: Module Manifests, Next: Module Semantics, Prev: Module Conventions, Up: Compiling Scheme + | +Module Manifests | +---------------- | - - Procedure: provide feature - Assures that FEATURE is contained in `*features*' if FEATURE is a - symbol and `*modules*' otherwise. +`(require 'manifest)' | - - Function: require:feature->path feature - Returns `#t' if FEATURE is a member of `*features*' or `*modules*' - or if FEATURE is supported by a file already loaded. Returns a - path if one was found in `*catalog*' under the feature name, and - `#f' otherwise. The path can either be a string suitable as an - argument to load or a pair as described above for *catalog*. +In some of these examples, SLIB:CATALOG is the SLIB part of the | +catalog; it is free of compiled and implementation-specific entries. | +It would be defined by: | + | + (define slib:catalog (cdr (member (assq 'null *catalog*) *catalog*))) | + | + - Function: file->requires file provided? catalog | + Returns a list of the features `require'd by FILE assuming the | + predicate PROVIDED? and association-list CATALOG. | + | + (define (provided+? . features) | + (lambda (feature) | + (or (memq feature features) (provided? feature)))) | + | + (file->requires "obj2str.scm" (provided+? 'compiling) '()) | + => (string-port generic-write) | + | + (file->requires "obj2str.scm" provided? '()) | + => (string-port) | + | + - Function: feature->requires feature provided? catalog | + Returns a list of the features `require'd by FEATURE assuming the | + predicate PROVIDED? and association-list CATALOG. | + | + (feature->requires 'batch (provided+? 'compiling) *catalog*) | + => (tree line-i/o databases parameters string-port | + pretty-print common-list-functions posix-time) | + | + (feature->requires 'batch provided? *catalog*) | + => (tree line-i/o databases parameters string-port | + pretty-print common-list-functions) | + | + (feature->requires 'batch provided? '((batch . "batch"))) | + => (tree line-i/o databases parameters string-port | + pretty-print common-list-functions) | + | + - Function: file->loads file | + Returns a list of strings naming existing files loaded (load | + slib:load slib:load-source macro:load defmacro:load syncase:load | + synclo:load macwork:load) by FILE or any of the files it loads. | + | + (file->loads (in-vicinity (library-vicinity) "scainit.scm")) | + => ("/usr/local/lib/slib/scaexpp.scm" | + "/usr/local/lib/slib/scaglob.scm" | + "/usr/local/lib/slib/scaoutp.scm") | + | + - Function: load->path exp | + Given a `(load '<expr>)', where <expr> is a string or vicinity | + stuff), `(load->path <expr>)' figures a path to the file. | + `load->path' returns that path if it names an existing file; | + otherwise #f. | + | + (load->path '(in-vicinity (library-vicinity) "mklibcat")) | + => "/usr/local/lib/slib/mklibcat.scm" | + | + - Function: file->definitions file | + Returns a list of the identifier symbols defined by SLIB (or | + SLIB-style) file FILE. | + | + (file->definitions "random.scm") | + => (*random-state* make-random-state | + seed->random-state copy-random-state random | + random:chunk) | + | + - Function: file->exports file | + Returns a list of the identifier symbols exported (advertised) by | + SLIB (or SLIB-style) file FILE. | + | + (file->exports "random.scm") | + => (make-random-state seed->random-state | + copy-random-state random) | + | + (file->exports "randinex.scm") | + => (random:solid-sphere! random:hollow-sphere! | + random:normal-vector! random:normal | + random:exp random:uniform) | + | + - Function: feature->export-alist feature catalog | + Returns a list of lists; each sublist holding the name of the file | + implementing FEATURE, and the identifier symbols exported | + (advertised) by SLIB (or SLIB-style) feature FEATURE, in CATALOG. | + | + - Function: feature->exports feature catalog | + Returns a list of all exports of FEATURE. | + | +In the case of `aggregate' features, more than one file may have export | +lists to report: | + | + (feature->export-alist 'r5rs slib:catalog)) | + => (("/usr/local/lib/slib/values.scm" | + call-with-values values) | + ("/usr/local/lib/slib/mbe.scm" | + define-syntax macro:expand | + macro:load macro:eval) | + ("/usr/local/lib/slib/eval.scm" | + eval scheme-report-environment | + null-environment interaction-environment)) | + | + (feature->export-alist 'stdio *catalog*) | + => (("/usr/local/lib/slib/scanf.scm" | + fscanf sscanf scanf scanf-read-list) | + ("/usr/local/lib/slib/printf.scm" | + sprintf printf fprintf) | + ("/usr/local/lib/slib/stdio.scm" | + stderr stdout stdin)) | + | + (feature->exports 'stdio slib:catalog) | + => (fscanf sscanf scanf scanf-read-list | + sprintf printf fprintf stderr stdout stdin) | -File: slib.info, Node: Vicinity, Next: Configuration, Prev: Require, Up: Built-in Support - +File: slib.info, Node: Module Semantics, Next: Top-level Variable References, Prev: Module Manifests, Up: Compiling Scheme + | +Module Semantics | +---------------- | + | +For the purpose of compiling Scheme code, each top-level `require' | +makes the identifiers exported by its feature's module `defined' (or | +defmacroed or defined-syntaxed) within the file (being compiled) headed | +with those requires. | + | + Top-level occurrences of `require-if' make defined the exports from | +the module named by the second argument _if_ the FEATURE-EXPRESSION | +first argument is true in the target environment. The target feature | +`compiling' should be provided during this phase of compilation. | + | + Non-top-level SLIB occurences of `require' and `require-if' of quoted | +features can be ignored by compilers. The SLIB modules will all have | +top-level constructs for those features. | + | + Note that aggregate catalog entries import more than one module. | +Implementations of `require' may or may _not_ be transitive; code which | +uses module exports without requiring the providing module is in error. | + | + In the SLIB modules `modular', `batch', `hash', `common-lisp-time', | +`commutative-ring', `charplot', `logical', `common-list-functions', | +`coerce' and `break' there is code conditional on features being | +`provided?'. Most are testing for the presence of features which are | +intrinsic to implementations (inexacts, bignums, ...). | + | + In all cases these `provided?' tests can be evaluated at compile-time | +using `feature-eval' (*note feature-eval: Feature.). The simplest way | +to compile these constructs may be to treat `provided?' as a macro. | + | + +File: slib.info, Node: Top-level Variable References, Next: Module Analysis, Prev: Module Semantics, Up: Compiling Scheme + | +Top-level Variable References | +----------------------------- | + | +`(require 'top-refs)' | + | +These procedures complement those in *Note Module Manifests:: by | +finding the top-level variable references in Scheme source code. They | +work by traversing expressions and definitions, keeping track of | +bindings encountered. It is certainly possible to foil these | +functions, but they return useful information about SLIB source code. | + | + - Function: top-refs obj | + Returns a list of the top-level variables referenced by the Scheme | + expression OBJ. | + | + - Function: top-refs<-file filename | + FILENAME should be a string naming an existing file containing | + Scheme source code. `top-refs<-file' returns a list of the | + top-level variable references made by expressions in the file | + named by FILENAME. | + | + Code in modules which FILENAME `require's is not traversed. Code | + in files loaded from top-level _is_ traversed if the expression | + argument to `load', `slib:load', `slib:load-source', `macro:load', | + `defmacro:load', `synclo:load', `syncase:load', or `macwork:load' | + is a literal string constant or composed of combinations of | + vicinity functions and string literal constants; and the resulting | + file exists (possibly with ".scm" appended). | + | +The following function parses an "Info" Index. (1) | + | + - Function: exports<-info-index file n ... | + N ... must be an increasing series of positive integers. | + `exports<-info-index' returns a list of all the identifiers | + appearing in the Nth ... (info) indexes of FILE. The identifiers | + have the case that the implementation's `read' uses for symbols. | + Identifiers containing spaces (eg. `close-base on base-table') are | + _not_ included. | + | + Each info index is headed by a `* Menu:' line. To list the | + symbols in the first and third info indexes do: | + | + (exports<-info-index "slib.info" 1 3) | + | + ---------- Footnotes ---------- | + | + (1) Although it will work on large info files, feeding it an excerpt | +is much faster; and has less chance of being confused by unusual text | +in the info file. This command excerpts the SLIB index into | +`slib-index.info': | + | + info -f slib2d6.info -n "Index" -o slib-index.info | + | + +File: slib.info, Node: Module Analysis, Prev: Top-level Variable References, Up: Compiling Scheme + | +Module Analysis | +--------------- | + | +`(require 'vet)' | + | + - Function: vet-slib | + Using the procedures in the `top-refs' and `manifest' modules, | + `vet-slib' analyzes each SLIB module, reporting about any | + procedure or macro defined whether it is: | + | + orphaned | + defined, not called, not exported; | + | + missing | + called, not defined, and not exported by its `require'd | + modules; | + | + undocumented-export | + Exported by module, but no index entry in `slib.info'; | + | + | + And for the library as a whole: | + | + documented-unexport | + Index entry in `slib.info', but no module exports it. | + | + | + This straightforward analysis caught three full days worth of | + never-executed branches, transitive require assumptions, spelling | + errors, undocumented procedures, missing procedures, and cyclic | + dependencies in SLIB. | + | + +File: slib.info, Node: Universal SLIB Procedures, Next: Scheme Syntax Extension Packages, Prev: The Library System, Up: Top + | +Universal SLIB Procedures | +************************* | + | +The procedures described in these sections are supported by all | +implementations as part of the `*.init' files or by `require.scm'. | + | +* Menu: | + | +* Vicinity:: Pathname Management | +* Configuration:: Characteristics of Scheme Implementation | +* Input/Output:: Things not provided by the Scheme specs. | +* System:: LOADing, EVALing, ERRORing, and EXITing | +* Miscellany:: | + | + +File: slib.info, Node: Vicinity, Next: Configuration, Prev: Universal SLIB Procedures, Up: Universal SLIB Procedures + | Vicinity --------- +======== | A vicinity is a descriptor for a place in the file system. Vicinities hide from the programmer the concepts of host, volume, directory, and @@ -386,8 +726,14 @@ these procedures are file system dependent. These procedures are provided by all implementations. - - Function: make-vicinity path - Returns the vicinity of PATH for use by `in-vicinity'. + - Function: make-vicinity dirpath + Returns DIRPATH as a vicinity for use as first argument to + `in-vicinity'. + + - Function: pathname->vicinity path + Returns the vicinity containing PATH. + (pathname->vicinity "/usr/local/lib/scm/Link.scm") + => "/usr/local/lib/scm/" - Function: program-vicinity Returns the vicinity of the currently loading Scheme code. For an @@ -417,6 +763,10 @@ These procedures are provided by all implementations. a daemon) or if this concept is meaningless for the platform, then `home-vicinity' returns `#f'. + - Function: vicinity:suffix? chr | + Returns the `#t' if CHR is a vicinity suffix character; and `#f' | + otherwise. Typical vicinity suffixes are `/', `:', and `\', | + | - Function: in-vicinity vicinity filename Returns a filename suitable for use by `slib:load', `slib:load-source', `slib:load-compiled', `open-input-file', @@ -435,10 +785,10 @@ These procedures are provided by all implementations. return a pathname of the subdirectory NAME of VICINITY. -File: slib.info, Node: Configuration, Next: Input/Output, Prev: Vicinity, Up: Built-in Support - +File: slib.info, Node: Configuration, Next: Input/Output, Prev: Vicinity, Up: Universal SLIB Procedures + | Configuration -------------- +============= | These constants and procedures describe characteristics of the Scheme and underlying operating system. They are provided by all @@ -474,7 +824,7 @@ implementations. implementation and the name of the operating system. An unspecified value is returned. - (slib:report-version) => slib "2d2" on scm "5b1" on unix | + (slib:report-version) => slib "3a1" on scm "5b1" on unix | - Function: slib:report Displays the information of `(slib:report-version)' followed by @@ -489,9 +839,9 @@ implementations. (slib:report) => - slib "2d2" on scm "5b1" on unix | - (implementation-vicinity) is "/home/jaffer/scm/" - (library-vicinity) is "/home/jaffer/slib/" + slib "3a1" on scm "5b1" on unix | + (implementation-vicinity) is "/usr/local/lib/scm/" | + (library-vicinity) is "/usr/local/lib/slib/" | (scheme-file-suffix) is ".scm" loaded *features* : trace alist qp sort @@ -501,7 +851,7 @@ implementations. bignum complex real rational inexact vicinity ed getenv tmpnam abort transcript with-file - ieee-p1178 rev4-report rev4-optional-procedures hash + ieee-p1178 r4rs rev4-optional-procedures hash | object-hash delay eval dynamic-wind multiarg-apply multiarg/and- logical defmacro string-port source current-time record @@ -509,32 +859,79 @@ implementations. array dump char-ready? full-continuation system implementation *catalog* : - (i/o-extensions compiled "/home/jaffer/scm/ioext.so") + (i/o-extensions compiled "/usr/local/lib/scm/ioext.so") | ... -File: slib.info, Node: Input/Output, Next: Legacy, Prev: Configuration, Up: Built-in Support - +File: slib.info, Node: Input/Output, Next: System, Prev: Configuration, Up: Universal SLIB Procedures + | Input/Output ------------- +============ | These procedures are provided by all implementations. - - Procedure: file-exists? filename + - Function: file-exists? filename Returns `#t' if the specified file exists. Otherwise, returns `#f'. If the underlying implementation does not support this feature then `#f' is always returned. - - Procedure: delete-file filename + - Function: delete-file filename Deletes the file specified by FILENAME. If FILENAME can not be deleted, `#f' is returned. Otherwise, `#t' is returned. - - Procedure: tmpnam + - Function: open-file filename modes + FILENAME should be a string naming a file. `open-file' returns a + port depending on the symbol MODES: + + r + an input port capable of delivering characters from the file. + + rb + a _binary_ input port capable of delivering characters from + the file. + + w + an output port capable of writing characters to a new file by + that name. + + wb + a _binary_ output port capable of writing characters to a new + file by that name. + + If an implementation does not distinguish between binary and + non-binary files, then it must treat rb as r and wb as w. + + If the file cannot be opened, either #f is returned or an error is + signalled. For output, if a file with the given name already + exists, the effect is unspecified. + + - Function: port? obj + Returns #t if OBJ is an input or output port, otherwise returns #f. + + - Procedure: close-port port + Closes the file associated with PORT, rendering the PORT incapable + of delivering or accepting characters. + + `close-file' has no effect if the file has already been closed. + The value returned is unspecified. + + - Function: call-with-open-ports proc ports ... + - Function: call-with-open-ports ports ... proc + PROC should be a procedure that accepts as many arguments as there + are PORTS passed to `call-with-open-ports'. + `call-with-open-ports' calls PROC with PORTS .... If PROC + returns, then the ports are closed automatically and the value + yielded by the PROC is returned. If PROC does not return, then + the ports will not be closed automatically unless it is possible + to prove that the ports will never again be used for a read or + write operation. + + - Function: tmpnam Returns a pathname for a file which will likely not be used by any other process. Successive calls to `(tmpnam)' will return different pathnames. - - Procedure: current-error-port + - Function: current-error-port Returns the current port to which diagnostic and error output is directed. @@ -545,60 +942,23 @@ These procedures are provided by all implementations. omitted, in which case it defaults to the value returned by `(current-output-port)'. - - Procedure: output-port-width - - Procedure: output-port-width port + - Function: output-port-width + - Function: output-port-width port Returns the width of PORT, which defaults to `(current-output-port)' if absent. If the width cannot be determined 79 is returned. - - Procedure: output-port-height - - Procedure: output-port-height port + - Function: output-port-height + - Function: output-port-height port Returns the height of PORT, which defaults to `(current-output-port)' if absent. If the height cannot be determined 24 is returned. -File: slib.info, Node: Legacy, Next: System, Prev: Input/Output, Up: Built-in Support - -Legacy ------- - - These procedures are provided by all implementations. - - - Function: identity x - IDENTITY returns its argument. - - Example: - (identity 3) - => 3 - (identity '(foo bar)) - => (foo bar) - (map identity LST) - == (copy-list LST) - -The following procedures were present in Scheme until R4RS (*note -Language changes: (r4rs)Notes.). They are provided by all SLIB -implementations. - - - Constant: t - Derfined as `#t'. - - - Constant: nil - Defined as `#f'. - - - Function: last-pair l - Returns the last pair in the list L. Example: - (last-pair (cons 1 2)) - => (1 . 2) - (last-pair '(1 2)) - => (2) - == (cons 2 '()) - - -File: slib.info, Node: System, Prev: Legacy, Up: Built-in Support - +File: slib.info, Node: System, Next: Miscellany, Prev: Input/Output, Up: Universal SLIB Procedures + | System ------- +====== | These procedures are provided by all implementations. @@ -653,26 +1013,93 @@ These procedures are provided by all implementations. the system (if possible). If the Scheme session cannot exit an unspecified value is returned from `slib:exit'. + - Function: browse-url url + Web browsers have become so ubiquitous that programming languagues + should support a uniform interface to them. + + If a `netscape' browser is running, `browse-url' causes the + browser to display the page specified by string URL and returns #t. + + If the browser is not running, `browse-url' starts a browser + displaying the argument URL. If the browser starts as a + background job, `browse-url' returns #t immediately; if the + browser starts as a foreground job, then `browse-url' returns #t + when the browser exits; otherwise it returns #f. + -File: slib.info, Node: About this manual, Prev: Built-in Support, Up: The Library System +File: slib.info, Node: Miscellany, Prev: System, Up: Universal SLIB Procedures + | +Miscellany +========== | -About this manual -================= +These procedures are provided by all implementations. - * Entries that are labeled as Functions are called for their return - values. Entries that are labeled as Procedures are called - primarily for their side effects. + - Function: identity x + IDENTITY returns its argument. - * Examples in this text were produced using the `scm' Scheme - implementation. + Example: + (identity 3) + => 3 + (identity '(foo bar)) + => (foo bar) + (map identity LST) + == (copy-list LST) - * At the beginning of each section, there is a line that looks like - `(require 'feature)'. Include this line in your code prior to - using the package. +Mutual Exclusion +---------------- | - -File: slib.info, Node: Scheme Syntax Extension Packages, Next: Textual Conversion Packages, Prev: The Library System, Up: Top +An "exchanger" is a procedure of one argument regulating mutually +exclusive access to a resource. When a exchanger is called, its current +content is returned, while being replaced by its argument in an atomic +operation. + + - Function: make-exchanger obj + Returns a new exchanger with the argument OBJ as its initial + content. + + (define queue (make-exchanger (list a))) + + A queue implemented as an exchanger holding a list can be + protected from reentrant execution thus: + + (define (pop queue) + (let ((lst #f)) + (dynamic-wind + (lambda () (set! lst (queue #f))) + (lambda () (and lst (not (null? lst)) + (let ((ret (car lst))) + (set! lst (cdr lst)) + ret))) + (lambda () (and lst (queue lst)))))) + + (pop queue) => a + + (pop queue) => #f +Legacy +------ | + +The following procedures were present in Scheme until R4RS (*note +Language changes: (r4rs)Notes.). They are provided by all SLIB +implementations. + + - Constant: t + Derfined as `#t'. + + - Constant: nil + Defined as `#f'. + + - Function: last-pair l + Returns the last pair in the list L. Example: + (last-pair (cons 1 2)) + => (1 . 2) + (last-pair '(1 2)) + => (2) + == (cons 2 '()) + + +File: slib.info, Node: Scheme Syntax Extension Packages, Next: Textual Conversion Packages, Prev: Universal SLIB Procedures, Up: Top + | Scheme Syntax Extension Packages ******************************** @@ -686,7 +1113,7 @@ Scheme Syntax Extension Packages * Syntactic Closures:: 'syntactic-closures * Syntax-Case Macros:: 'syntax-case -Syntax extensions (macros) included with SLIB. | +Syntax extensions (macros) included with SLIB. * Fluid-Let:: 'fluid-let * Yasos:: 'yasos, 'oop, 'collect @@ -697,7 +1124,7 @@ File: slib.info, Node: Defmacro, Next: R4RS Macros, Prev: Scheme Syntax Exten Defmacro ======== - Defmacros are supported by all implementations. +Defmacros are supported by all implementations. - Function: gentemp Returns a new (interned) symbol each time it is called. The symbol @@ -739,7 +1166,7 @@ Defmacro Defmacroexpand -------------- - `(require 'defmacroexpand)' +`(require 'defmacroexpand)' - Function: defmacro:expand* e Returns the result of expanding all defmacros in scheme expression @@ -751,9 +1178,9 @@ File: slib.info, Node: R4RS Macros, Next: Macro by Example, Prev: Defmacro, R4RS Macros =========== - `(require 'macro)' is the appropriate call if you want R4RS -high-level macros but don't care about the low level implementation. If -an SLIB R4RS macro implementation is already loaded it will be used. +`(require 'macro)' is the appropriate call if you want R4RS high-level +macros but don't care about the low level implementation. If an SLIB +R4RS macro implementation is already loaded it will be used. Otherwise, one of the R4RS macros implemetations is loaded. The SLIB R4RS macro implementations support the following uniform @@ -781,7 +1208,7 @@ File: slib.info, Node: Macro by Example, Next: Macros That Work, Prev: R4RS M Macro by Example ================ - `(require 'macro-by-example)' +`(require 'macro-by-example)' A vanilla implementation of `Macro by Example' (Eugene Kohlbecker, R4RS) by Dorai Sitaram, (dorai @ cs.rice.edu) using `defmacro'. @@ -801,7 +1228,7 @@ R4RS) by Dorai Sitaram, (dorai @ cs.rice.edu) using `defmacro'. Caveat ------ - These macros are not referentially transparent (*note Macros: +These macros are not referentially transparent (*note Macros: (r4rs)Macros.). Lexically scoped macros (i.e., `let-syntax' and `letrec-syntax') are not supported. In any case, the problem of referential transparency gains poignancy only when `let-syntax' and @@ -856,7 +1283,7 @@ File: slib.info, Node: Macros That Work, Next: Syntactic Closures, Prev: Macr Macros That Work ================ - `(require 'macros-that-work)' +`(require 'macros-that-work)' `Macros That Work' differs from the other R4RS macro implementations in that it does not expand derived expression types to primitive @@ -889,10 +1316,9 @@ Rees [editors]. To appear in LISP Pointers. Also available as a technical report from the University of Oregon, MIT AI Lab, and Cornell. Macros That Work. Clinger and Rees. POPL '91. - - The supported syntax differs from the R4RS in that vectors are allowed -as patterns and as templates and are not allowed as pattern or template -data. + The supported syntax +differs from the R4RS in that vectors are allowed as patterns and as +templates and are not allowed as pattern or template data. transformer spec ==> (syntax-rules literals rules) @@ -966,10 +1392,11 @@ Variables opened by an ellipsis template pattern variables whose rank is greater than the rank of the ellipsis template. + Restrictions ------------ - No pattern variable appears more than once within a pattern. +No pattern variable appears more than once within a pattern. For every occurrence of a pattern variable within a template, the template rank of the occurrence must be greater than or equal to the @@ -1038,7 +1465,7 @@ File: slib.info, Node: Syntactic Closures, Next: Syntax-Case Macros, Prev: Ma Syntactic Closures ================== - `(require 'syntactic-closures)' +`(require 'syntactic-closures)' - Function: macro:expand expression - Function: synclo:expand expression @@ -1064,19 +1491,18 @@ Syntactic Closure Macro Facility -------------------------------- A Syntactic Closures Macro Facility - by Chris Hanson - 9 November 1991 + This +document describes "syntactic closures", a low-level macro facility for +the Scheme programming language. The facility is an alternative to the +low-level macro facility described in the `Revised^4 Report on Scheme.' +This document is an addendum to that report. - This document describes "syntactic closures", a low-level macro -facility for the Scheme programming language. The facility is an -alternative to the low-level macro facility described in the `Revised^4 -Report on Scheme.' This document is an addendum to that report. - - The syntactic closures facility extends the BNF rule for TRANSFORMER +The syntactic closures facility extends the BNF rule for TRANSFORMER SPEC to allow a new keyword that introduces a low-level macro transformer: + TRANSFORMER SPEC := (transformer EXPRESSION) Additionally, the following procedures are added: @@ -1094,7 +1520,7 @@ compatible with `syntax-rules'. Terminology ........... - This section defines the concepts and data types used by the syntactic +This section defines the concepts and data types used by the syntactic closures facility. * "Forms" are the syntactic entities out of which programs are @@ -1102,6 +1528,7 @@ closures facility. definition, any syntactic keyword, or any syntactic closure. The variable name that appears in a `set!' special form is also a form. Examples of forms: + 17 #t car @@ -1141,7 +1568,7 @@ closures facility. Transformer Definition ...................... - This section describes the `transformer' special form and the +This section describes the `transformer' special form and the procedures `make-syntactic-closure' and `capture-syntactic-environment'. - Syntax: transformer expression @@ -1165,6 +1592,7 @@ procedures `make-syntactic-closure' and `capture-syntactic-environment'. For example, here is a definition of a push macro using `syntax-rules': + (define-syntax push (syntax-rules () ((push item list) @@ -1189,6 +1617,7 @@ procedures `make-syntactic-closure' and `capture-syntactic-environment'. escape procedure. The binding of `exit' is intended to capture free references to `exit' in the body of the loop, so `exit' must be left free when the body is closed: + (define-syntax loop (transformer (lambda (exp env) @@ -1248,6 +1677,7 @@ procedures `make-syntactic-closure' and `capture-syntactic-environment'. An example will make this clear. Suppose we wanted to define a simple `loop-until' keyword equivalent to + (define-syntax loop-until (syntax-rules () ((loop-until id init test return step) @@ -1291,6 +1721,7 @@ procedures `make-syntactic-closure' and `capture-syntactic-environment'. the identifier loop has been added. `capture-syntactic-environment' captures exactly that environment as follows: + (define-syntax loop-until (transformer (lambda (exp env) @@ -1321,6 +1752,7 @@ procedures `make-syntactic-closure' and `capture-syntactic-environment'. A common use of `capture-syntactic-environment' is to get the transformer environment of a macro transformer: + (transformer (lambda (exp env) (capture-syntactic-environment @@ -1330,7 +1762,7 @@ procedures `make-syntactic-closure' and `capture-syntactic-environment'. Identifiers ........... - This section describes the procedures that create and manipulate +This section describes the procedures that create and manipulate identifiers. Previous syntactic closure proposals did not have an identifier data type - they just used symbols. The identifier data type extends the syntactic closures facility to be compatible with the @@ -1339,6 +1771,7 @@ high-level `syntax-rules' facility. As discussed earlier, an identifier is either a symbol or an "alias". An alias is implemented as a syntactic closure whose "form" is an identifier: + (make-syntactic-closure env '() 'a) => an "alias" @@ -1362,6 +1795,7 @@ roles of the substituted input subforms. - Function: identifier? object Returns `#t' if OBJECT is an identifier, otherwise returns `#f'. Examples: + (identifier? 'a) => #t (identifier? (make-syntactic-closure env '() 'a)) @@ -1428,11 +1862,10 @@ roles of the substituted input subforms. Acknowledgements ................ - The syntactic closures facility was invented by Alan Bawden and -Jonathan Rees. The use of aliases to implement `syntax-rules' was -invented by Alan Bawden (who prefers to call them "synthetic names"). -Much of this proposal is derived from an earlier proposal by Alan -Bawden. +The syntactic closures facility was invented by Alan Bawden and Jonathan +Rees. The use of aliases to implement `syntax-rules' was invented by +Alan Bawden (who prefers to call them "synthetic names"). Much of this +proposal is derived from an earlier proposal by Alan Bawden. File: slib.info, Node: Syntax-Case Macros, Next: Fluid-Let, Prev: Syntactic Closures, Up: Scheme Syntax Extension Packages @@ -1440,7 +1873,7 @@ File: slib.info, Node: Syntax-Case Macros, Next: Fluid-Let, Prev: Syntactic C Syntax-Case Macros ================== - `(require 'syntax-case)' +`(require 'syntax-case)' - Function: macro:expand expression - Function: syncase:expand expression @@ -1465,9 +1898,9 @@ Syntax-Case Macros This is version 2.1 of `syntax-case', the low-level macro facility proposed and implemented by Robert Hieb and R. Kent Dybvig. - This version is further adapted by Harald Hanche-Olsen <hanche @ | -imf.unit.no> to make it compatible with, and easily usable with, SLIB. | -Mainly, these adaptations consisted of: | + This version is further adapted by Harald Hanche-Olsen <hanche @ +imf.unit.no> to make it compatible with, and easily usable with, SLIB. +Mainly, these adaptations consisted of: * Removing white space from `expand.pp' to save space in the distribution. This file is not meant for human readers anyway... @@ -1510,7 +1943,7 @@ Gambit). Notes ----- - All R4RS syntactic forms are defined, including `delay'. Along with +All R4RS syntactic forms are defined, including `delay'. Along with `delay' are simple definitions for `make-promise' (into which `delay' expressions expand) and `force'. @@ -1537,12 +1970,14 @@ if there is some incompatibility that is not flagged as such. Send bug reports, comments, suggestions, and questions to Kent Dybvig (dyb @ iuvax.cs.indiana.edu). -Note from maintainer --------------------- +Note from SLIB maintainer | +------------------------- | - Included with the `syntax-case' files was `structure.scm' which -defines a macro `define-structure'. There is no documentation for this -macro and it is not used by any code in SLIB. +`(require 'structure)' | + | + Included with the `syntax-case' files was `structure.scm' which | +defines a macro `define-structure'. I have no documentation for this | +macro; it is not used by any other code in SLIB. | File: slib.info, Node: Fluid-Let, Next: Yasos, Prev: Syntax-Case Macros, Up: Scheme Syntax Extension Packages @@ -1550,7 +1985,7 @@ File: slib.info, Node: Fluid-Let, Next: Yasos, Prev: Syntax-Case Macros, Up: Fluid-Let ========= - `(require 'fluid-let)' +`(require 'fluid-let)' - Syntax: fluid-let `(BINDINGS ...)' FORMS... @@ -1575,7 +2010,7 @@ File: slib.info, Node: Yasos, Prev: Fluid-Let, Up: Scheme Syntax Extension Pa Yasos ===== - `(require 'oop)' or `(require 'yasos)' +`(require 'oop)' or `(require 'yasos)' `Yet Another Scheme Object System' is a simple object system for Scheme based on the paper by Norman Adams and Jonathan Rees: `Object @@ -1677,16 +2112,15 @@ File: slib.info, Node: Setters, Next: Yasos examples, Prev: Yasos interface, Setters ------- - "Setters" implement "generalized locations" for objects associated -with some sort of mutable state. A "getter" operation retrieves a -value from a generalized location and the corresponding setter -operation stores a value into the location. Only the getter is named - -the setter is specified by a procedure call as below. (Dylan uses -special syntax.) Typically, but not necessarily, getters are access -operations to extract values from Yasos objects (*note Yasos::). -Several setters are predefined, corresponding to getters `car', `cdr', -`string-ref' and `vector-ref' e.g., `(setter car)' is equivalent to -`set-car!'. +"Setters" implement "generalized locations" for objects associated with +some sort of mutable state. A "getter" operation retrieves a value +from a generalized location and the corresponding setter operation +stores a value into the location. Only the getter is named - the +setter is specified by a procedure call as below. (Dylan uses special +syntax.) Typically, but not necessarily, getters are access operations +to extract values from Yasos objects (*note Yasos::). Several setters +are predefined, corresponding to getters `car', `cdr', `string-ref' and +`vector-ref' e.g., `(setter car)' is equivalent to `set-car!'. This implementation of setters is similar to that in Dylan(TM) (`Dylan: An object-oriented dynamic language', Apple Computer Eastern @@ -1753,7 +2187,7 @@ Examples ((string? obj) (string-length obj)) ((char? obj) 1) (else - (error "Operation not supported: size" obj)))) + (slib:error "Operation not supported: size" obj)))) (define-predicate cell?) (define-operation (fetch obj)) @@ -1842,13 +2276,14 @@ Textual Conversion Packages * Format:: Common-Lisp Format * Standard Formatted I/O:: Posix printf and scanf * Programs and Arguments:: -* HTML:: +* HTML:: Generating * HTML Tables:: Databases meet HTML * HTTP and CGI:: Serve WWW sites +* Parsing HTML:: 'html-for-each * URI:: Uniform Resource Identifier * Printing Scheme:: Nicely * Time and Date:: -* Vector Graphics:: +* NCBI-DNA:: DNA and protein sequences * Schmooz:: Documentation markup for Scheme programs @@ -1857,7 +2292,7 @@ File: slib.info, Node: Precedence Parsing, Next: Format, Prev: Textual Conver Precedence Parsing ================== - `(require 'precedence-parse)' or `(require 'parse)' +`(require 'precedence-parse)' or `(require 'parse)' This package implements: @@ -1873,13 +2308,14 @@ This package implements: * Menu: * Precedence Parsing Overview:: +* Rule Types:: * Ruleset Definition and Use:: * Token definition:: * Nud and Led Definition:: * Grammar Rule Definition:: -File: slib.info, Node: Precedence Parsing Overview, Next: Ruleset Definition and Use, Prev: Precedence Parsing, Up: Precedence Parsing +File: slib.info, Node: Precedence Parsing Overview, Next: Rule Types, Prev: Precedence Parsing, Up: Precedence Parsing Precedence Parsing Overview --------------------------- @@ -1900,6 +2336,35 @@ This package offers improvements over previous parsers. structure as was parsed when the error occured; The symbol `?' is substituted for missing input. +The notion of "binding power" may be unfamiliar to those accustomed to +BNF grammars. + +When two consecutive objects are parsed, the first might be the prefix +to the second, or the second might be a suffix of the first. Comparing +the left and right binding powers of the two objects decides which way +to interpret them. + +Objects at each level of syntactic grouping have binding powers. + +A syntax tree is not built unless the rules explicitly do so. The call +graph of grammar rules effectively instantiate the sytnax tree. + +The JACAL symbolic math system +(<http://swissnet.ai.mit.edu/~jaffer/JACAL.html>) uses +precedence-parse. Its grammar definitions in the file +`jacal/English.scm' can serve as examples of use. + + ---------- Footnotes ---------- + + (1) How do I know this? I parsed 250kbyte of random input (an e-mail +file) with a non-trivial grammar utilizing all constructs. + + +File: slib.info, Node: Rule Types, Next: Ruleset Definition and Use, Prev: Precedence Parsing Overview, Up: Precedence Parsing + +Rule Types +---------- + Here are the higher-level syntax types and an example of each. Precedence considerations are omitted for clarity. See *Note Grammar Rule Definition:: for full details. @@ -1944,13 +2409,8 @@ Rule Definition:: for full details. set foo bar; delimits the extent of the restfix operator `set'. - ---------- Footnotes ---------- - - (1) How do I know this? I parsed 250kbyte of random input (an e-mail -file) with a non-trivial grammar utilizing all constructs. - -File: slib.info, Node: Ruleset Definition and Use, Next: Token definition, Prev: Precedence Parsing Overview, Up: Precedence Parsing +File: slib.info, Node: Ruleset Definition and Use, Next: Token definition, Prev: Rule Types, Up: Precedence Parsing Ruleset Definition and Use -------------------------- @@ -2064,14 +2524,22 @@ The following convenient constants are provided for use with Is the string consisting of all characters between 0 and 255 for which `char-whitespace?' returns true. +For the purpose of reporting problems in error messages, this package | +keeps track of the "current column". When the column does not simply | +track input characters, `tok:bump-column' can be used to adjust the | +current-column. | + | + - Function: tok:bump-column pos port | + Adds POS to the current-column for input-port PORT. | + | File: slib.info, Node: Nud and Led Definition, Next: Grammar Rule Definition, Prev: Token definition, Up: Precedence Parsing Nud and Led Definition ---------------------- - This section describes advanced features. You can skip this section -on first reading. +This section describes advanced features. You can skip this section on +first reading. The "Null Denotation" (or "nud") of a token is the procedure and arguments applying for that token when "Left", an unclaimed parsed @@ -2300,458 +2768,9 @@ File: slib.info, Node: Format, Next: Standard Formatted I/O, Prev: Precedence Format (version 3.0) ==================== - `(require 'format)' - -* Menu: - -* Format Interface:: -* Format Specification:: - - -File: slib.info, Node: Format Interface, Next: Format Specification, Prev: Format, Up: Format - -Format Interface ----------------- - - - Function: format destination format-string . arguments - An almost complete implementation of Common LISP format description - according to the CL reference book `Common LISP' from Guy L. - Steele, Digital Press. Backward compatible to most of the - available Scheme format implementations. - - Returns `#t', `#f' or a string; has side effect of printing - according to FORMAT-STRING. If DESTINATION is `#t', the output is - to the current output port and `#t' is returned. If DESTINATION - is `#f', a formatted string is returned as the result of the call. - NEW: If DESTINATION is a string, DESTINATION is regarded as the - format string; FORMAT-STRING is then the first argument and the - output is returned as a string. If DESTINATION is a number, the - output is to the current error port if available by the - implementation. Otherwise DESTINATION must be an output port and - `#t' is returned. - - FORMAT-STRING must be a string. In case of a formatting error - format returns `#f' and prints a message on the current output or - error port. Characters are output as if the string were output by - the `display' function with the exception of those prefixed by a - tilde (~). For a detailed description of the FORMAT-STRING syntax - please consult a Common LISP format reference manual. For a test - suite to verify this format implementation load `formatst.scm'. - Please send bug reports to `lutzeb@cs.tu-berlin.de'. - - Note: `format' is not reentrant, i.e. only one `format'-call may - be executed at a time. - - - -File: slib.info, Node: Format Specification, Prev: Format Interface, Up: Format - -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 `formatst.scm'. - - This implementation supports directive parameters and modifiers (`:' -and `@' characters). Multiple parameters must be separated by a comma -(`,'). Parameters can be numerical parameters (positive or negative), -character parameters (prefixed by a quote character (`''), variable -parameters (`v'), number of rest arguments parameter (`#'), empty and -default parameters. Directive characters are case independent. The -general form of a directive is: - -DIRECTIVE ::= ~{DIRECTIVE-PARAMETER,}[:][@]DIRECTIVE-CHARACTER - -DIRECTIVE-PARAMETER ::= [ [-|+]{0-9}+ | 'CHARACTER | v | # ] - -Implemented CL Format Control Directives -........................................ - - Documentation syntax: Uppercase characters represent the corresponding -control directive characters. Lowercase characters represent control -directive parameter descriptions. - -`~A' - Any (print as `display' does). - `~@A' - left pad. - - `~MINCOL,COLINC,MINPAD,PADCHARA' - full padding. - -`~S' - S-expression (print as `write' does). - `~@S' - left pad. - - `~MINCOL,COLINC,MINPAD,PADCHARS' - full padding. - -`~D' - Decimal. - `~@D' - print number sign always. - - `~:D' - print comma separated. - - `~MINCOL,PADCHAR,COMMACHARD' - padding. - -`~X' - Hexadecimal. - `~@X' - print number sign always. - - `~:X' - print comma separated. - - `~MINCOL,PADCHAR,COMMACHARX' - padding. - -`~O' - Octal. - `~@O' - print number sign always. - - `~:O' - print comma separated. - - `~MINCOL,PADCHAR,COMMACHARO' - padding. - -`~B' - Binary. - `~@B' - print number sign always. - - `~:B' - print comma separated. - - `~MINCOL,PADCHAR,COMMACHARB' - padding. - -`~NR' - Radix N. - `~N,MINCOL,PADCHAR,COMMACHARR' - padding. - -`~@R' - print a number as a Roman numeral. - -`~:@R' - print a number as an "old fashioned" Roman numeral. - -`~:R' - print a number as an ordinal English number. - -`~R' - print a number as a cardinal English number. - -`~P' - Plural. - `~@P' - prints `y' and `ies'. - - `~:P' - as `~P but jumps 1 argument backward.' - - `~:@P' - as `~@P but jumps 1 argument backward.' - -`~C' - Character. - `~@C' - prints a character as the reader can understand it (i.e. `#\' - prefixing). - - `~:C' - prints a character as emacs does (eg. `^C' for ASCII 03). - -`~F' - Fixed-format floating-point (prints a flonum like MMM.NNN). - `~WIDTH,DIGITS,SCALE,OVERFLOWCHAR,PADCHARF' - - `~@F' - If the number is positive a plus sign is printed. - -`~E' - Exponential floating-point (prints a flonum like MMM.NNN`E'EE). - `~WIDTH,DIGITS,EXPONENTDIGITS,SCALE,OVERFLOWCHAR,PADCHAR,EXPONENTCHARE' - - `~@E' - If the number is positive a plus sign is printed. - -`~G' - General floating-point (prints a flonum either fixed or - exponential). - `~WIDTH,DIGITS,EXPONENTDIGITS,SCALE,OVERFLOWCHAR,PADCHAR,EXPONENTCHARG' - - `~@G' - If the number is positive a plus sign is printed. - -`~$' - Dollars floating-point (prints a flonum in fixed with signs - separated). - `~DIGITS,SCALE,WIDTH,PADCHAR$' - - `~@$' - If the number is positive a plus sign is printed. - - `~:@$' - A sign is always printed and appears before the padding. - - `~:$' - The sign appears before the padding. - -`~%' - Newline. - `~N%' - print N newlines. - -`~&' - print newline if not at the beginning of the output line. - `~N&' - prints `~&' and then N-1 newlines. - -`~|' - Page Separator. - `~N|' - print N page separators. - -`~~' - Tilde. - `~N~' - print N tildes. - -`~'<newline> - Continuation Line. - `~:'<newline> - newline is ignored, white space left. - - `~@'<newline> - newline is left, white space ignored. - -`~T' - Tabulation. - `~@T' - relative tabulation. - - `~COLNUM,COLINCT' - full tabulation. - -`~?' - Indirection (expects indirect arguments as a list). - `~@?' - extracts indirect arguments from format arguments. - -`~(STR~)' - Case conversion (converts by `string-downcase'). - `~:(STR~)' - converts by `string-capitalize'. - - `~@(STR~)' - converts by `string-capitalize-first'. - - `~:@(STR~)' - converts by `string-upcase'. - -`~*' - Argument Jumping (jumps 1 argument forward). - `~N*' - jumps N arguments forward. - - `~:*' - jumps 1 argument backward. - - `~N:*' - jumps N arguments backward. - - `~@*' - jumps to the 0th argument. - - `~N@*' - jumps to the Nth argument (beginning from 0) - -`~[STR0~;STR1~;...~;STRN~]' - Conditional Expression (numerical clause conditional). - `~N[' - take argument from N. - - `~@[' - true test conditional. - - `~:[' - if-else-then conditional. - - `~;' - clause separator. - - `~:;' - default clause follows. - -`~{STR~}' - Iteration (args come from the next argument (a list)). - `~N{' - at most N iterations. - - `~:{' - args from next arg (a list of lists). - - `~@{' - args from the rest of arguments. - - `~:@{' - args from the rest args (lists). - -`~^' - Up and out. - `~N^' - aborts if N = 0 - - `~N,M^' - aborts if N = M - - `~N,M,K^' - aborts if N <= M <= K - -Not Implemented CL Format Control Directives -............................................ - -`~:A' - print `#f' as an empty list (see below). - -`~:S' - print `#f' as an empty list (see below). - -`~<~>' - Justification. - -`~:^' - (sorry I don't understand its semantics completely) - -Extended, Replaced and Additional Control Directives -.................................................... - -`~MINCOL,PADCHAR,COMMACHAR,COMMAWIDTHD' - -`~MINCOL,PADCHAR,COMMACHAR,COMMAWIDTHX' - -`~MINCOL,PADCHAR,COMMACHAR,COMMAWIDTHO' - -`~MINCOL,PADCHAR,COMMACHAR,COMMAWIDTHB' - -`~N,MINCOL,PADCHAR,COMMACHAR,COMMAWIDTHR' - COMMAWIDTH is the number of characters between two comma - characters. - -`~I' - print a R4RS complex number as `~F~@Fi' with passed parameters for - `~F'. - -`~Y' - Pretty print formatting of an argument for scheme code lists. - -`~K' - Same as `~?.' - -`~!' - Flushes the output if format DESTINATION is a port. - -`~_' - Print a `#\space' character - `~N_' - print N `#\space' characters. - -`~/' - Print a `#\tab' character - `~N/' - print N `#\tab' characters. - -`~NC' - Takes N as an integer representation for a character. No arguments - are consumed. N is converted to a character by `integer->char'. N - must be a positive decimal number. - -`~:S' - Print out readproof. Prints out internal objects represented as - `#<...>' as strings `"#<...>"' so that the format output can always - be processed by `read'. - -`~:A' - Print out readproof. Prints out internal objects represented as - `#<...>' as strings `"#<...>"' so that the format output can always - be processed by `read'. - -`~Q' - Prints information and a copyright notice on the format - implementation. - `~:Q' - prints format version. - -`~F, ~E, ~G, ~$' - may also print number strings, i.e. passing a number as a string - and format it accordingly. - -Configuration Variables -....................... - - Format has some configuration variables at the beginning of -`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. - -FORMAT:SYMBOL-CASE-CONV - Symbols are converted by `symbol->string' so the case type 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'. (default `#f') - -FORMAT:IOBJ-CASE-CONV - As FORMAT:SYMBOL-CASE-CONV but applies for the representation of - implementation internal objects. (default `#f') - -FORMAT:EXPCH - The character prefixing the exponent value in `~E' printing. - (default `#\E') - -Compatibility With Other Format Implementations -............................................... - -SLIB format 2.x: - See `format.doc'. - -SLIB format 1.4: - Downward compatible except for padding support and `~A', `~S', - `~P', `~X' uppercase printing. SLIB format 1.4 uses C-style - `printf' padding support which is completely replaced by the CL - `format' padding style. - -MIT C-Scheme 7.1: - Downward compatible except for `~', which is not documented - (ignores all characters inside the format string up to a newline - character). (7.1 implements `~a', `~s', ~NEWLINE, `~~', `~%', - numerical and variable parameters and `:/@' modifiers in the CL - sense). - -Elk 1.5/2.0: - Downward compatible except for `~A' and `~S' which print in - uppercase. (Elk implements `~a', `~s', `~~', and `~%' (no - directive parameters or modifiers)). - -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 `~a', `~s', `~c', `~%', and `~~' (no directive - parameters or modifiers)). - - This implementation of format is solely useful in the SLIB context -because it requires other components provided by SLIB. +The `format.scm' package was removed because it was not reentrant. | +<http://swissnet.ai.mit.edu/~jaffer/SLIB.FAQ> explains more about | +FORMAT's woes. | File: slib.info, Node: Standard Formatted I/O, Next: Programs and Arguments, Prev: Format, Up: Textual Conversion Packages @@ -2767,7 +2786,7 @@ Standard Formatted I/O stdio ----- - `(require 'stdio)' +`(require 'stdio)' `require's `printf' and `scanf' and additionally defines the symbols: @@ -2786,7 +2805,7 @@ File: slib.info, Node: Standard Formatted Output, Next: Standard Formatted Inp Standard Formatted Output ------------------------- - `(require 'printf)' +`(require 'printf)' - Procedure: printf format arg1 ... - Procedure: fprintf port format arg1 ... @@ -2921,11 +2940,11 @@ Standard Formatted Output Exact Conversions ................. - `b', `B' | - Print an integer as an unsigned binary number. | - | - _Note:_ `%b' and `%B' are SLIB extensions. | - | + `b', `B' + Print an integer as an unsigned binary number. + + _Note:_ `%b' and `%B' are SLIB extensions. + `d', `i' Print an integer as a signed decimal number. `%d' and `%i' are synonymous for output, but are different when used with @@ -2966,6 +2985,7 @@ Inexact Conversions after the number, which is scaled accordingly. `%K' outputs a space between number and prefix, `%k' does not. + Other Conversions ................. @@ -2991,8 +3011,8 @@ Other Conversions `%' Print a literal `%' character. No argument is consumed. It - is an error to specify flags, field width, precision, or type | - modifiers with `%%'. | + is an error to specify flags, field width, precision, or type + modifiers with `%%'. File: slib.info, Node: Standard Formatted Input, Prev: Standard Formatted Output, Up: Standard Formatted I/O @@ -3000,7 +3020,7 @@ File: slib.info, Node: Standard Formatted Input, Prev: Standard Formatted Outp Standard Formatted Input ------------------------ - `(require 'scanf)' +`(require 'scanf)' - Function: scanf-read-list format - Function: scanf-read-list format port @@ -3174,49 +3194,65 @@ File: slib.info, Node: Getopt, Next: Command Line, Prev: Programs and Argumen Getopt ------ - `(require 'getopt)' +`(require 'getopt)' This routine implements Posix command line argument parsing. Notice that returning values through global variables means that `getopt' is _not_ reentrant. + Obedience to Posix format for the `getopt' calls sows confusion. +Passing ARGC and ARGV as arguments while referencing OPTIND as a global +variable leads to strange behavior, especially when the calls to +`getopt' are buried in other procedures. + + Even in C, ARGC can be derived from ARGV; what purpose does it serve +beyond providing an opportunity for ARGV/ARGC mismatch? Just such a +mismatch existed for years in a SLIB `getopt--' example. + + I have removed the ARGC and ARGV arguments to getopt procedures; and +replaced them with a global variable: + + - Variable: *argv* + Define *ARGV* with a list of arguments before calling getopt + procedures. If you don't want the first (0th) element to be + ignored, set *OPTIND* to 0 (after requiring getopt). + - Variable: *optind* Is the index of the current element of the command line. It is initially one. In order to parse a new command line or reparse an - old one, *OPTING* must be reset. + old one, *OPTIND* must be reset. - Variable: *optarg* Is set by getopt to the (string) option-argument of the current option. - - Procedure: getopt argc argv optstring - Returns the next option letter in ARGV (starting from `(vector-ref - argv *optind*)') that matches a letter in OPTSTRING. ARGV is a - vector or list of strings, the 0th of which getopt usually - ignores. ARGC is the argument count, usually the length of ARGV. - OPTSTRING is a string of recognized option characters; if a - character is followed by a colon, the option takes an argument - which may be immediately following it in the string or in the next - element of ARGV. - - *OPTIND* is the index of the next element of the ARGV vector to be - processed. It is initialized to 1 by `getopt.scm', and `getopt' - updates it when it finishes with each element of ARGV. - - `getopt' returns the next option character from ARGV that matches - a character in OPTSTRING, if there is one that matches. If the - option takes an argument, `getopt' sets the variable *OPTARG* to - the option-argument as follows: + - Function: getopt optstring | + Returns the next option letter in *ARGV* (starting from + `(vector-ref argv *optind*)') that matches a letter in OPTSTRING. + *ARGV* is a vector or list of strings, the 0th of which getopt + usually ignores. OPTSTRING is a string of recognized option + characters; if a character is followed by a colon, the option + takes an argument which may be immediately following it in the + string or in the next element of *ARGV*. + + *OPTIND* is the index of the next element of the *ARGV* vector to + be processed. It is initialized to 1 by `getopt.scm', and + `getopt' updates it when it finishes with each element of *ARGV*. + + `getopt' returns the next option character from *ARGV* that + matches a character in OPTSTRING, if there is one that matches. + If the option takes an argument, `getopt' sets the variable + *OPTARG* to the option-argument as follows: * If the option was the last character in the string pointed to - by an element of ARGV, then *OPTARG* contains the next - element of ARGV, and *OPTIND* is incremented by 2. If the - resulting value of *OPTIND* is greater than or equal to ARGC, - this indicates a missing option argument, and `getopt' - returns an error indication. + by an element of *ARGV*, then *OPTARG* contains the next + element of *ARGV*, and *OPTIND* is incremented by 2. If the + resulting value of *OPTIND* is greater than or equal to + `(length *ARGV*)', this indicates a missing option argument, + and `getopt' returns an error indication. * Otherwise, *OPTARG* is set to the string following the option - character in that element of ARGV, and *OPTIND* is + character in that element of *ARGV*, and *OPTIND* is incremented by 1. If, when `getopt' is called, the string `(vector-ref argv @@ -3273,10 +3309,10 @@ _not_ reentrant. (slib:exit) -Getopt- -------- +Getopt-- +-------- - - Function: getopt- argc argv optstring + - Function: `getopt--' optstring | The procedure `getopt--' is an extended version of `getopt' which parses "long option names" of the form `--hold-the-onions' and `--verbosity-level=extreme'. `Getopt--' behaves as `getopt' @@ -3289,20 +3325,19 @@ Getopt- No information is passed to `getopt--' concerning which long options should be accepted or whether such options can take - arguments. If a long option did not have an argument, `*optarg' + arguments. If a long option did not have an argument, `*optarg*' will be set to `#f'. The caller is responsible for detecting and reporting errors. (define opts ":-:b:") - (define argc 5) - (define argv '("foo" "-b9" "--f1" "--2=" "--g3=35234.342" "--")) + (define *argv* '("foo" "-b9" "--f1" "--2=" "--g3=35234.342" "--")) (define *optind* 1) (define *optarg* #f) (require 'qp) (do ((i 5 (+ -1 i))) ((zero? i)) - (define opt (getopt-- argc argv opts)) - (print *optind* opt *optarg*))) + (let ((opt (getopt-- opts))) + (print *optind* opt *optarg*))) -| 2 #\b "9" 3 "f1" #f @@ -3316,7 +3351,7 @@ File: slib.info, Node: Command Line, Next: Parameter lists, Prev: Getopt, Up Command Line ------------ - `(require 'read-command)' +`(require 'read-command)' - Function: read-command port - Function: read-command @@ -3391,7 +3426,7 @@ File: slib.info, Node: Parameter lists, Next: Getopt Parameter lists, Prev: C Parameter lists --------------- - `(require 'parameters)' +`(require 'parameters)' Arguments to procedures in scheme are distinguished from each other by their position in the procedure call. This can be confusing when a @@ -3487,11 +3522,11 @@ File: slib.info, Node: Getopt Parameter lists, Next: Filenames, Prev: Paramet Getopt Parameter lists ---------------------- - `(require 'getopt-parameters)' +`(require 'getopt-parameters)' - - Function: getopt->parameter-list argc argv optnames arities types - aliases desc ... - Returns ARGV converted to a parameter-list. OPTNAMES are the + - Function: getopt->parameter-list optnames arities types aliases desc + ... + Returns *ARGV* converted to a parameter-list. OPTNAMES are the parameter-names. ARITIES and TYPES are lists of symbols corresponding to OPTNAMES. @@ -3516,16 +3551,16 @@ Getopt Parameter lists In all cases, if unclaimed arguments remain after processing, a warning is signaled and #f is returned. - - Function: getopt->arglist argc argv optnames positions arities types + - Function: getopt->arglist optnames positions arities types defaulters checks aliases desc ... - Like `getopt->parameter-list', but converts ARGV to an + Like `getopt->parameter-list', but converts *ARGV* to an argument-list as specified by OPTNAMES, POSITIONS, ARITIES, TYPES, DEFAULTERS, CHECKS, and ALIASES. If the options supplied violate the ARITIES or CHECKS constraints, then a warning is signaled and #f is returned. These `getopt' functions can be used with SLIB relational databases. -For an example, *Note make-command-server: Database Utilities. +For an example, *Note make-command-server: Using Databases. If errors are encountered while processing options, directions for using the options (and argument strings DESC ...) are printed to @@ -3533,9 +3568,8 @@ the options (and argument strings DESC ...) are printed to (begin (set! *optind* 1) + (set! *argv* '("cmd" "-?") (getopt->parameter-list - 2 - '("cmd" "-?") '(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) @@ -3574,7 +3608,7 @@ File: slib.info, Node: Filenames, Next: Batch, Prev: Getopt Parameter lists, Filenames --------- - `(require 'filename)' or `(require 'glob)' +`(require 'filename)' or `(require 'glob)' - Function: filename:match?? pattern - Function: filename:match-ci?? pattern @@ -3601,7 +3635,6 @@ Filenames `-' or `]' may be matched by including it as the first or last character in the set. - - Function: filename:substitute?? pattern template - Function: filename:substitute-ci?? pattern template Returns a function transforming a single string argument according @@ -3622,15 +3655,16 @@ Filenames substrings matched by wildcard specifications will be returned, otherwise TEMPLATE will not be called and `#f' will be returned. - ((filename:substitute?? "scm_[0-9]*.html" "scm5c4_??.htm") - "scm_10.html") - => "scm5c4_10.htm" - ((filename:substitute?? "??" "beg?mid?end") "AZ") - => "begAmidZend" - ((filename:substitute?? "*na*" "?NA?") "banana") - => "banaNA" - ((filename:substitute?? "?*?" (lambda (s1 s2 s3) (string-append s3 s1))) "ABZ") - => "ZA" + ((filename:substitute?? "scm_[0-9]*.html" "scm5c4_??.htm") + "scm_10.html") + => "scm5c4_10.htm" + ((filename:substitute?? "??" "beg?mid?end") "AZ") + => "begAmidZend" + ((filename:substitute?? "*na*" "?NA?") "banana") + => "banaNA" + ((filename:substitute?? "?*?" (lambda (s1 s2 s3) (string-append s3 s1))) | + "ABZ") | + => "ZA" - Function: replace-suffix str old new STR can be a string or a list of strings. Returns a new string @@ -3638,16 +3672,31 @@ Filenames removed and the suffix string NEW appended. If the end of STR does not match OLD, an error is signaled. - (replace-suffix "/usr/local/lib/slib/batch.scm" ".scm" ".c") - => "/usr/local/lib/slib/batch.c" + (replace-suffix "/usr/local/lib/slib/batch.scm" ".scm" ".c") + => "/usr/local/lib/slib/batch.c" + - Function: call-with-tmpnam proc k | + - Function: call-with-tmpnam proc | + Calls PROC with K arguments, strings returned by successive calls | + to `tmpnam'. If PROC returns, then any files named by the | + arguments to PROC are deleted automatically and the value(s) | + yielded by the PROC is(are) returned. K may be ommited, in which | + case it defaults to `1'. | + | + - Function: call-with-tmpnam proc suffix1 ... | + Calls PROC with strings returned by successive calls to `tmpnam', | + each with the corresponding SUFFIX string appended. If PROC | + returns, then any files named by the arguments to PROC are deleted | + automatically and the value(s) yielded by the PROC is(are) | + returned. | + | File: slib.info, Node: Batch, Prev: Filenames, Up: Programs and Arguments Batch ----- - `(require 'batch)' +`(require 'batch)' The batch procedures provide a way to write and execute portable scripts for a variety of operating systems. Each `batch:' procedure takes as @@ -3666,24 +3715,24 @@ currently uses 2 of these: * vms - * amigados + * amigaos * system * *unknown* -`batch.scm' uses 2 enhanced relational tables (*note Database -Utilities::) to store information linking the names of -`operating-system's to `batch-dialect'es. +`batch.scm' uses 2 enhanced relational tables (*note Using Databases::) +to store information linking the names of `operating-system's to +`batch-dialect'es. - Function: batch:initialize! database Defines `operating-system' and `batch-dialect' tables and adds the domain `operating-system' to the enhanced relational database DATABASE. - - Variable: batch:platform + - Variable: *operating-system* Is batch's best guess as to which operating-system it is running - under. `batch:platform' is set to `(software-type)' (*note + under. `*operating-system*' is set to `(software-type)' (*note Configuration::) unless `(software-type)' is `unix', in which case finer distinctions are made. @@ -3785,7 +3834,7 @@ scripts: Here is an example of the use of most of batch's procedures: - (require 'database-utilities) + (require 'databases) (require 'parameters) (require 'batch) (require 'glob) @@ -3794,8 +3843,8 @@ Here is an example of the use of most of batch's procedures: (batch:initialize! batch) (define my-parameters - (list (list 'batch-dialect (os->batch-dialect batch:platform)) - (list 'platform batch:platform) + (list (list 'batch-dialect (os->batch-dialect *operating-system*)) + (list 'operating-system *operating-system*) (list 'batch-port (current-output-port)))) ;gets filled in later (batch:call-with-output-script @@ -3826,7 +3875,7 @@ Here is an example of the use of most of batch's procedures: Produces the file `my-batch': - #!/bin/sh + #! /bin/sh # "my-batch" script created by SLIB/batch Sun Oct 31 18:24:10 1999 # ================ Write file with C program. mv -f hello.c hello.c~ @@ -3857,7 +3906,7 @@ File: slib.info, Node: HTML, Next: HTML Tables, Prev: Programs and Arguments, HTML ==== - `(require 'html-form)' +`(require 'html-form)' - Function: html:atval txt Returns a string with character substitutions appropriate to send @@ -3994,6 +4043,12 @@ HTML Forms delimited list. Apply map `form:delimited' to the list returned by `command->p-specs'. + - Function: html:delimited-list row ... | + Wraps its arguments with delimited-list (`DL' command. | + | + - Function: get-foreign-choices tab | + Returns a list of the `visible-name' or first fields of table TAB. | + | - Function: command->p-specs rdb command-table command The symbol COMMAND-TABLE names a command table in the RDB relational database. The symbol COMMAND names a key in @@ -4014,16 +4069,16 @@ HTML Forms (html:head 'commands) (html:body (sprintf #f "<H2>%s:</H2><BLOCKQUOTE>%s</BLOCKQUOTE>\\n" - (html:plain 'build) - (html:plain ((comtab 'get 'documentation) 'build))) + (html:plain 'build) + (html:plain ((comtab 'get 'documentation) 'build))) (html:form - 'post - (or "http://localhost:8081/buildscm" "/cgi-bin/build.cgi") - (apply html:delimited-list - (apply map form:delimited - (command->p-specs build '*commands* 'build))) - (form:submit 'build) - (form:reset)))) + 'post + (or "http://localhost:8081/buildscm" "/cgi-bin/build.cgi") + (apply html:delimited-list + (apply map form:delimited + (command->p-specs build '*commands* 'build))) + (form:submit 'build) + (form:reset)))) port))) @@ -4032,7 +4087,7 @@ File: slib.info, Node: HTML Tables, Next: HTTP and CGI, Prev: HTML, Up: Text HTML Tables =========== - `(require 'db->html)' +`(require 'db->html)' - Function: html:table options row ... @@ -4116,10 +4171,11 @@ performed. - Function: command:modify-table table-name null-keys update - Function: command:modify-table table-name null-keys Returns procedure (of DB) which returns procedure to modify row of - TABLE-NAME. NULL-KEYS is the list of "null" keys which indicate - that the row is to be deleted. Optional arguments UPDATE, DELETE, - and RETRIEVE default to the `row:update', `row:delete', and - `row:retrieve' of TABLE-NAME in DB. + TABLE-NAME. NULL-KEYS is the list of "null" keys indicating the + row is to be deleted when any matches its corresponding primary + key. Optional arguments UPDATE, DELETE, and RETRIEVE default to + the `row:update', `row:delete', and `row:retrieve' of TABLE-NAME + in DB. - Function: command:make-editable-table rdb table-name arg ... Given TABLE-NAME in RDB, creates parameter and `*command*' tables @@ -4184,16 +4240,16 @@ HTML databases - Function: db->netscape db dir index-filename - Function: db->netscape db dir `db->netscape' is just like `db->html-directory', but calls - `browse-url-netscape' with the uri for the top page after the - pages are created. + `browse-url' with the uri for the top page after the pages are + created. -File: slib.info, Node: HTTP and CGI, Next: URI, Prev: HTML Tables, Up: Textual Conversion Packages +File: slib.info, Node: HTTP and CGI, Next: Parsing HTML, Prev: HTML Tables, Up: Textual Conversion Packages HTTP and CGI ============ - `(require 'http)' or `(require 'cgi)' +`(require 'http)' or `(require 'cgi)' - Function: http:header alist Returns a string containing lines for each element of ALIST; the @@ -4287,12 +4343,79 @@ HTTP and CGI arguments described in its table. -File: slib.info, Node: URI, Next: Printing Scheme, Prev: HTTP and CGI, Up: Textual Conversion Packages +File: slib.info, Node: Parsing HTML, Next: URI, Prev: HTTP and CGI, Up: Textual Conversion Packages + +Parsing HTML +============ + +`(require 'html-for-each)' + + - Function: html-for-each file word-proc markup-proc white-proc + newline-proc + FILE is an input port or a string naming an existing file + containing HTML text. WORD-PROC is a procedure of one argument or + #f. MARKUP-PROC is a procedure of one argument or #f. WHITE-PROC + is a procedure of one argument or #f. NEWLINE-PROC is a procedure + of no arguments or #f. + + `html-for-each' opens and reads characters from port FILE or the + file named by string FILE. Sequential groups of characters are + assembled into strings which are either + + * enclosed by `<' and `>' (hypertext markups or comments); + + * end-of-line; + + * whitespace; or + + * none of the above (words). + + Procedures are called according to these distinctions in order of + the string's occurrence in FILE. + + NEWLINE-PROC is called with no arguments for end-of-line _not + within a markup or comment_. + + WHITE-PROC is called with strings of non-newline whitespace. + + MARKUP-PROC is called with hypertext markup strings (including `<' + and `>'). + + WORD-PROC is called with the remaining strings. + + `html-for-each' returns an unspecified value. + + - Function: html:read-title file limit + - Function: html:read-title file + FILE is an input port or a string naming an existing file + containing HTML text. If supplied, LIMIT must be an integer. + LIMIT defaults to 1000. + + `html:read-title' opens and reads HTML from port FILE or the file + named by string FILE, until reaching the (mandatory) `TITLE' + field. `html:read-title' returns the title string with adjacent + whitespaces collapsed to one space. `html:read-title' returns #f + if the title field is empty, absent, if the first character read + from FILE is not `#\<', or if the end of title is not found within + the first (approximately) LIMIT words. + + - Function: htm-fields htm + HTM is a hypertext markup string. + + If HTM is a (hypertext) comment, then `htm-fields' returns #f. + Otherwise `htm-fields' returns the hypertext element symbol + (created by `string-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. + + +File: slib.info, Node: URI, Next: Printing Scheme, Prev: Parsing HTML, Up: Textual Conversion Packages URI === - `(require 'uri)' +`(require 'uri)' Implements "Uniform Resource Identifiers" (URI) as described in RFC 2396. @@ -4306,6 +4429,9 @@ Implements "Uniform Resource Identifiers" (URI) as described in RFC Returns a Uniform Resource Identifier string from component arguments. + - Function: uri:make-path path | + Returns a URI string combining the components of list PATH. | + | - Function: html:anchor name Returns a string which defines this location in the (HTML) file as NAME. The hypertext `<A HREF="#NAME">' will link to this point. @@ -4329,13 +4455,16 @@ Implements "Uniform Resource Identifiers" (URI) as described in RFC Returns a string specifying the search PROMPT of a document, for inclusion in the HEAD of the document (*note head: HTML.). - - Function: uri->tree uri-reference base-tree ... + - Function: uri->tree uri-reference base-tree + - Function: uri->tree uri-reference Returns a list of 5 elements corresponding to the parts (SCHEME AUTHORITY PATH QUERY FRAGMENT) of string URI-REFERENCE. Elements corresponding to absent parts are #f. The PATH is a list of strings. If the first string is empty, then - the path is absolute; otherwise relative. + the path is absolute; otherwise relative. The optional BASE-TREE + is a tree as returned by `uri->tree'; and is used as the base + address for relative URIs. If the AUTHORITY component is a "Server-based Naming Authority", then it is a list of the USERINFO, HOST, and PORT strings (or #f). @@ -4346,6 +4475,13 @@ Implements "Uniform Resource Identifiers" (URI) as described in RFC => (http "www.ics.uci.edu" ("" "pub" "ietf" "uri" "") #f "Related") + - Function: uri:split-fields txt chr | + Returns a list of TXT split at each occurrence of CHR. CHR does | + not appear in the returned list of strings. | + | + - Function: uri:decode-query query-string + Converts a "URI" encoded QUERY-STRING to a query-alist. + `uric:' prefixes indicate procedures dealing with URI-components. - Function: uric:encode uri-component allows @@ -4359,6 +4495,50 @@ Implements "Uniform Resource Identifiers" (URI) as described in RFC it encodes. This routine is useful for showing URI contents on error pages. + - Function: uri:path->keys path-list ptypes | + PATH-LIST is a path-list as returned by `uri:split-fields'. | + `uri:path->keys' returns a list of items returned by | + `uri:decode-path', coerced to types PTYPES. | + | +File-system Locators and Predicates +----------------------------------- + + - Function: path->uri path + Returns a URI-string for PATH on the local host. + + - Function: absolute-uri? str + Returns #t if STR is an absolute-URI as indicated by a + syntactically valid (per RFC 2396) "scheme"; otherwise returns #f. + + - Function: absolute-path? file-name + Returns #t if FILE-NAME is a fully specified pathname (does not + depend on the current working directory); otherwise returns #f. + + - Function: null-directory? str + Returns #t if changing directory to STR would leave the current + directory unchanged; otherwise returns #f. + + - Function: glob-pattern? str + Returns #t if the string STR contains characters used for + specifying glob patterns, namely `*', `?', or `['. + +Before RFC 2396, the "File Transfer Protocol" (FTP) served a similar +purpose. + + - Function: parse-ftp-address uri + Returns a list of the decoded FTP URI; or #f if indecipherable. + FTP "Uniform Resource Locator", "ange-ftp", and "getit" formats + are handled. The returned list has four elements which are + strings or #f: + + 0. username + + 1. password + + 2. remote-site + + 3. remote-directory + File: slib.info, Node: Printing Scheme, Next: Time and Date, Prev: URI, Up: Textual Conversion Packages @@ -4377,7 +4557,7 @@ File: slib.info, Node: Generic-Write, Next: Object-To-String, Prev: Printing Generic-Write ------------- - `(require 'generic-write)' +`(require 'generic-write)' `generic-write' is a procedure that transforms a Scheme data value (or Scheme program expression) into its textual representation and @@ -4421,7 +4601,7 @@ File: slib.info, Node: Object-To-String, Next: Pretty-Print, Prev: Generic-Wr Object-To-String ---------------- - `(require 'object->string)' +`(require 'object->string)' - Function: object->string obj Returns the textual representation of OBJ as a string. @@ -4436,7 +4616,7 @@ File: slib.info, Node: Pretty-Print, Prev: Object-To-String, Up: Printing Sch Pretty-Print ------------ - `(require 'pretty-print)' +`(require 'pretty-print)' - Procedure: pretty-print obj - Procedure: pretty-print obj port @@ -4522,7 +4702,7 @@ thus can reduce loading time. The following will write into (pprint-filter-file "code.scm" defmacro:expand* "exp-code.scm") -File: slib.info, Node: Time and Date, Next: Vector Graphics, Prev: Printing Scheme, Up: Textual Conversion Packages +File: slib.info, Node: Time and Date, Next: NCBI-DNA, Prev: Printing Scheme, Up: Textual Conversion Packages Time and Date ============= @@ -4559,7 +4739,7 @@ File: slib.info, Node: Time Zone, Next: Posix Time, Prev: Time and Date, Up: Time Zone --------- - (require 'time-zone) +(require 'time-zone) - Data Format: TZ-string POSIX standards specify several formats for encoding time-zone @@ -4641,6 +4821,11 @@ Time Zone made of any timezone at any calendar time. + - Function: tz:std-offset tz | + TZ is a time-zone object. `tz:std-offset' returns the number of | + seconds west of the Prime Meridian timezone TZ is. | + | + | The rest of these procedures and variables are provided for POSIX compatability. Because of shared state they are not thread-safe. @@ -4797,81 +4982,53 @@ Common-Lisp Time match the arguments to `encode-universal-time'. -File: slib.info, Node: Vector Graphics, Next: Schmooz, Prev: Time and Date, Up: Textual Conversion Packages - -Vector Graphics -=============== - -* Menu: - -* Tektronix Graphics Support:: - - -File: slib.info, Node: Tektronix Graphics Support, Prev: Vector Graphics, Up: Vector Graphics - -Tektronix Graphics Support --------------------------- - - _Note:_ The Tektronix graphics support files need more work, and are -not complete. - -Tektronix 4000 Series Graphics -.............................. - - The Tektronix 4000 series graphics protocol gives the user a 1024 by -1024 square drawing area. The origin is in the lower left corner of the -screen. Increasing y is up and increasing x is to the right. - - The graphics control codes are sent over the current-output-port and -can be mixed with regular text and ANSI or other terminal control -sequences. +File: slib.info, Node: NCBI-DNA, Next: Schmooz, Prev: Time and Date, Up: Textual Conversion Packages - - Procedure: tek40:init - - - Procedure: tek40:graphics - - - Procedure: tek40:text - - - Procedure: tek40:linetype linetype - - - Procedure: tek40:move x y - - - Procedure: tek40:draw x y - - - Procedure: tek40:put-text x y str - - - Procedure: tek40:reset - -Tektronix 4100 Series Graphics -.............................. +NCBI-DNA +======== - The graphics control codes are sent over the current-output-port and -can be mixed with regular text and ANSI or other terminal control -sequences. + - Function: ncbi:read-dna-sequence port + Reads the NCBI-format DNA sequence following the word `ORIGIN' + from PORT. - - Procedure: tek41:init + - Function: ncbi:read-file file + Reads the NCBI-format DNA sequence following the word `ORIGIN' + from FILE. - - Procedure: tek41:reset + - Function: mrna<-cdna str + Replaces `T' with `U' in STR - - Procedure: tek41:graphics + - Function: codons<-cdna cdna + Returns a list of three-letter symbol codons comprising the protein + sequence encoded by CDNA starting with its first occurence of + `atg'. - - Procedure: tek41:move x y + - Function: protein<-cdna cdna + Returns a list of three-letter symbols for the protein sequence + encoded by CDNA starting with its first occurence of `atg'. - - Procedure: tek41:draw x y + - Function: p<-cdna cdna + Returns a string of one-letter amino acid codes for the protein + sequence encoded by CDNA starting with its first occurence of + `atg'. - - Procedure: tek41:point x y number + These cDNA count routines provide a means to check the nucleotide +sequence with the `BASE COUNT' line preceding the sequence from NCBI. - - Procedure: tek41:encode-x-y x y + - Function: cdna:base-count cdna + Returns a list of counts of `a', `c', `g', and `t' occurrencing in + CDNA. - - Procedure: tek41:encode-int number + - Function: cdna:report-base-count cdna + Prints the counts of `a', `c', `g', and `t' occurrencing in CDNA. -File: slib.info, Node: Schmooz, Prev: Vector Graphics, Up: Textual Conversion Packages +File: slib.info, Node: Schmooz, Prev: NCBI-DNA, Up: Textual Conversion Packages Schmooz ======= - "Schmooz" is a simple, lightweight markup language for interspersing +"Schmooz" is a simple, lightweight markup language for interspersing Texinfo documentation with Scheme source code. Schmooz does not create the top level Texinfo file; it creates `txi' files which can be imported into the documentation using the Texinfo command `@include'. @@ -4880,20 +5037,20 @@ imported into the documentation using the Texinfo command `@include'. process files. Files containing schmooz documentation should not contain `(require 'schmooz)'. - - Procedure: schmooz filenamescm ... - FILENAMEscm should be a string ending with `scm' naming an + - Procedure: schmooz filename.scm ... + FILENAME.scm should be a string ending with `.scm' naming an existing file containing Scheme source code. `schmooz' extracts - top-level comments containing schmooz commands from FILENAMEscm + top-level comments containing schmooz commands from FILENAME.scm and writes the converted Texinfo source to a file named - FILENAMEtxi. + FILENAME.txi. - - Procedure: schmooz filenametexi ... - - Procedure: schmooz filenametex ... - - Procedure: schmooz filenametxi ... + - Procedure: schmooz filename.texi ... + - Procedure: schmooz filename.tex ... + - Procedure: schmooz filename.txi ... FILENAME should be a string naming an existing file containing Texinfo source code. For every occurrence of the string `@include - FILENAMEtxi' within that file, `schmooz' calls itself with the - argument `FILENAMEscm'. + FILENAME.txi' within that file, `schmooz' calls itself with the + argument `FILENAME.scm'. Schmooz comments are distinguished (from non-schmooz comments) by their first line, which must start with an at-sign (@) preceded by one @@ -4977,12 +5134,14 @@ Mathematical Packages * Prime Numbers:: 'factor * Random Numbers:: 'random * Fast Fourier Transform:: 'fft -* Cyclic Checksum:: 'make-crc -* Plotting:: 'charplot +* Cyclic Checksum:: 'crc +* Graphing:: | +* Solid Modeling:: VRML97 +* Color:: * Root Finding:: 'root * Minimizing:: 'minimize * Commutative Rings:: 'commutative-ring -* Determinant:: 'determinant +* Matrix Algebra:: 'determinant File: slib.info, Node: Bit-Twiddling, Next: Modular Arithmetic, Prev: Mathematical Packages, Up: Mathematical Packages @@ -4990,9 +5149,9 @@ File: slib.info, Node: Bit-Twiddling, Next: Modular Arithmetic, Prev: Mathema Bit-Twiddling ============= - `(require 'logical)' +`(require 'logical)' - The bit-twiddling functions are made available through the use of the +The bit-twiddling functions are made available through the use of the `logical' package. `logical' is loaded by inserting `(require 'logical)' before the code that uses these functions. These functions behave as though operating on integers in two's-complement @@ -5085,14 +5244,14 @@ Bit Within Word Fields of Bits -------------- + - Function: logical:ones n | + Returns the smallest non-negative integer having N binary ones. | + | - Function: bit-field n start end Returns the integer composed of the START (inclusive) through END (exclusive) bits of N. The STARTth bit becomes the 0-th bit in the result. - - This function was called `bit-extract' in previous versions of - SLIB. - + | Example: (number->string (bit-field #b1101101010 0 4) 2) => "1010" @@ -5111,8 +5270,8 @@ Fields of Bits (number->string (copy-bit-field #b1101101010 0 4 -1) 2) => "1101101111" - - Function: ash int count - Returns an integer equivalent to `(inexact->exact (floor (* INT + - Function: ash n count + Returns an integer equivalent to `(inexact->exact (floor (* N (expt 2 COUNT))))'. Example: @@ -5141,13 +5300,117 @@ Fields of Bits (integer-expt -3 3) => -27 +Bit order and Lamination +------------------------ + + - Function: logical:rotate k count len + Returns the low-order LEN bits of K cyclically permuted COUNT bits + towards high-order. + + Example: + (number->string (logical:rotate #b0100 3 4) 2) + => "10" + (number->string (logical:rotate #b0100 -1 4) 2) + => "10" + + - Function: bit-reverse k n + Returns the low-order K bits of N with the bit order reversed. + The low-order bit of N is the high order bit of the returned value. + + (number->string (bit-reverse 8 #xa7) 16) + => "e5" + + - Function: integer->list k len + - Function: integer->list k + `integer->list' returns a list of LEN booleans corresponding to + each bit of the given integer. #t is coded for each 1; #f for 0. + The LEN argument defaults to `(integer-length K)'. + + - Function: list->integer list + `list->integer' returns an integer formed from the booleans in the + list LIST, which must be a list of booleans. A 1 bit is coded for + each #t; a 0 bit for #f. + + `integer->list' and `list->integer' are inverses so far as + `equal?' is concerned. + + - Function: booleans->integer bool1 ... + Returns the integer coded by the BOOL1 ... arguments. + + - Function: bitwise:laminate k1 ... + Returns an integer composed of the bits of K1 ... interlaced in + argument order. Given K1, ... KN, the n low-order bits of the + returned value will be the lowest-order bit of each argument. + + - Function: bitwise:delaminate count k + Returns a list of COUNT integers comprised of every COUNTh bit of + the integer K. + + For any non-negative integers K and COUNT: + (eqv? k (bitwise:laminate (bitwise:delaminate count k))) + +Gray code +--------- + +A "Gray code" is an ordering of non-negative integers in which exactly +one bit differs between each pair of successive elements. There are +multiple Gray codings. An n-bit Gray code corresponds to a Hamiltonian +cycle on an n-dimensional hypercube. + +Gray codes find use communicating incrementally changing values between +asynchronous agents. De-laminated Gray codes comprise the coordinates +of Peano-Hilbert space-filling curves. + + - Function: integer->gray-code k + Converts K to a Gray code of the same `integer-length' as K. + + - Function: gray-code->integer k + Converts the Gray code K to an integer of the same + `integer-length' as K. + + For any non-negative integer K, + (eqv? k (gray-code->integer (integer->gray-code k))) + + - Function: = k1 k2 + - Function: gray-code<? k1 k2 + - Function: gray-code>? k1 k2 + - Function: gray-code<=? k1 k2 + - Function: gray-code>=? k1 k2 + These procedures return #t if their Gray code arguments are + (respectively): equal, monotonically increasing, monotonically + decreasing, monotonically nondecreasing, or monotonically + nonincreasing. + + For any non-negative integers K1 and K2, the Gray code predicate + of `(integer->gray-code k1)' and `(integer->gray-code k2)' will + return the same value as the corresponding predicate of K1 and K2. + File: slib.info, Node: Modular Arithmetic, Next: Prime Numbers, Prev: Bit-Twiddling, Up: Mathematical Packages Modular Arithmetic ================== - `(require 'modular)' +`(require 'modular)' + + - Function: mod x1 x2 + - Function: rem x1 x2 + These procedures implement the Common-Lisp functions of the same + names. The real number X2 must be non-zero. `mod' returns `(- X1 + (* X2 (floor (/ X1 X2))))'. `rem' returns `(- X1 (* X2 (truncate + (/ X1 X2))))'. + + If X1 and X2 are integers, then `mod' behaves like `modulo' and + `rem' behaves like `remainder'. + + (mod -90 360) => 270 + (rem -90 180) => -90 + + (mod 540 360) => 180 + (rem 540 360) => 180 + + (mod (* 5/2 pi) (* 2 pi)) => 1.5707963267948965 + (rem (* -5/2 pi) (* 2 pi)) => -1.5707963267948965 - Function: extended-euclid n1 n2 Returns a list of 3 integers `(d x y)' such that d = gcd(N1, N2) = @@ -5185,27 +5448,27 @@ If all the arguments are fixnums the computation will use only fixnums. Returns `#t' if there exists an integer n such that K * n == 1 mod MODULUS, and `#f' otherwise. - - Function: modular:invert modulus k2 - Returns an integer n such that 1 = (n * K2) mod MODULUS. If K2 + - Function: modular:invert modulus n2 + Returns an integer n such that 1 = (n * N2) mod MODULUS. If N2 has no inverse mod MODULUS an error is signaled. - - Function: modular:negate modulus k2 - Returns (-K2) mod MODULUS. + - Function: modular:negate modulus n2 + Returns (-N2) mod MODULUS. - - Function: modular:+ modulus k2 k3 - Returns (K2 + K3) mod MODULUS. + - Function: modular:+ modulus n2 n3 + Returns (N2 + N3) mod MODULUS. - - Function: modular:- modulus k2 k3 - Returns (K2 - K3) mod MODULUS. + - Function: modular:- modulus n2 n3 + Returns (N2 - N3) mod MODULUS. - - Function: modular:* modulus k2 k3 - Returns (K2 * K3) mod MODULUS. + - Function: modular:* modulus n2 n3 + Returns (N2 * N3) mod MODULUS. The Scheme code for `modular:*' with negative MODULUS is not completed for fixnum-only implementations. - - Function: modular:expt modulus k2 k3 - Returns (K2 ^ K3) mod MODULUS. + - Function: modular:expt modulus n2 n3 + Returns (N2 ^ N3) mod MODULUS. File: slib.info, Node: Prime Numbers, Next: Random Numbers, Prev: Modular Arithmetic, Up: Mathematical Packages @@ -5213,7 +5476,7 @@ File: slib.info, Node: Prime Numbers, Next: Random Numbers, Prev: Modular Ari Prime Numbers ============= - `(require 'factor)' +`(require 'factor)' - Variable: prime:prngs PRIME:PRNGS is the random-state (*note Random Numbers::) used by @@ -5258,24 +5521,34 @@ File: slib.info, Node: Random Numbers, Next: Fast Fourier Transform, Prev: Pr Random Numbers ============== - `(require 'random)' - - A pseudo-random number generator is only as good as the tests it -passes. George Marsaglia of Florida State University developed a -battery of tests named "DIEHARD" -(<http://stat.fsu.edu/~geo/diehard.html>). `diehard.c' has a bug which -the patch +A pseudo-random number generator is only as good as the tests it passes. | +George Marsaglia of Florida State University developed a battery of | +tests named "DIEHARD" (<http://stat.fsu.edu/~geo/diehard.html>). | +`diehard.c' has a bug which the patch | <http://swissnet.ai.mit.edu/ftpdir/users/jaffer/diehard.c.pat> corrects. - SLIB's new PRNG generates 8 bits at a time. With the degenerate seed + SLIB's PRNG generates 8 bits at a time. With the degenerate seed | `0', the numbers generated pass DIEHARD; but when bits are combined from sequential bytes, tests fail. With the seed `http://swissnet.ai.mit.edu/~jaffer/SLIB.html', all of those tests pass. - - Function: random n +* Menu: | + | +* Exact Random Numbers:: 'random | +* Inexact Random Numbers:: 'random-inexact | + | + +File: slib.info, Node: Exact Random Numbers, Next: Inexact Random Numbers, Prev: Random Numbers, Up: Random Numbers + | +Exact Random Numbers | +-------------------- | + | +`(require 'random)' | + | - Function: random n state - Accepts a positive integer or real N and returns a number of the - same type between zero (inclusive) and N (exclusive). The values + - Function: random n | + N must be an exact positive integer. `random' returns an exact | + integer between zero (inclusive) and N (exclusive). The values | returned by `random' are uniformly distributed from 0 to N. The optional argument STATE must be of the type returned by @@ -5316,9 +5589,13 @@ from sequential bytes, tests fail. With the seed representation will be used as the seed. Otherwise the value of `*random-state*' is used as the seed. - If inexact numbers are supported by the Scheme implementation, -`randinex.scm' will be loaded as well. `randinex.scm' contains -procedures for generating inexact distributions. + +File: slib.info, Node: Inexact Random Numbers, Prev: Exact Random Numbers, Up: Random Numbers + | +Inexact Random Numbers | +---------------------- | + | +`(require 'random-inexact)' | - Function: random:uniform - Function: random:uniform state @@ -5337,21 +5614,21 @@ procedures for generating inexact distributions. standard deviation 1. For a normal distribution with mean M and standard deviation D use `(+ M (* D (random:normal)))'. - - Function: random:normal-vector! vect - - Function: random:normal-vector! vect state + - Procedure: random:normal-vector! vect | + - Procedure: random:normal-vector! vect state | Fills VECT with inexact real random numbers which are independent and standard normally distributed (i.e., with mean 0 and variance 1). - - Function: random:hollow-sphere! vect - - Function: random:hollow-sphere! vect state + - Procedure: random:hollow-sphere! vect | + - Procedure: random:hollow-sphere! vect state | Fills VECT with inexact real random numbers the sum of whose squares is equal to 1.0. Thinking of VECT as coordinates in space of dimension n = `(vector-length VECT)', the coordinates are uniformly distributed over the surface of the unit n-shere. - - Function: random:solid-sphere! vect - - Function: random:solid-sphere! vect state + - Procedure: random:solid-sphere! vect | + - Procedure: random:solid-sphere! vect state | Fills VECT with inexact real random numbers the sum of whose squares is less than 1.0. Thinking of VECT as coordinates in space of dimension N = `(vector-length VECT)', the coordinates are @@ -5364,7 +5641,7 @@ File: slib.info, Node: Fast Fourier Transform, Next: Cyclic Checksum, Prev: R Fast Fourier Transform ====================== - `(require 'fft)' +`(require 'fft)' - Function: fft array ARRAY is an array of `(expt 2 n)' numbers. `fft' returns an array @@ -5375,7 +5652,7 @@ Fast Fourier Transform `fft-1' returns an array of complex numbers comprising the inverse Discrete Fourier Transform of ARRAY. - `(fft-1 (fft ARRAY))' will return an array of values close to ARRAY. +`(fft-1 (fft ARRAY))' will return an array of values close to ARRAY. (fft '#(1 0+i -1 0-i 1 0+i -1 0-i)) => @@ -5388,126 +5665,2098 @@ Fast Fourier Transform 1.0 -61.23031769111886e-18+1.0i -1.0 61.23031769111886e-18-1.0i) -File: slib.info, Node: Cyclic Checksum, Next: Plotting, Prev: Fast Fourier Transform, Up: Mathematical Packages - +File: slib.info, Node: Cyclic Checksum, Next: Graphing, Prev: Fast Fourier Transform, Up: Mathematical Packages + | Cyclic Checksum =============== - `(require 'make-crc)' +`(require 'crc)' + +Cyclic Redundancy Checks using Galois field GF(2) polynomial arithmetic +are used for error detection in many data transmission and storage +applications. + +The generator polynomials for various CRC protocols are availble from +many sources. But the polynomial is just one of many parameters which +must match in order for a CRC implementation to interoperate with +existing systems: + + * the byte-order and bit-order of the data stream; + + * whether the CRC or its inverse is being calculated; + + * the initial CRC value; and + + * whether and where the CRC value is appended (inverted or + non-inverted) to the data stream. + + +There is even some controversy over the polynomials themselves. + + - Constant: crc-32-polynomial + For CRC-32, http://www2.sis.pitt.edu/~jkabara/tele-2100/lect08.html + gives x^32+x^26+x^23+x^16+x^12+x^11+x^10+x^8+x^7+x^5+x^4+x^2+x^1+1. + + But + http://www.cs.ncl.ac.uk/people/harry.whitfield/home.formal/CRCs.html, + http://duchon.umuc.edu/Web_Pages/duchon/99_f_cm435/ShiftRegister.htm, + http://spinroot.com/spin/Doc/Book91_PDF/ch3.pdf, + http://www.erg.abdn.ac.uk/users/gorry/course/dl-pages/crc.html, + http://www.rad.com/networks/1994/err_con/crc_most.htm, and + http://www.gpfn.sk.ca/~rhg/csc8550s02/crc.html, + http://www.nobugconsulting.ro/crc.php give + x^32+x^26+x^23+x^22+x^16+x^12+x^11+x^10+x^8+x^7+x^5+x^4+x^2+x+1. + + SLIB `crc-32-polynomial' uses the latter definition. | + + - Constant: crc-ccitt-polynomial + http://www.math.grin.edu/~rebelsky/Courses/CS364/2000S/Outlines/outline.12.html, + http://duchon.umuc.edu/Web_Pages/duchon/99_f_cm435/ShiftRegister.htm, + http://www.cs.ncl.ac.uk/people/harry.whitfield/home.formal/CRCs.html, + http://www2.sis.pitt.edu/~jkabara/tele-2100/lect08.html, and + http://www.gpfn.sk.ca/~rhg/csc8550s02/crc.html give CRC-CCITT: + x^16+x^12+x^5+1. + + - Constant: crc-16-polynomial + http://www.math.grin.edu/~rebelsky/Courses/CS364/2000S/Outlines/outline.12.html, + http://duchon.umuc.edu/Web_Pages/duchon/99_f_cm435/ShiftRegister.htm, + http://www.cs.ncl.ac.uk/people/harry.whitfield/home.formal/CRCs.html, + http://www.gpfn.sk.ca/~rhg/csc8550s02/crc.html, and + http://www.usb.org/developers/data/crcdes.pdf give CRC-16: + x^16+x^15+x^2+1. - - Function: make-port-crc - - Function: make-port-crc degree - Returns an expression for a procedure of one argument, a port. - This procedure reads characters from the port until the end of - file and returns the integer checksum of the bytes read. + - Constant: crc-12-polynomial + http://www.math.grin.edu/~rebelsky/Courses/CS364/2000S/Outlines/outline.12.html, + http://www.cs.ncl.ac.uk/people/harry.whitfield/home.formal/CRCs.html, + http://www.it.iitb.ac.in/it605/lectures/link/node4.html, and + http://spinroot.com/spin/Doc/Book91_PDF/ch3.pdf give CRC-12: + x^12+x^11+x^3+x^2+1. - The integer DEGREE, if given, specifies the degree of the - polynomial being computed - which is also the number of bits - computed in the checksums. The default value is 32. + But + http://www.ffldusoe.edu/Faculty/Denenberg/Topics/Networks/Error_Detection_Correction/crc.html, + http://duchon.umuc.edu/Web_Pages/duchon/99_f_cm435/ShiftRegister.htm, + http://www.eng.uwi.tt/depts/elec/staff/kimal/errorcc.html, + http://www.ee.uwa.edu.au/~roberto/teach/itc314/java/CRC/, + http://www.gpfn.sk.ca/~rhg/csc8550s02/crc.html, and + http://www.efg2.com/Lab/Mathematics/CRC.htm give CRC-12: + x^12+x^11+x^3+x^2+x+1. - - Function: make-port-crc generator - The integer GENERATOR specifies the polynomial being computed. - The power of 2 generating each 1 bit is the exponent of a term of - the polynomial. The value of GENERATOR must be larger than 127. + These differ in bit 1 and calculations using them return different + values. With citations near evenly split, it is hard to know | + which is correct. | - - Function: make-port-crc degree generator - The integer GENERATOR specifies the polynomial being computed. - The power of 2 generating each 1 bit is the exponent of a term of - the polynomial. The bit at position DEGREE is implicit and should - not be part of GENERATOR. This allows systems with numbers - limited to 32 bits to calculate 32 bit checksums. The default - value of GENERATOR when DEGREE is 32 (its default) is: + - Constant: crc-10-polynomial + http://www.math.grin.edu/~rebelsky/Courses/CS364/2000S/Outlines/outline.12.html + gives CRC-10: x^10+x^9+x^5+x^4+1; but + http://cell-relay.indiana.edu/cell-relay/publications/software/CRC/crc10.html, + http://www.it.iitb.ac.in/it605/lectures/link/node4.html, + http://www.gpfn.sk.ca/~rhg/csc8550s02/crc.html, + http://www.techfest.com/networking/atm/atm.htm, + http://www.protocols.com/pbook/atmcell2.htm, and + http://www.nobugconsulting.ro/crc.php give CRC-10: + x^10+x^9+x^5+x^4+x+1. - (make-port-crc 32 #b00000100110000010001110110110111) + - Constant: crc-08-polynomial + http://www.math.grin.edu/~rebelsky/Courses/CS364/2000S/Outlines/outline.12.html, + http://www.cs.ncl.ac.uk/people/harry.whitfield/home.formal/CRCs.html, + http://www.it.iitb.ac.in/it605/lectures/link/node4.html, and + http://www.nobugconsulting.ro/crc.php give CRC-8: x^8+x^2+x^1+1 - Creates a procedure to calculate the P1003.2/D11.2 (POSIX.2) 32-bit - checksum from the polynomial: + - Constant: atm-hec-polynomial + http://cell-relay.indiana.edu/cell-relay/publications/software/CRC/32bitCRC.tutorial.html + and http://www.gpfn.sk.ca/~rhg/csc8550s02/crc.html give ATM HEC: + x^8+x^2+x+1. - 32 26 23 22 16 12 11 - ( x + x + x + x + x + x + x + - - 10 8 7 5 4 2 1 - x + x + x + x + x + x + x + 1 ) mod 2 + - Constant: dowcrc-polynomial + http://www.cs.ncl.ac.uk/people/harry.whitfield/home.formal/CRCs.html + gives DOWCRC: x^8+x^5+x^4+1. - (require 'make-crc) - (define crc32 (slib:eval (make-port-crc))) - (define (file-check-sum file) (call-with-input-file file crc32)) - (file-check-sum (in-vicinity (library-vicinity) "ratize.scm")) - - => 157103930 + - Constant: usb-token-polynomial + http://www.usb.org/developers/data/crcdes.pdf and + http://www.nobugconsulting.ro/crc.php give USB-token: x^5+x^2+1. - -File: slib.info, Node: Plotting, Next: Root Finding, Prev: Cyclic Checksum, Up: Mathematical Packages +Each of these polynomial constants is a string of `1's and `0's, the +exponent of each power of X in descending order. + + - Function: crc:make-table poly + POLY must be string of `1's and `0's beginning with `1' and having + length greater than 8. `crc:make-table' returns a vector of 256 + integers, such that: + + (set! CRC + (logxor (ash (logand (+ -1 (ash 1 (- DEG 8))) CRC) 8) + (vector-ref CRC-TABLE + (logxor (ash CRC (- 8 DEG)) BYTE)))) + + will compute the CRC with the 8 additional bits in BYTE; where CRC + is the previous accumulated CRC value, DEG is the degree of POLY, + and CRC-TABLE is the vector returned by `crc:make-table'. + + If the implementation does not support DEG-bit integers, then + `crc:make-table' returns #f. + + + - Function: cksum file + Computes the P1003.2/D11.2 (POSIX.2) 32-bit checksum of FILE. + + (require 'crc) + (cksum (in-vicinity (library-vicinity) "ratize.scm")) + => 157103930 + + - Function: cksum port + Computes the checksum of the bytes read from PORT until the + end-of-file. + + +`cksum-string', which returns the P1003.2/D11.2 (POSIX.2) 32-bit | +checksum of the bytes in STR, can be defined as follows: | + + (require 'string-port) | + (define (cksum-string str) (call-with-input-string str cksum)) | -Plotting on Character Devices -============================= + - Function: crc16 file + Computes the USB data-packet (16-bit) CRC of FILE. - `(require 'charplot)' + - Function: crc16 port + Computes the USB data-packet (16-bit) CRC of the bytes read from + PORT until the end-of-file. - The plotting procedure is made available through the use of the -`charplot' package. `charplot' is loaded by inserting `(require -'charplot)' before the code that uses this procedure. + `crc16' calculates the same values as the crc16.pl program given + in http://www.usb.org/developers/data/crcdes.pdf. - - Variable: charplot:height - The number of rows to make the plot vertically. - - Variable: charplot:width - The number of columns to make the plot horizontally. + - Function: crc5 file + Computes the USB token (5-bit) CRC of FILE. - - Procedure: plot! coords x-label y-label - COORDS is a list of pairs of x and y coordinates. X-LABEL and - Y-LABEL are strings with which to label the x and y axes. + - Function: crc5 port + Computes the USB token (5-bit) CRC of the bytes read from PORT + until the end-of-file. + + `crc5' calculates the same values as the crc5.pl program given in + http://www.usb.org/developers/data/crcdes.pdf. + + + +File: slib.info, Node: Graphing, Next: Solid Modeling, Prev: Cyclic Checksum, Up: Mathematical Packages + | +Graphing | +======== + +* Menu: | + | +* Character Plotting:: | +* PostScript Graphing:: | + | + +File: slib.info, Node: Character Plotting, Next: PostScript Graphing, Prev: Graphing, Up: Graphing + | +Character Plotting | +------------------ | + | +`(require 'charplot)' + + - Variable: charplot:dimensions + A list of the maximum height (number of lines) and maximum width + (number of columns) for the graph, its scales, and labels. + + The default value for CHARPLOT:DIMENSIONS is the + `output-port-height' and `output-port-width' of + `current-output-port'. + + - Procedure: plot coords x-label y-label + COORDS is a list or vector of coordinates, lists of x and y + coordinates. X-LABEL and Y-LABEL are strings with which to label + the x and y axes. Example: (require 'charplot) - (set! charplot:height 19) - (set! charplot:width 45) + (set! charplot:dimensions '(20 55)) (define (make-points n) (if (zero? n) '() - (cons (cons (/ n 6) (sin (/ n 6))) (make-points (1- n))))) + (cons (list (/ n 6) (sin (/ n 6))) (make-points (1- n))))) - (plot! (make-points 37) "x" "Sin(x)") + (plot (make-points 40) "x" "Sin(x)") -| - Sin(x) ______________________________________________ - 1.25|- | - | | - 1|- **** | - | ** ** | - 0.75|- * * | - | * * | - 0.5|- * * | - | * | - 0.25|- * | - | * * | - 0|-------------------*--------------------------| - | * | - -0.25|- * * | - | * * | - -0.5|- * | - | * * | - -0.75|- * * | - | ** ** | - -1|- **** | - |____________:_____._____:_____._____:_________| - x 2 4 6 - - - Procedure: plot-function! func x1 x2 - - Procedure: plot-function! func x1 x2 npts + Sin(x) _________________________________________ + 1|- **** | + | ** ** | + 0.75|- * * | + | * * | + 0.5|- * * | + | * *| + 0.25|- * * | + | * * | + 0|-------------------*------------------*--| + | * | + -0.25|- * * | + | * * | + -0.5|- * | + | * * | + -0.75|- * * | + | ** ** | + -1|- **** | + |:_____._____:_____._____:_____._____:____| + x 2 4 6 + + - Procedure: plot func x1 x2 + - Procedure: plot func x1 x2 npts Plots the function of one argument FUNC over the range X1 to X2. If the optional integer argument NPTS is supplied, it specifies the number of points to evaluate FUNC at. + (plot sin 0 (* 2 pi)) + -| + _________________________________________ + 1|-: **** | + | : ** ** | + 0.75|-: * * | + | : * * | + 0.5|-: ** ** | + | : * * | + 0.25|-:** ** | + | :* * | + 0|-*------------------*--------------------| + | : * * | + -0.25|-: ** ** | + | : * * | + -0.5|-: * ** | + | : * * | + -0.75|-: * ** | + | : ** ** | + -1|-: **** | + |_:_____._____:_____._____:_____._____:___| + 0 2 4 6 + + - Procedure: histograph data label + Creates and displays a histogram of the numerical values contained + in vector or list DATA + + (require 'random-inexact) | + (histograph (do ((idx 99 (+ -1 idx)) + (lst '() (cons (* .02 (random:normal)) lst))) + ((negative? idx) lst)) + "normal") + -| + _________________________________________ + 8|- : I | + | : I | + 7|- I I : I | + | I I : I | + 6|- III I :I I | + | III I :I I | + 5|- IIIIIIIIII I | + | IIIIIIIIII I | + 4|- IIIIIIIIIIII | + | IIIIIIIIIIII | + 3|-I I I IIIIIIIIIIII II I | + | I I I IIIIIIIIIIII II I | + 2|-I I I IIIIIIIIIIIIIIIII I | + | I I I IIIIIIIIIIIIIIIII I | + 1|-II I I IIIIIIIIIIIIIIIIIIIII I I I | + | II I I IIIIIIIIIIIIIIIIIIIII I I I | + 0|-IIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIII----| + |__.____:____.____:____.____:____.____:___| + normal -0.025 0 0.025 0.05 + + +File: slib.info, Node: PostScript Graphing, Prev: Character Plotting, Up: Graphing + | +PostScript Graphing | +------------------- | + | +`(require 'eps-graph)' | + | +This is a graphing package creating encapsulated-PostScript files. Its | +motivations and design choice are described in | +<http://swissnet.ai.mit.edu/~jaffer/Docupage/grapheps> | + | +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. | + | + - Function: create-postscript-graph filename.eps size elt1 ... | + FILENAME.EPS should be a string naming an output file to be | + created. SIZE should be an exact integer, a list of two exact | + integers, or #f. ELT1, ... are values returned by graphing | + primitives described here. | + | + `create-postscript-graph' creates an "Encapsulated-PostScript" | + file named FILENAME.EPS containing graphs as directed by the ELT1, | + ... arguments. | + | + The size of the graph is determined by the 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. | + | +These graphing procedures should be called as arguments to | +`create-postscript-graph'. The order of these arguments is | +significant; PostScript graphics state is affected serially from the | +first ELT argument to the last. | + | + - Function: whole-page | + Pushes a rectangle for the whole encapsulated page onto the | + PostScript stack. This pushed rectangle is an implicit argument to | + `partition-page' or `setup-plot'. | + | +* Menu: | + | +* Column Ranges:: | +* Drawing the Graph:: | +* Graphics Context:: | +* Rectangles:: | +* Legending:: | +* Legacy Plotting:: | +* Example Graph:: | + | -File: slib.info, Node: Root Finding, Next: Minimizing, Prev: Plotting, Up: Mathematical Packages +File: slib.info, Node: Column Ranges, Next: Drawing the Graph, Prev: PostScript Graphing, Up: PostScript Graphing + | +Column Ranges | +............. | + | +A "range" is a list of two numbers, the minimum and the maximum. | +Ranges can be given explicity or computed in PostScript by | +`column-range'. | + | + - Function: column-range array k | + Returns the range of values in 2-dimensional ARRAY column K. | + | + - Function: pad-range range p | + Expands RANGE by P/100 on each end. | + | + - Function: snap-range range | + Expands RANGE to round number of ticks. | + | + - Function: combine-ranges range1 range2 ... | + Returns the minimal range covering all RANGE1, RANGE2, ... | + | + - Function: setup-plot x-range y-range pagerect | + - Function: setup-plot x-range y-range | + X-RANGE and Y-RANGE should each be a list of two numbers or the | + value returned by `pad-range', `snap-range', or `combine-range'. | + 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, `setup-plot' sets up scaling and | + margins for making a graph. The margins are sized proportional to | + the FONTHEIGHT value at the time of the call to setup-plot. | + `setup-plot' sets two variables: | + | + PLOTRECT | + The region where data points will be plotted. | + | + GRAPHRECT | + The PAGERECT argument to `setup-plot'. Includes plotrect, | + legends, etc. | + | + +File: slib.info, Node: Drawing the Graph, Next: Graphics Context, Prev: Column Ranges, Up: PostScript Graphing + | +Drawing the Graph | +................. | + | + - Function: plot-column array x-column y-column proc3s | + Plots points with x coordinate in X-COLUMN of ARRAY and y | + coordinate Y-COLUMN of ARRAY. The symbol PROC3S specifies the | + type of glyph or drawing style for presenting these coordinates. | + | +The glyphs and drawing styles available are: | + | +`line' | + Draws line connecting points in order. | + | +`mountain' | + Fill area below line connecting points. | + | +`cloud' | + Fill area above line connecting points. | + | +`impulse' | + Draw line from x-axis to each point. | + | +`bargraph' | + Draw rectangle from x-axis to each point. | + | +`disc' | + Solid round dot. | + | +`point' | + Minimal point - invisible if linewidth is 0. | + | +`square' | + Square box. | + | +`diamond' | + Square box at 45.o | + | +`plus' | + Plus sign. | + | +`cross' | + X sign. | + | +`triup' | + Triangle pointing upward | + | +`tridown' | + Triangle pointing downward | + | +`pentagon' | + Five sided polygon | + | +`circle' | + Hollow circle | + | + +File: slib.info, Node: Graphics Context, Next: Rectangles, Prev: Drawing the Graph, Up: PostScript Graphing + | +Graphics Context | +................ | + | + - Function: in-graphic-context arg ... | + Saves the current graphics state, executes ARGS, then restores to | + saved graphics state. | + | + - Function: set-color color | + COLOR should be a string naming a Resene color, a saturate color, | + or a number between 0 and 100. | + | + `set-color' sets the PostScript color to the color of the given | + string, or a grey value between black (0) and white (100). | + | + - Function: set-font name fontheight | + NAME should be a (case-sensitive) string naming a PostScript font. | + FONTHEIGHT should be a positive real number. | + | + `set-font' Changes the current PostScript font to NAME with height | + equal to FONTHEIGHT. The default font is Helvetica (12pt). | + | +The base set of PostScript fonts is: | + | +Times Times-Italic Times-Bold Times-BoldItalic | +Helvetica Helvetica-Oblique Helvetica-Bold Helvetica-BoldOblique | +Courier Courier-Oblique Courier-Bold Courier-BoldOblique | +Symbol | + | +Line parameters do no affect fonts; they do effect glyphs. | + | + - Function: 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. | + | + - Function: set-linedash j k | + Lines are drawn J-on K-off. | + | + - Function: set-linedash j | + Lines are drawn J-on J-off. | + | + - Function: set-linedash | + Turns off dashing. | + | + - Function: set-glyphsize w | + Sets the (PostScript) variable glyphsize to W. The default | + glyphsize is 6. | + | +The effects of `clip-to-rect' are also part of the graphic context. | + | + +File: slib.info, Node: Rectangles, Next: Legending, Prev: Graphics Context, Up: PostScript Graphing + | +Rectangles | +.......... | + | +A "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. | + | + - Function: whole-page | + Pushes a rectangle for the whole encapsulated page onto the | + PostScript stack. This pushed rectangle is an implicit argument to | + `partition-page' or `setup-plot'. | + | + - Function: partition-page xparts yparts | + Pops the rectangle currently on top of the stack and pushes XPARTS | + * 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 `partition-page'. | + | + - Variable: plotrect | + The rectangle where data points should be plotted. PLOTRECT is | + set by `setup-plot'. | + | + - Variable: graphrect | + The PAGERECT argument of the most recent call to `setup-plot'. | + Includes plotrect, legends, etc. | + | + - Function: fill-rect rect | + fills RECT with the current color. | + | + - Function: outline-rect rect | + Draws the perimiter of RECT in the current color. | + | + - Function: clip-to-rect rect | + Modifies the current graphics-state so that nothing will be drawn | + outside of the rectangle RECT. Use `in-graphic-context' to limit | + the extent of `clip-to-rect'. | + | + +File: slib.info, Node: Legending, Next: Legacy Plotting, Prev: Rectangles, Up: PostScript Graphing + | +Legending | +......... | + | + - Function: title-top title subtitle | + - Function: title-top title | + Puts a TITLE line and an optional SUBTITLE line above the | + `graphrect'. | + | + - Function: title-bottom title subtitle | + - Function: title-bottom title | + Puts a TITLE line and an optional SUBTITLE line below the | + `graphrect'. | + | + - Variable: topedge | + - Variable: bottomedge | + These edge coordinates of `graphrect' are suitable for passing as | + the first argument to `rule-horizontal'. | + | + - Variable: leftedge | + - Variable: rightedge | + These edge coordinates of `graphrect' are suitable for passing as | + the first argument to `rule-vertical'. | + | + - Function: rule-vertical x-coord text tick-width | + Draws a vertical ruler with X coordinate X-COORD and labeled with | + string TEXT. If TICK-WIDTH is positive, then the ticks are | + TICK-WIDTH long on the right side of X-COORD; and TEXT and numeric | + legends are on the left. If TICK-WIDTH is negative, then the | + ticks are -TICK-WIDTH long on the left side of X-COORD; and TEXT | + and numeric legends are on the right. | + | + - Function: rule-horizontal x-coord text tick-height | + Draws a horizontal ruler with X coordinate X-COORD and labeled with | + string TEXT. If TICK-HEIGHT is positive, then the ticks are | + TICK-HEIGHT long on the right side of X-COORD; and TEXT and | + numeric legends are on the left. If TICK-HEIGHT is negative, then | + the ticks are -TICK-HEIGHT long on the left side of X-COORD; and | + TEXT and numeric legends are on the right. | + | + - Function: y-axis | + Draws the y-axis. | + | + - Function: x-axis | + Draws the x-axis. | + | + - Function: grid-verticals | + Draws vertical lines through `graphrect' at each tick on the | + vertical ruler. | + | + - Function: grid-horizontals | + Draws horizontal lines through `graphrect' at each tick on the | + horizontal ruler. | + | + +File: slib.info, Node: Legacy Plotting, Next: Example Graph, Prev: Legending, Up: PostScript Graphing + | +Legacy Plotting | +............... | + | + - Variable: graph:dimensions | + A list of the width and height of the graph to be plotted using | + `plot'. | + | + - Function: plot func x1 x2 npts | + - Function: plot func x1 x2 | + Creates and displays using `(system "gv tmp.eps")' an encapsulated | + PostScript graph of the function of one argument FUNC over the | + range X1 to X2. If the optional integer argument NPTS is | + supplied, it specifies the number of points to evaluate FUNC at. | + | + - Function: plot coords x-label y-label | + COORDS is a list or vector of coordinates, lists of x and y | + coordinates. X-LABEL and Y-LABEL are strings with which to label | + the x and y axes. | + | + +File: slib.info, Node: Example Graph, Prev: Legacy Plotting, Up: PostScript Graphing + | +Example Graph | +............. | + | +The file `am1.5.html', a table of solar irradiance, is fetched with | +`wget' if it isn't already in the working directory. The file is read | +and stored into an array, IRRADIANCE. | + | + `create-postscript-graph' is then called to create an | +encapsulated-PostScript file, `solarad.eps'. The size of the page is | +set to 600 by 300. `whole-page' is called and leaves the rectangle on | +the PostScript stack. `setup-plot' is called with a literal range for | +x and computes the range for column 1. | + | + Two calls to `top-title' are made so a different font can be used for | +the lower half. `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, `in-graphic-context' | +is called and `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 `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 `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 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. | + | + (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") | + | + +File: slib.info, Node: Solid Modeling, Next: Color, Prev: Graphing, Up: Mathematical Packages + | +Solid Modeling +============== + +`(require 'solid)' + +`http://swissnet.ai.mit.edu/~jaffer/Solid/#Example' gives an example +use of this package. + + - Function: vrml node ... + Returns the VRML97 string (including header) of the concatenation + of strings NODES, .... + + - Function: vrml-append node1 node2 ... + Returns the concatenation with interdigitated newlines of strings + NODE1, NODE2, .... + + - Function: vrml-to-file file node ... + Writes to file named FILE the VRML97 string (including header) of + the concatenation of strings NODES, .... + + - Function: world:info title info ... + Returns a VRML97 string setting the title of the file in which it + appears to TITLE. Additional strings INFO, ... are comments. + +VRML97 strings passed to `vrml' and `vrml-to-file' as arguments will +appear in the resulting VRML code. This string turns off the headlight +at the viewpoint: + " NavigationInfo {headlight FALSE}" + + - Function: scene:panorama front right back left top bottom + Specifies the distant images on the inside faces of the cube + enclosing the virtual world. + + - Function: scene:sphere colors angles + COLORS is a list of color objects. Each may be of type *Note + color: Color Data-Type, a 24-bit sRGB integer, or a list of 3 + numbers between 0.0 and 1.0. + + ANGLES is a list of non-increasing angles the same length as + COLORS. Each angle is between 90 and -90 degrees. If 90 or -90 + are not elements of ANGLES, then the color at the zenith and nadir + are taken from the colors paired with the angles nearest them. + + `scene:sphere' fills horizontal bands with interpolated colors on + the backgroud sphere encasing the world. + + - Function: scene:sky-and-dirt + Returns a blue and brown backgroud sphere encasing the world. + + - Function: scene:sky-and-grass + Returns a blue and green backgroud sphere encasing the world. + + - Function: scene:sun latitude julian-day hour turbidity strength + - Function: scene:sun latitude julian-day hour turbidity + LATITUDE is the virtual place's latitude in degrees. JULIAN-DAY + is an integer from 0 to 366, the day of the year. HOUR is a real + number from 0 to 24 for the time of day; 12 is noon. TURBIDITY is + the degree of fogginess described in *Note turbidity: Daylight. + + `scene:sun' returns a bright yellow, distant sphere where the sun + would be at HOUR on JULIAN-DAY at LATITUDE. If STRENGTH is + positive, included is a light source of STRENGTH (default 1). + + - Function: scene:overcast latitude julian-day hour turbidity strength + - Function: scene:overcast latitude julian-day hour turbidity + LATITUDE is the virtual place's latitude in degrees. JULIAN-DAY + is an integer from 0 to 366, the day of the year. HOUR is a real + number from 0 to 24 for the time of day; 12 is noon. TURBIDITY is + the degree of cloudiness described in *Note turbidity: Daylight. + + `scene:overcast' returns an overcast sky as it might look at HOUR + on JULIAN-DAY at LATITUDE. If STRENGTH is positive, included is + an ambient light source of STRENGTH (default 1). + +Viewpoints are objects in the virtual world, and can be transformed +individually or with solid objects. + + - Function: scene:viewpoint name distance compass pitch + - Function: scene:viewpoint name distance compass + Returns a viewpoint named NAME facing the origin and placed + DISTANCE from it. COMPASS is a number from 0 to 360 giving the + compass heading. PITCH is a number from -90 to 90, defaulting to + 0, specifying the angle from the horizontal. + + - Function: scene:viewpoints proximity + Returns 6 viewpoints, one at the center of each face of a cube + with sides 2 * PROXIMITY, centered on the origin. + +Light Sources +------------- + +In VRML97, lights shine only on objects within the same children node +and descendants of that node. Although it would have been convenient +to let light direction be rotated by `solid:rotation', this restricts a +rotated light's visibility to objects rotated with it. + +To workaround this limitation, these directional light source +procedures accept either Cartesian or spherical coordinates for +direction. A spherical coordinate is a list `(THETA AZIMUTH)'; where +THETA is the angle in degrees from the zenith, and AZIMUTH is the angle +in degrees due west of south. + +It is sometimes useful for light sources to be brighter than `1'. When +INTENSITY arguments are greater than 1, these functions gang multiple +sources to reach the desired strength. + + - Function: light:ambient color intensity + - Function: light:ambient color + Ambient light shines on all surfaces with which it is grouped. + + COLOR is a an object of type *Note color: Color Data-Type, a + 24-bit sRGB integer, or a list of 3 numbers between 0.0 and 1.0. + If COLOR is #f, then the default color will be used. INTENSITY is + a real non-negative number defaulting to `1'. + + `light:ambient' returns a light source or sources of COLOR with + total strength of INTENSITY (or 1 if omitted). + + - Function: light:directional color direction intensity + - Function: light:directional color direction + - Function: light:directional color + Directional light shines parallel rays with uniform intensity on + all objects with which it is grouped. + + COLOR is a an object of type *Note color: Color Data-Type, a + 24-bit sRGB integer, or a list of 3 numbers between 0.0 and 1.0. + If COLOR is #f, then the default color will be used. + + DIRECTION must be a list or vector of 2 or 3 numbers specifying + the direction to this light. If DIRECTION has 2 numbers, then + these numbers are the angle from zenith and the azimuth in + degrees; if DIRECTION has 3 numbers, then these are taken as a + Cartesian vector specifying the direction to the light source. + The default direction is upwards; thus its light will shine down. + + INTENSITY is a real non-negative number defaulting to `1'. + + `light:directional' returns a light source or sources of COLOR + with total strength of INTENSITY, shining from DIRECTION. + + - Function: light:beam attenuation radius aperture peak + - Function: light:beam attenuation radius aperture + - Function: light:beam attenuation radius + - Function: light:beam attenuation + ATTENUATION is a list or vector of three nonnegative real numbers + specifying the reduction of intensity, the reduction of intensity + with distance, and the reduction of intensity as the square of + distance. RADIUS is the distance beyond which the light does not + shine. RADIUS defaults to `100'. + + APERTURE is a real number between 0 and 180, the angle centered on + the light's axis through which it sheds some light. PEAK is a + real number between 0 and 90, the angle of greatest illumination. + + - Function: light:point location color intensity beam + - Function: light:point location color intensity + - Function: light:point location color + - Function: light:point location + Point light radiates from LOCATION, intensity decreasing with + distance, towards all objects with which it is grouped. + + COLOR is a an object of type *Note color: Color Data-Type, a + 24-bit sRGB integer, or a list of 3 numbers between 0.0 and 1.0. + If COLOR is #f, then the default color will be used. INTENSITY is + a real non-negative number defaulting to `1'. BEAM is a structure + returned by `light:beam' or #f. + + `light:point' returns a light source or sources at LOCATION of + COLOR with total strength INTENSITY and BEAM properties. Note + that the pointlight itself is not visible. To make it so, place + an object with emissive appearance at LOCATION. + + - Function: light:spot location direction color intensity beam + - Function: light:spot location direction color intensity + - Function: light:spot location direction color + - Function: light:spot location direction + - Function: light:spot location + Spot light radiates from LOCATION towards DIRECTION, intensity + decreasing with distance, illuminating objects with which it is + grouped. + + DIRECTION must be a list or vector of 2 or 3 numbers specifying + the direction to this light. If DIRECTION has 2 numbers, then + these numbers are the angle from zenith and the azimuth in + degrees; if DIRECTION has 3 numbers, then these are taken as a + Cartesian vector specifying the direction to the light source. + The default direction is upwards; thus its light will shine down. + + COLOR is a an object of type *Note color: Color Data-Type, a + 24-bit sRGB integer, or a list of 3 numbers between 0.0 and 1.0. + If COLOR is #f, then the default color will be used. + + INTENSITY is a real non-negative number defaulting to `1'. + + `light:spot' returns a light source or sources at LOCATION of + DIRECTION with total strength COLOR. Note that the spotlight + itself is not visible. To make it so, place an object with + emissive appearance at LOCATION. + +Object Primitives +----------------- + + - Function: solid:box geometry appearance + - Function: solid:box geometry + GEOMETRY must be a number or a list or vector of three numbers. + If GEOMETRY is a number, the `solid:box' returns a cube with sides + of length GEOMETRY centered on the origin. Otherwise, `solid:box' + returns a rectangular box with dimensions GEOMETRY centered on the + origin. APPEARANCE determines the surface properties of the + returned object. + + - Function: solid:cylinder radius height appearance + - Function: solid:cylinder radius height + Returns a right cylinder with dimensions RADIUS and `(abs HEIGHT)' + centered on the origin. If HEIGHT is positive, then the cylinder + ends will be capped. APPEARANCE determines the surface properties + of the returned object. + + - Function: solid:disk radius thickness appearance + - Function: solid:disk radius thickness + THICKNESS must be a positive real number. `solid:disk' returns a + circular disk with dimensions RADIUS and THICKNESS centered on the + origin. APPEARANCE determines the surface properties of the + returned object. + + - Function: solid:cone radius height appearance + - Function: solid:cone radius height + Returns an isosceles cone with dimensions RADIUS and HEIGHT + centered on the origin. APPEARANCE determines the surface + properties of the returned object. + + - Function: solid:pyramid side height appearance + - Function: solid:pyramid side height + Returns an isosceles pyramid with dimensions SIDE and HEIGHT + centered on the origin. APPEARANCE determines the surface + properties of the returned object. + + - Function: solid:sphere radius appearance + - Function: solid:sphere radius + Returns a sphere of radius RADIUS centered on the origin. + APPEARANCE determines the surface properties of the returned + object. + + - Function: solid:ellipsoid geometry appearance + - Function: solid:ellipsoid geometry + GEOMETRY must be a number or a list or vector of three numbers. + If GEOMETRY is a number, the `solid:ellipsoid' returns a sphere of + diameter GEOMETRY centered on the origin. Otherwise, + `solid:ellipsoid' returns an ellipsoid with diameters GEOMETRY + centered on the origin. APPEARANCE determines the surface + properties of the returned object. + + - Function: solid:basrelief width height depth colorray appearance + - Function: solid:basrelief width height depth appearance + - Function: solid:basrelief width height depth + One of WIDTH, HEIGHT, or DEPTH must be a 2-dimensional array; the + others must be real numbers giving the length of the basrelief in + those dimensions. The rest of this description assumes that + HEIGHT is an array of heights. + + `solid:basrelief' returns a WIDTH by DEPTH basrelief solid with + heights per array HEIGHT with the buttom surface centered on the + origin. + + If present, APPEARANCE determines the surface properties of the + returned object. If present, COLORRAY must be an array of objects + of type *Note color: Color Data-Type, 24-bit sRGB integers or + lists of 3 numbers between 0.0 and 1.0. + + If COLORRAY's dimensions match HEIGHT, then each element of + COLORRAY paints its corresponding vertex of HEIGHT. If COLORRAY + has all dimensions one smaller than HEIGHT, then each element of + COLORRAY paints the corresponding face of HEIGHT. Other + dimensions for COLORRAY are in error. + +Surface Attributes +------------------ + + - Function: solid:color diffuseColor ambientIntensity specularColor + shininess emissiveColor transparency + - Function: solid:color diffuseColor ambientIntensity specularColor + shininess emissiveColor + - Function: solid:color diffuseColor ambientIntensity specularColor + shininess + - Function: solid:color diffuseColor ambientIntensity specularColor + - Function: solid:color diffuseColor ambientIntensity + - Function: solid:color diffuseColor + Returns an "appearance", the optical properties of the objects + with which it is associated. AMBIENTINTENSITY, SHININESS, and + TRANSPARENCY must be numbers between 0 and 1. DIFFUSECOLOR, + SPECULARCOLOR, and EMISSIVECOLOR are objects of type *Note color: + Color Data-Type, 24-bit sRGB integers or lists of 3 numbers + between 0.0 and 1.0. If a color argument is omitted or #f, then + the default color will be used. + + - Function: solid:texture image color scale rotation center translation + - Function: solid:texture image color scale rotation center + - Function: solid:texture image color scale rotation + - Function: solid:texture image color scale + - Function: solid:texture image color + - Function: solid:texture image + Returns an "appearance", the optical properties of the objects + with which it is associated. IMAGE is a string naming a JPEG or + PNG image resource. COLOR is #f, a color, or the string returned + by `solid:color'. The rest of the optional arguments specify + 2-dimensional transforms applying to the IMAGE. + + SCALE must be #f, a number, or list or vector of 2 numbers + specifying the scale to apply to IMAGE. ROTATION must be #f or + the number of degrees to rotate IMAGE. CENTER must be #f or a + list or vector of 2 numbers specifying the center of IMAGE + relative to the IMAGE dimensions. TRANSLATION must be #f or a + list or vector of 2 numbers specifying the translation to apply to + IMAGE. + +Aggregating Objects +------------------- + + - Function: solid:center-row-of number solid spacing + Returns a row of NUMBER SOLID objects spaced evenly SPACING apart. + + - Function: solid:center-array-of number-a number-b solid spacing-a + spacing-b + Returns NUMBER-B rows, SPACING-B apart, of NUMBER-A SOLID objects + SPACING-A apart. + + - Function: solid:center-pile-of number-a number-b number-c solid + spacing-a spacing-b spacing-c + Returns NUMBER-C planes, SPACING-C apart, of NUMBER-B rows, + SPACING-B apart, of NUMBER-A SOLID objects SPACING-A apart. + + - Function: solid:arrow center + CENTER must be a list or vector of three numbers. Returns an + upward pointing metallic arrow centered at CENTER. + + - Function: solid:arrow + Returns an upward pointing metallic arrow centered at the origin. + +Spatial Transformations +----------------------- + + - Function: solid:translation center solid ... + CENTER must be a list or vector of three numbers. + `solid:translation' Returns an aggregate of SOLIDS, ... with their + origin moved to CENTER. + + - Function: solid:scale scale solid ... + SCALE must be a number or a list or vector of three numbers. + `solid:scale' Returns an aggregate of SOLIDS, ... scaled per SCALE. + + - Function: solid:rotation axis angle solid ... + AXIS must be a list or vector of three numbers. `solid:rotation' + Returns an aggregate of SOLIDS, ... rotated ANGLE degrees around + the axis AXIS. + + +File: slib.info, Node: Color, Next: Root Finding, Prev: Solid Modeling, Up: Mathematical Packages + +Color +===== + +`http://swissnet.ai.mit.edu/~jaffer/Color' + +The goals of this package are to provide methods to specify, compute, +and transform colors in a core set of additive color spaces. The color +spaces supported should be sufficient for working with the color data +encountered in practice and the literature. + +* Menu: + +* Color Data-Type:: 'color +* Color Spaces:: XYZ, L*a*b*, L*u*v*, L*C*h, RGB709, sRGB +* Spectra:: Color Temperatures and CIEXYZ(1931) +* Color Difference Metrics:: Society of Dyers and Colorists +* Color Conversions:: Low-level +* Color Names:: in relational databases +* Daylight:: Sunlight and sky colors + + +File: slib.info, Node: Color Data-Type, Next: Color Spaces, Prev: Color, Up: Color + +Color Data-Type +--------------- + +`(require 'color)' + + - Function: color? obj + Returns #t if OBJ is a color. + + - Function: color? obj typ + Returns #t if OBJ is a color of color-space TYP. The symbol TYP + must be one of: + + * CIEXYZ + + * RGB709 + + * L*a*b* + + * L*u*v* + + * sRGB + + * e-sRGB + + * L*C*h + + - Function: make-color space arg ... + Returns a color of type SPACE. + + - Function: color-space color + Returns the symbol for the color-space in which COLOR is embedded. + + - Function: color-precision color + For colors in digital color-spaces, `color-precision' returns the + number of bits used for each of the R, G, and B channels of the + encoding. Otherwise, `color-precision' returns #f + + - Function: color-white-point color + Returns the white-point of COLOR in all color-spaces except CIEXYZ. + + - Function: convert-color color space white-point + - Function: convert-color color space + - Function: convert-color color e-sRGB precision + Converts COLOR into SPACE at optional WHITE-POINT. + +External Representation +....................... + +Each color encoding has an external, case-insensitive representation. +To ensure portability, the white-point for all color strings is D65. +(1) + +Color Space External Representation +CIEXYZ CIEXYZ:<X>/<Y>/<Z> +RGB709 RGBi:<R>/<G>/<B> +L*a*b* CIELAB:<L>/<a>/<b> +L*u*v* CIELuv:<L>/<u>/<v> +L*C*h CIELCh:<L>/<C>/<h> + +The X, Y, Z, L, A, B, U, V, C, H, R, G, and B fields are (Scheme) real +numbers within the appropriate ranges. + +Color Space External Representation +sRGB sRGB:<R>/<G>/<B> +e-sRGB10 e-sRGB10:<R>/<G>/<B> +e-sRGB12 e-sRGB12:<R>/<G>/<B> +e-sRGB16 e-sRGB16:<R>/<G>/<B> + +The R, G, and B, fields are non-negative exact decimal integers within +the appropriate ranges. + +Several additional syntaxes are supported by `string->color': + +Color Space External Representation +sRGB sRGB:<RRGGBB> +sRGB #<RRGGBB> +sRGB 0x<RRGGBB> +sRGB #x<RRGGBB> + + Where RRGGBB is a non-negative six-digit hexadecimal number. + + - Function: color->string color + Returns a string representation of COLOR. + + - Function: string->color string + Returns the color represented by STRING. If STRING is not a + syntactically valid notation for a color, then `string->color' + returns #f. + +White +..... + +We experience color relative to the illumination around us. CIEXYZ +coordinates, although subject to uniform scaling, are objective. Thus +other color spaces are specified relative to a "white point" in CIEXYZ +coordinates. + +The white point for digital color spaces is set to D65. For the other +spaces a WHITE-POINT argument can be specified. The default if none is +specified is the white-point with which the color was created or last +converted; and D65 if none has been specified. + + - Constant: D65 + Is the color of 6500.K (blackbody) illumination. D65 is close to + the average color of daylight. + + - Constant: D50 + Is the color of 5000.K (blackbody) illumination. D50 is the color + of indoor lighting by incandescent bulbs, whose filaments have + temperatures around 5000.K. + + ---------- Footnotes ---------- + + (1) Readers may recognize these color string formats from Xlib. +X11's color management system was doomed by its fiction that CRT +monitors' (and X11 default) color-spaces were linear RGBi. Unable to +shed this legacy, the only practical way to view pictures on X is to +ignore its color management system and use an sRGB monitor. In this +implementation the device-independent RGB709 and sRGB spaces replace the +device-dependent RGBi and RGB spaces of Xlib. + + +File: slib.info, Node: Color Spaces, Next: Spectra, Prev: Color Data-Type, Up: Color + +Color Spaces +------------ + +Measurement-based Color Spaces +.............................. + +The "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. + + - Color Space: CIEXYZ + The CIEXYZ color space covers the full "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. + + - Function: ciexyz->color xyz + XYZ must be a list of 3 numbers. If XYZ is valid CIEXYZ + coordinates, then `ciexyz->color' returns the color specified by + XYZ; otherwise returns #f. + + - Function: color:ciexyz x y z + Returns the CIEXYZ color composed of X, Y, Z. If the coordinates + do not encode a valid CIEXYZ color, then an error is signaled. + + - Function: color->ciexyz color + Returns the list of 3 numbers encoding COLOR in CIEXYZ. + + - Color Space: RGB709 + BT.709-4 (03/00) `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. + + - Function: rgb709->color rgb + RGB must be a list of 3 numbers. If RGB is valid RGB709 + coordinates, then `rgb709->color' returns the color specified by + RGB; otherwise returns #f. + + - Function: color:rgb709 r g b + Returns the RGB709 color composed of R, G, B. If the coordinates + do not encode a valid RGB709 color, then an error is signaled. + + - Function: color->rgb709 color + Returns the list of 3 numbers encoding COLOR in RGB709. + +Perceptual Uniformity +..................... + +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). + + - 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: + + * 0 <= L* <= 100 (CIE "Lightness") + + * -500 <= a* <= 500 + + * -200 <= b* <= 200 + + - Function: l*a*b*->color L*a*b* white-point + L*A*B* must be a list of 3 numbers. If L*A*B* is valid L*a*b* + coordinates, then `l*a*b*->color' returns the color specified by + L*A*B*; otherwise returns #f. + + - Function: color:l*a*b* L* a* b* white-point + Returns the L*a*b* color composed of L*, A*, B* with WHITE-POINT. + + - Function: color:l*a*b* L* a* b* + Returns the L*a*b* color composed of L*, A*, B*. If the + coordinates do not encode a valid L*a*b* color, then an error is + signaled. + + - Function: color->l*a*b* color white-point + Returns the list of 3 numbers encoding COLOR in L*a*b* with + WHITE-POINT. + + - Function: color->l*a*b* color + Returns the list of 3 numbers encoding COLOR in L*a*b*. + + - Color Space: L*u*v* + Is another CIE encoding designed to better match the human visual + system's perception of color. + + - Function: l*u*v*->color L*u*v* white-point + L*U*V* must be a list of 3 numbers. If L*U*V* is valid L*u*v* + coordinates, then `l*u*v*->color' returns the color specified by + L*U*V*; otherwise returns #f. + + - Function: color:l*u*v* L* u* v* white-point + Returns the L*u*v* color composed of L*, U*, V* with WHITE-POINT. + + - Function: color:l*u*v* L* u* v* + Returns the L*u*v* color composed of L*, U*, V*. If the + coordinates do not encode a valid L*u*v* color, then an error is + signaled. + + - Function: color->l*u*v* color white-point + Returns the list of 3 numbers encoding COLOR in L*u*v* with + WHITE-POINT. + + - Function: color->l*u*v* color + Returns the list of 3 numbers encoding COLOR in L*u*v*. + +Cylindrical Coordinates +....................... + +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. + +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. + + - Color Space: L*C*h + Expresses the *a and b* of L*a*b* in polar coordinates. It is a + list of three numbers: + + * 0 <= L* <= 100 (CIE "Lightness") + + * C* (CIE "Chroma") is the distance from the neutral (gray) + axis. + + * 0 <= h <= 360 (CIE "Hue") is the angle. + + The colors by quadrant of h are: + + 0 red, orange, yellow 90 + 90 yellow, yellow-green, green 180 + 180 green, cyan (blue-green), blue 270 + 270 blue, purple, magenta 360 + + + - Function: l*c*h->color L*C*h white-point + L*C*H must be a list of 3 numbers. If L*C*H is valid L*C*h + coordinates, then `l*c*h->color' returns the color specified by + L*C*H; otherwise returns #f. + + - Function: color:l*c*h L* C* h white-point + Returns the L*C*h color composed of L*, C*, H with WHITE-POINT. + + - Function: color:l*c*h L* C* h + Returns the L*C*h color composed of L*, C*, H. If the coordinates + do not encode a valid L*C*h color, then an error is signaled. + + - Function: color->l*c*h color white-point + Returns the list of 3 numbers encoding COLOR in L*C*h with + WHITE-POINT. + + - Function: color->l*c*h color + Returns the list of 3 numbers encoding COLOR in L*C*h. + +Digital Color Spaces +.................... + +The color spaces discussed so far are impractical for image data because +of numerical precision and computational requirements. In 1998 the IEC +adopted `A Standard Default Color Space for the Internet - sRGB' +(<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. + +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. + + - 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 (1) should work very well with sRGB. + + + - Function: srgb->color rgb + RGB must be a list of 3 numbers. If RGB is valid sRGB coordinates, + then `srgb->color' returns the color specified by RGB; otherwise + returns #f. + + - Function: color:srgb r g b + Returns the sRGB color composed of R, G, B. If the coordinates do + not encode a valid sRGB color, then an error is signaled. + + - 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. + + - Function: color->srgb color + Returns the list of 3 integers encoding COLOR in sRGB. + + - Function: color->xrgb color + Returns the 24-bit integer encoding COLOR in sRGB. + + - Function: xrgb->color k + Returns the sRGB color composed of the 24-bit integer K. + + - 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: + + e-sRGB10 + 0 to 1023 + + e-sRGB12 + 0 to 4095 + + e-sRGB16 + 0 to 65535 + + - Function: e-srgb->color precision rgb + PRECISION must be the integer 10, 12, or 16. RGB must be a list + of 3 numbers. If RGB is valid e-sRGB coordinates, then + `e-srgb->color' returns the color specified by RGB; otherwise + returns #f. + + - Function: color:e-srgb 10 r g b + Returns the e-sRGB10 color composed of integers R, G, B. + + - Function: color:e-srgb 12 r g b + Returns the e-sRGB12 color composed of integers R, G, B. + + - Function: color:e-srgb 16 r g b + Returns the e-sRGB16 color composed of integers R, G, B. If the + coordinates do not encode a valid e-sRGB color, then an error is + signaled. + + - Function: color->e-srgb precision color + PRECISION must be the integer 10, 12, or 16. `color->e-srgb' + returns the list of 3 integers encoding COLOR in sRGB10, sRGB12, + or sRGB16. + + ---------- Footnotes ---------- + + (1) + +A comprehensive encoding of transforms between CIEXYZ and device color +spaces is the International Color Consortium profile format, +ICC.1:1998-09: + + 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. + + +File: slib.info, Node: Spectra, Next: Color Difference Metrics, Prev: Color Spaces, Up: Color + +Spectra +------- + +The following functions compute colors from spectra, scale color +luminance, and extract chromaticity. XYZ is used in the names of +procedures for unnormalized colors; the coordinates of CIEXYZ colors are +constrained as described in *Note Color Spaces::. + + `(require 'color-space)' + +A spectrum may be represented as: + + * A procedure of one argument accepting real numbers from 380e-9 to + 780e-9, the wavelength in meters; or + + * A vector of real numbers representing intensity samples evenly + spaced over some range of wavelengths overlapping the range 380e-9 + to 780e-9. + +CIEXYZ values are calculated as dot-product with the X, Y (Luminance), +and Z "Spectral Tristimulus Values". The files `cie1931.xyz' and +`cie1964.xyz' in the distribution contain these CIE-defined values. + + - Feature: cie1964 + Loads the Spectral Tristimulus Values defining `CIE 1964 + Supplementary Standard Colorimetric Observer'. + + - Feature: cie1931 + Loads the Spectral Tristimulus Values defining `CIE 1931 + Supplementary Standard Colorimetric Observer'. + + - Feature: ciexyz + Requires Spectral Tristimulus Values, defaulting to cie1931. + +`(require 'cie1964)' or `(require 'cie1931)' will `load-ciexyz' | +specific values used by the following spectrum conversion procedures. | +The spectrum conversion procedures `(require 'ciexyz)' to assure that a | +set is loaded. | + + - Function: spectrum->XYZ proc + PROC must be a function of one argument. `spectrum->XYZ' computes + the CIEXYZ(1931) values for the spectrum returned by PROC when + called with arguments from 380e-9 to 780e-9, the wavelength in + meters. + + - Function: spectrum->XYZ spectrum x1 x2 + X1 and X2 must be positive real numbers specifying the wavelengths + (in meters) corresponding to the zeroth and last elements of + vector or list SPECTRUM. `spectrum->XYZ' returns the CIEXYZ(1931) + values for a light source with spectral values proportional to the + elements of SPECTRUM at evenly spaced wavelengths between X1 and + X2. + + Compute the colors of 6500.K and 5000.K blackbody radiation: + + (require 'color-space) + (define xyz (spectrum->XYZ (blackbody-spectrum 6500))) + (define y_n (cadr xyz)) + (map (lambda (x) (/ x y_n)) xyz) + => (0.9687111145512467 1.0 1.1210875945303613) + + (define xyz (spectrum->XYZ (blackbody-spectrum 5000))) + (map (lambda (x) (/ x y_n)) xyz) + => (0.2933441826889158 0.2988931825387761 0.25783646831201573) + + - Function: spectrum->CIEXYZ proc + - Function: spectrum->CIEXYZ spectrum x1 x2 + `spectrum->CIEXYZ' computes the CIEXYZ(1931) values for the + spectrum, scaled so their sum is 1. + + - Function: spectrum->chromaticity proc + - Function: spectrum->chromaticity spectrum x1 x2 + Computes the chromaticity for the given spectrum. + + - Function: wavelength->XYZ w + - Function: wavelength->chromaticity w + - Function: wavelength->CIEXYZ w + W must be a number between 380e-9 to 780e-9. `wavelength->XYZ' + returns (unnormalized) XYZ values for a monochromatic light source + with wavelength W. `wavelength->chromaticity' returns the + chromaticity for a monochromatic light source with wavelength W. + `wavelength->CIEXYZ' returns XYZ values for the saturated color + having chromaticity of a monochromatic light source with wavelength + W. + + - Function: blackbody-spectrum temp + - Function: blackbody-spectrum temp span + Returns a procedure of one argument (wavelength in meters), which + returns the radiance of a black body at TEMP. + + The optional argument SPAN is the wavelength analog of bandwidth. + With the default SPAN of 1.nm (1e-9.m), the values returned by the + procedure correspond to the power of the photons with wavelengths + W to W+1e-9. + + - Function: temperature->XYZ x + The positive number X is a temperature in degrees kelvin. + `temperature->XYZ' computes the CIEXYZ(1931) values for the + spectrum of a black body at temperature X. + + Compute the chromaticities of 6500.K and 5000.K blackbody + radiation: + + (require 'color-space) + (XYZ->chromaticity (temperature->XYZ 6500)) + => (0.3135191660557008 0.3236456786200268) + + (XYZ->chromaticity (temperature->XYZ 5000)) + => (0.34508082841161052 0.3516084965163377) + + - Function: temperature->CIEXYZ x + The positive number X is a temperature in degrees kelvin. + `temperature->CIEXYZ' computes the CIEXYZ(1931) values for the + spectrum of a black body at temperature X, scaled to be just + inside the RGB709 gamut. + + - Function: temperature->chromaticity x | + | + - Function: XYZ:normalize xyz + XYZ is a list of three non-negative real numbers. `XYZ:normalize' + returns a list of numbers proportional to XYZ; scaled so their sum + is 1. + + - Function: XYZ:normalize-colors colors ... + COLORS is a list of XYZ triples. `XYZ:normalize-colors' scales + all the triples by a common factor such that the maximum sum of + numbers in a scaled triple is 1. + + - Function: XYZ->chromaticity xyz + Returns a two element list: the x and y components of XYZ + normalized to 1 (= X + Y + Z). + + - Function: chromaticity->CIEXYZ x y + Returns the list of X, and Y, 1 - Y - X. + + - Function: chromaticity->whitepoint x y + Returns the CIEXYZ(1931) values having luminosity 1 and + chromaticity X and Y. + +Many color datasets are expressed in "xyY" format; chromaticity with +CIE luminance (Y). But xyY is not a CIE standard like CIEXYZ, CIELAB, +and CIELUV. Although chrominance is well defined, the luminance +component is sometimes scaled to 1, sometimes to 100, but usually has no +obvious range. With no given whitepoint, the only reasonable course is +to ascertain the luminance range of a dataset and normalize the values +to lie from 0 to 1. + + - Function: XYZ->xyY xyz + Returns a three element list: the X and Y components of XYZ + normalized to 1, and CIE luminance Y. + + - Function: xyY->XYZ xyY + + - Function: xyY:normalize-colors colors + COLORS is a list of xyY triples. `xyY:normalize-colors' scales + each chromaticity so it sums to 1 or less; and divides the Y + values by the maximum Y in the dataset, so all lie between 0 and 1. + + - Function: xyY:normalize-colors colors n + If N is positive real, then `xyY:normalize-colors' divides the Y + values by N times the maximum Y in the dataset. + + If N is an exact non-positive integer, then `xyY:normalize-colors' + divides the Y values by the maximum of the Ys in the dataset + excepting the -N largest Y values. + + In all cases, returned Y values are limited to lie from 0 to 1. + +Why would one want to normalize to other than 1? If the sun or its +reflection is the brightest object in a scene, then normalizing to its +luminance will tend to make the rest of the scene very dark. As with +photographs, limiting the specular highlights looks better than +darkening everything else. + +The results of measurements being what they are, `xyY:normalize-colors' +is extremely tolerant. Negative numbers are replaced with zero, and +chromaticities with sums greater than one are scaled to sum to one. + + +File: slib.info, Node: Color Difference Metrics, Next: Color Conversions, Prev: Spectra, Up: Color + +Color Difference Metrics +------------------------ + +`(require 'color-space)' | + | + The low-level metric functions operate on lists of 3 numbers, lab1, | +lab2, lch1, or lch2. | + | + `(require 'color)' | + | + The wrapped functions operate on objects of type color, color1 and | +color2 in the function entries. | + | + - Function: L*a*b*:DE* lab1 lab2 | + Returns the Euclidean distance between LAB1 and LAB2. | + | + - Function: CIE:DE* color1 color2 white-point + - Function: CIE:DE* color1 color2 + Returns the Euclidean distance in L*a*b* space between COLOR1 and + COLOR2. + + - Function: L*C*h:DE*94 lch1 lch2 parametric-factors | + - Function: L*C*h:DE*94 lch1 lch2 | + - Function: CIE:DE*94 color1 color2 parametric-factors + - Function: CIE:DE*94 color1 color2 + Measures distance in the L*C*h cylindrical color-space. The three | + axes are individually scaled (depending on C*) in their | + contributions to the total distance. + + The CIE has defined reference conditions under which the metric + with default parameters can be expected to perform well. These + are: + + * The specimens are homogeneous in colour. + + * The colour difference (CIELAB) is <= 5 units. + + * They are placed in direct edge contact. + + * Each specimen subtends an angle of >4 degrees to the + assessor, whose colour vision is normal. + + * They are illuminated at 1000 lux, and viewed against a + background of uniform grey, with L* of 50, under illumination + simulating D65. + + The PARAMETRIC-FACTORS argument is a list of 3 quantities kL, kC + and kH. PARAMETRIC-FACTORS independently adjust each + colour-difference term to account for any deviations from the + reference viewing conditions. Under the reference conditions + explained above, the default is kL = kC = kH = 1. + +The Color Measurement Committee of The Society of Dyers and Colorists in +Great Britain created a more sophisticated color-distance function for +use in judging the consistency of dye lots. With CMC:DE* it is possible +to use a single value pass/fail tolerance for all shades. + + - Function: CMC-DE lch1 lch2 parametric-factors | + - Function: CMC-DE lch1 lch2 l c | + - Function: CMC-DE lch1 lch2 l | + - Function: CMC-DE lch1 lch2 | + - Function: CMC:DE* color1 color2 l c + - Function: CMC:DE* color1 color2 + `CMC:DE' is a L*C*h metric. The PARAMETRIC-FACTORS argument is a | + list of 2 numbers L and C. L and C parameterize this metric. 1 | + and 1 are recommended for perceptibility; the default, 2 and 1, | + for acceptability. + + +File: slib.info, Node: Color Conversions, Next: Color Names, Prev: Color Difference Metrics, Up: Color + +Color Conversions +----------------- + +This package contains the low-level color conversion and color metric +routines operating on lists of 3 numbers. There is no type or range +checking. + + `(require 'color-space)' + + - Constant: CIEXYZ:D65 + Is the color of 6500.K (blackbody) illumination. D65 is close to + the average color of daylight. + + - Constant: CIEXYZ:D50 + Is the color of 5000.K (blackbody) illumination. D50 is the color + of indoor lighting by incandescent bulbs. + + - Constant: CIEXYZ:A + - Constant: CIEXYZ:B + - Constant: CIEXYZ:C + - Constant: CIEXYZ:E + CIE 1931 illuminants normalized to 1 = y. + + - Function: color:linear-transform matrix row | + | + - Function: CIEXYZ->RGB709 xyz + - Function: RGB709->CIEXYZ srgb + + - Function: CIEXYZ->L*u*v* xyz white-point + - Function: CIEXYZ->L*u*v* xyz + - Function: L*u*v*->CIEXYZ L*u*v* white-point + - Function: L*u*v*->CIEXYZ L*u*v* + The WHITE-POINT defaults to CIEXYZ:D65. + + - Function: CIEXYZ->L*a*b* xyz white-point + - Function: CIEXYZ->L*a*b* xyz + - Function: L*a*b*->CIEXYZ L*a*b* white-point + - Function: L*a*b*->CIEXYZ L*a*b* + The XYZ WHITE-POINT defaults to CIEXYZ:D65. + + - Function: L*a*b*->L*C*h L*a*b* + - Function: L*C*h->L*a*b* L*C*h + + - Function: CIEXYZ->sRGB xyz + - Function: sRGB->CIEXYZ srgb + + - Function: CIEXYZ->xRGB xyz | + - Function: xRGB->CIEXYZ srgb | + | + - Function: sRGB->xRGB xyz | + - Function: xRGB->sRGB srgb | + | + - Function: CIEXYZ->e-sRGB n xyz + - Function: e-sRGB->CIEXYZ n srgb + + - Function: sRGB->e-sRGB n srgb + - Function: e-sRGB->sRGB n srgb + The integer N must be 10, 12, or 16. Because sRGB and e-sRGB use + the same RGB709 chromaticities, conversion between them is simpler + than conversion through CIEXYZ. + +Do not convert e-sRGB precision through `e-sRGB->sRGB' then +`sRGB->e-sRGB' - values would be truncated to 8-bits! + + - Function: e-sRGB->e-sRGB n1 srgb n2 + The integers N1 and N2 must be 10, 12, or 16. `e-sRGB->e-sRGB' + converts SRGB to e-sRGB of precision N2. + | + +File: slib.info, Node: Color Names, Next: Daylight, Prev: Color Conversions, Up: Color + +Color Names +----------- + +`(require 'color-names)' + +Rather than ballast the color dictionaries with numbered grays, +`file->color-dictionary' discards them. They are provided through the +`grey' procedure: + + - Function: grey k + Returns `(inexact->exact (round (* k 2.55)))', the X11 color + grey<k>. + +A color dictionary is a database table relating "canonical" color-names +to color-strings (*note External Representation: Color Data-Type.). + +The column names in a color dictionary are unimportant; the first field +is the key, and the second is the color-string. + + - Function: color-name:canonicalize name + Returns a downcased copy of the string or symbol NAME with `_', + `-', and whitespace removed. + + - Function: color-name->color name table1 table2 ... + TABLE1, TABLE2, ... must be color-dictionary tables. + `color-name->color' searches for the canonical form of NAME in + TABLE1, TABLE2, ... in order; returning the color-string of the + first matching record; #f otherwise. + + - Function: color-dictionaries->lookup table1 table2 ... + TABLE1, TABLE2, ... must be color-dictionary tables. + `color-dictionaries->lookup' returns a procedure which searches + for the canonical form of its string argument in TABLE1, TABLE2, + ...; returning the color-string of the first matching record; and + #f otherwise. + + - Function: color-dictionary name rdb base-table-type + RDB must be a string naming a relational database file; and the + symbol NAME a table therein. The database will be opened as + BASE-TABLE-TYPE. `color-dictionary' returns the read-only table + NAME in database NAME if it exists; #f otherwise. + + - Function: color-dictionary name rdb + RDB must be an open relational database or a string naming a + relational database file; and the symbol NAME a table therein. + `color-dictionary' returns the read-only table NAME in database + NAME if it exists; #f otherwise. + + - Function: load-color-dictionary name rdb base-table-type + - Function: load-color-dictionary name rdb + RDB must be a string naming a relational database file; and the + symbol NAME a table therein. If the symbol BASE-TABLE-TYPE is + provided, the database will be opened as BASE-TABLE-TYPE. + `load-color-dictionary' creates a top-level definition of the + symbol NAME to a lookup procedure for the color dictionary NAME in + RDB. + + The value returned by `load-color-dictionary' is unspecified. + +Dictionary Creation +................... + +`(require 'color-database)' | + | + - Function: file->color-dictionary file table-name rdb base-table-type + - Function: file->color-dictionary file table-name rdb + RDB must be an open relational database or a string naming a + relational database file, TABLE-NAME a symbol, and the string FILE + must name an existing file with colornames and their corresponding + xRGB (6-digit hex) values. `file->color-dictionary' creates a + table TABLE-NAME in RDB and enters the associations found in FILE + into it. + + - Function: url->color-dictionary url table-name rdb base-table-type + - Function: url->color-dictionary url table-name rdb + RDB must be an open relational database or a string naming a + relational database file and TABLE-NAME a symbol. + `url->color-dictionary' retrieves the resource named by the string + URL using the "wget" program; then calls `file->color-dictionary' + to enter its associations in TABLE-NAME in URL. + +This section has detailed the procedures for creating and loading color +dictionaries. So where are the dictionaries to load? + + `http://swissnet.ai.mit.edu/~jaffer/Color/Dictionaries.html' + +Describes and evaluates several color-name dictionaries on the web. +The following procedure creates a database containing two of these +dictionaries. + + - Function: make-slib-color-name-db + Creates an alist-table relational database in library-vicinity + containing the "Resene" and "saturate" color-name dictionaries. + + If the files `resenecolours.txt' and `saturate.txt' exist in the + library-vicinity, then they used as the source of color-name data. + Otherwise, `make-slib-color-name-db' calls url->color-dictionary + with the URLs of appropriate source files. + +The Short List +.............. + +`(require 'saturate)' + + - Function: saturate name + Looks for NAME among the 19 saturated colors from `Approximate + Colors on CIE Chromaticity Diagram': + + reddish orange orange yellowish orange yellow + greenish yellow yellow green yellowish green green + bluish green blue green greenish blue blue + purplish blue bluish purple purple reddish purple + red purple purplish red red + + (<http://swissnet.ai.mit.edu/~jaffer/Color/saturate.pdf>). If + NAME is found, the corresponding color is returned. Otherwise #f + is returned. Use saturate only for light source colors. + +Resene Paints Limited, New Zealand's largest privately-owned and +operated paint manufacturing company, has generously made their `Resene +RGB Values List' available. + + `(require 'resene)' + + - Function: resene name + Looks for NAME among the 1300 entries in the Resene color-name + dictionary (<http://swissnet.ai.mit.edu/~jaffer/Color/resene.pdf>). + If NAME is found, the corresponding color is returned. Otherwise + #f is returned. The `Resene RGB Values List' is an excellent + source for surface colors. + +If you include the "Resene RGB Values List" in binary form in a +program, then you must include its license with your program: + + Resene RGB Values List + For further information refer to http://www.resene.co.nz + Copyright Resene Paints Ltd 2001 + + Permission to copy this dictionary, 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 text copy made of this dictionary must include this + copyright notice in full. + + 2. Any redistribution in binary form must reproduce this + copyright notice in the documentation or other materials + provided with the distribution. + + 3. Resene Paints Ltd makes no warranty or representation that | + this dictionary is error-free, and is under no obligation to + provide any services, by way of maintenance, update, or + otherwise. + + 4. There shall be no use of the name of Resene or Resene Paints + Ltd in any advertising, promotional, or sales literature + without prior written consent in each case. + + 5. These RGB colour formulations may not be used to the + detriment of Resene Paints Ltd. + + +File: slib.info, Node: Daylight, Prev: Color Names, Up: Color + +Daylight +-------- + +`(require 'daylight)' + +This package calculates the colors of sky as detailed in: +`http://www.cs.utah.edu/vissim/papers/sunsky/sunsky.pdf' +`A Practical Analytic Model for Daylight' +A. J. Preetham, Peter Shirley, Brian Smits + + - Function: solar-hour julian-day hour + Returns the solar-time in hours given the integer 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. + + - Function: solar-declination julian-day + + - Function: solar-polar declination latitude solar-hour + Returns a list of THETA_S, the solar angle from the zenith, and + PHI_S, the solar azimuth. 0 <= THETA_S measured in degrees. + PHI_S is measured in degrees from due south; west of south being + positive. + +In the following procedures, the number 0 <= THETA_S <= 90 is the solar +angle from the zenith in degrees. + +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. + + _______________________________________________________________ + 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 + + - Function: sunlight-spectrum turbidity theta_s + Returns a vector of 41 values, the spectrum of sunlight from + 380.nm to 790.nm for a given TURBIDITY and THETA_S. + + - Function: sunlight-xyz turbidity theta_s + Returns (unnormalized) XYZ values for color of sunlight for a + given TURBIDITY and THETA_S. + + - Function: sunlight-ciexyz turbidity theta_s + Given TURBIDITY and THETA_S, `sunlight-ciexyz' returns the CIEXYZ + triple for color of sunlight scaled to be just inside the RGB709 + gamut. + + - Function: zenith-xyy turbidity theta_s + Returns the xyY (chromaticity and luminance) at the zenith. The + Luminance has units kcd/m^2. + + - Function: overcast-sky-color-xyy turbidity theta_s + TURBIDITY is a positive real number expressing the amount of light + scattering. The real number THETA_S is the solar angle from the + zenith in degrees. + + `overcast-sky-color-xyy' returns a function of one angle 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. + + - Function: clear-sky-color-xyy turbidity theta_s phi_s + - Function: sky-color-xyy turbidity theta_s phi_s + TURBIDITY is a positive real number expressing the amount of light + scattering. The real number THETA_S is the solar angle from the + zenith in degrees. The real number PHI_S is the solar angle from + south. + + `clear-sky-color-xyy' returns a function of two angles, THETA and + 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. + + `sky-color-xyY' calls `overcast-sky-color-xyY' for TURBIDITY <= + 20; otherwise the `clear-sky-color-xyy' function. + + +File: slib.info, Node: Root Finding, Next: Minimizing, Prev: Color, Up: Mathematical Packages Root Finding ============ - `(require 'root)' +`(require 'root)' - - Function: newtown:find-integer-root f df/dx x0 + - Function: newton:find-integer-root f df/dx x0 Given integer valued procedure F, its derivative (with respect to its argument) DF/DX, and initial integer value X0 for which DF/DX(X0) is non-zero, returns an integer X for which F(X) is @@ -5600,7 +7849,7 @@ File: slib.info, Node: Minimizing, Next: Commutative Rings, Prev: Root Findin Minimizing ========== - `(require 'minimize)' +`(require 'minimize)' The Golden Section Search (1) algorithm finds minima of functions which are expensive to compute or for which derivatives are not available. @@ -5642,12 +7891,12 @@ approximating the derivative. and Software' Prentice-Hall, 1989, ISBN 0-13-627258-4 -File: slib.info, Node: Commutative Rings, Next: Determinant, Prev: Minimizing, Up: Mathematical Packages +File: slib.info, Node: Commutative Rings, Next: Matrix Algebra, Prev: Minimizing, Up: Mathematical Packages Commutative Rings ================= - Scheme provides a consistent and capable set of numeric functions. +Scheme provides a consistent and capable set of numeric functions. Inexacts implement a field; integers a commutative ring (and Euclidean domain). This package allows one to use basic Scheme numeric functions with symbols and non-numeric elements of commutative rings. @@ -5713,7 +7962,7 @@ restrictive Euclidean (Unique Factorization) Domain. Rules and Rulesets ================== - The "commutative-ring" package allows control of ring properties +The "commutative-ring" package allows control of ring properties through the use of "rulesets". - Variable: *ruleset* @@ -5741,11 +7990,11 @@ through the use of "rulesets". Two rulesets are defined by this package. - Constant: distribute* - Contain the ruleset to distribute multiplication over addition and + Contains the ruleset to distribute multiplication over addition and subtraction. - Constant: distribute/ - Contain the ruleset to distribute division over addition and + Contains the ruleset to distribute division over addition and subtraction. Take care when using both DISTRIBUTE* and DISTRIBUTE/ @@ -5787,12 +8036,12 @@ involving different non-numeric elements. How to Create a Commutative Ring ================================ - The first step in creating your commutative ring is to write -procedures to create elements of the ring. A non-numeric element of -the ring must be represented as a list whose first element is a symbol -or string. This first element identifies the type of the object. A -convenient and clear convention is to make the type-identifying element -be the same symbol whose top-level value is the procedure to create it. +The first step in creating your commutative ring is to write procedures +to create elements of the ring. A non-numeric element of the ring must +be represented as a list whose first element is a symbol or string. +This first element identifies the type of the object. A convenient and +clear convention is to make the type-identifying element be the same +symbol whose top-level value is the procedure to create it. (define (n . list1) (cond ((and (= 2 (length list1)) @@ -5856,14 +8105,14 @@ have _not_ been defined are not changed. (define (splice list1 list2) (cond ((eq? (last1 list1) (first list2)) (append list1 (cdr list2))) - (else (error 'splice list1 list2)))) + (else (slib:error 'splice list1 list2)))) ;;; where cyclicsplice is the result of leaving off the last element of ;;; splice(list1,list2). (define (cyclicsplice list1 list2) (cond ((and (eq? (last1 list1) (first list2)) (eq? (first list1) (last1 list2))) (butlast (splice list1 list2) 1)) - (else (error 'cyclicsplice list1 list2)))) + (else (slib:error 'cyclicsplice list1 list2)))) (N*N (S a b) (S a b)) => (m a b) @@ -5921,18 +8170,41 @@ objects. (* (m a c e b g) (m d f))) -File: slib.info, Node: Determinant, Prev: Commutative Rings, Up: Mathematical Packages +File: slib.info, Node: Matrix Algebra, Prev: Commutative Rings, Up: Mathematical Packages -Determinant -=========== +Matrix Algebra +============== + +`(require 'determinant)' + +A Matrix can be either a list of lists (rows) or an array. As with +linear-algebra texts, this package uses 1-based coordinates. + + - Function: matrix->lists matrix + Returns the list-of-lists form of MATRIX. - - Function: determinant square-matrix - Returns the determinant of SQUARE-MATRIX. + - Function: matrix->array matrix + Returns the (ones-based) array form of MATRIX. + + - Function: determinant matrix + MATRIX must be a square matrix. `determinant' returns the + determinant of MATRIX. (require 'determinant) (determinant '((1 2) (3 4))) => -2 (determinant '((1 2 3) (4 5 6) (7 8 9))) => 0 - (determinant '((1 2 3 4) (5 6 7 8) (9 10 11 12))) => 0 + + - Function: transpose matrix + Returns a copy of MATRIX flipped over the diagonal containing the + 1,1 element. + + - Function: matrix:product m1 m2 + Returns the product of matrices M1 and M2. + + - Function: matrix:inverse matrix + MATRIX must be a square matrix. If MATRIX is singlar, then + `matrix:inverse' returns #f; otherwise `matrix:inverse' returns the + `matrix:product' inverse of MATRIX. File: slib.info, Node: Database Packages, Next: Other Packages, Prev: Mathematical Packages, Up: Top @@ -5941,501 +8213,264 @@ Database Packages ***************** * Menu: - -* Base Table:: + | * Relational Database:: 'relational-database +* Relational Infrastructure:: | * Weight-Balanced Trees:: 'wt-tree -File: slib.info, Node: Base Table, Next: Relational Database, Prev: Database Packages, Up: Database Packages +File: slib.info, Node: Relational Database, Next: Relational Infrastructure, Prev: Database Packages, Up: Database Packages + | +Relational Database +=================== -Base Table -========== +`(require 'relational-database)' - A base table implementation using Scheme association lists is -available as the value of the identifier `alist-table' after doing: - - `(require 'alist-table)' - - Association list base tables are suitable for small databases and -support all Scheme types when temporary and readable/writeable Scheme -types when saved. I hope support for other base table implementations -will be added in the future. - - This rest of this section documents the interface for a base table -implementation from which the *Note Relational Database:: package -constructs a Relational system. It will be of interest primarily to -those wishing to port or write new base-table implementations. - - All of these functions are accessed through a single procedure by -calling that procedure with the symbol name of the operation. A -procedure will be returned if that operation is supported and `#f' -otherwise. For example: - - (require 'alist-table) - (define open-base (alist-table 'make-base)) - make-base => *a procedure* - (define foo (alist-table 'foo)) - foo => #f - - - Function: make-base filename key-dimension column-types - Returns a new, open, low-level database (collection of tables) - associated with FILENAME. This returned database has an empty - table associated with CATALOG-ID. The positive integer - KEY-DIMENSION is the number of keys composed to make a PRIMARY-KEY - for the catalog table. The list of symbols COLUMN-TYPES describes - the types of each column for that table. If the database cannot - be created as specified, `#f' is returned. - - Calling the `close-base' method on this database and possibly other - operations will cause FILENAME to be written to. If FILENAME is - `#f' a temporary, non-disk based database will be created if such - can be supported by the base table implelentation. - - - Function: open-base filename mutable - Returns an open low-level database associated with FILENAME. If - MUTABLE? is `#t', this database will have methods capable of - effecting change to the database. If MUTABLE? is `#f', only - methods for inquiring the database will be available. If the - database cannot be opened as specified `#f' is returned. - - Calling the `close-base' (and possibly other) method on a MUTABLE? - database will cause FILENAME to be written to. - - - Function: write-base lldb filename - Causes the low-level database LLDB to be written to FILENAME. If - the write is successful, also causes LLDB to henceforth be - associated with FILENAME. Calling the `close-database' (and - possibly other) method on LLDB may cause FILENAME to be written - to. If FILENAME is `#f' this database will be changed to a - temporary, non-disk based database if such can be supported by the - underlying base table implelentation. If the operations completed - successfully, `#t' is returned. Otherwise, `#f' is returned. - - - Function: sync-base lldb - Causes the file associated with the low-level database LLDB to be - updated to reflect its current state. If the associated filename - is `#f', no action is taken and `#f' is returned. If this - operation completes successfully, `#t' is returned. Otherwise, - `#f' is returned. + This package implements a database system inspired by the Relational +Model (`E. F. Codd, A Relational Model of Data for Large Shared Data +Banks'). An SLIB relational database implementation can be created +from any *Note Base Table:: implementation. - - Function: close-base lldb - Causes the low-level database LLDB to be written to its associated - file (if any). If the write is successful, subsequent operations - to LLDB will signal an error. If the operations complete - successfully, `#t' is returned. Otherwise, `#f' is returned. - - - Function: make-table lldb key-dimension column-types - Returns the BASE-ID for a new base table, otherwise returns `#f'. - The base table can then be opened using `(open-table LLDB - BASE-ID)'. The positive integer KEY-DIMENSION is the number of - keys composed to make a PRIMARY-KEY for this table. The list of - symbols COLUMN-TYPES describes the types of each column. - - - Constant: catalog-id - A constant BASE-ID suitable for passing as a parameter to - `open-table'. CATALOG-ID will be used as the base table for the - system catalog. - - - Function: open-table lldb base-id key-dimension column-types - Returns a HANDLE for an existing base table in the low-level - database LLDB if that table exists and can be opened in the mode - indicated by MUTABLE?, otherwise returns `#f'. - - As with `make-table', the positive integer KEY-DIMENSION is the - number of keys composed to make a PRIMARY-KEY for this table. The - list of symbols COLUMN-TYPES describes the types of each column. - - - Function: kill-table lldb base-id key-dimension column-types - Returns `#t' if the base table associated with BASE-ID was removed - from the low level database LLDB, and `#f' otherwise. - - - Function: make-keyifier-1 type - Returns a procedure which accepts a single argument which must be - of type TYPE. This returned procedure returns an object suitable - for being a KEY argument in the functions whose descriptions - follow. - - Any 2 arguments of the supported type passed to the returned - function which are not `equal?' must result in returned values - which are not `equal?'. - - - Function: make-list-keyifier key-dimension types - The list of symbols TYPES must have at least KEY-DIMENSION - elements. Returns a procedure which accepts a list of length - KEY-DIMENSION and whose types must corresopond to the types named - by TYPES. This returned procedure combines the elements of its - list argument into an object suitable for being a KEY argument in - the functions whose descriptions follow. - - Any 2 lists of supported types (which must at least include - symbols and non-negative integers) passed to the returned function - which are not `equal?' must result in returned values which are not - `equal?'. - - - Function: make-key-extractor key-dimension types column-number - Returns a procedure which accepts objects produced by application - of the result of `(make-list-keyifier KEY-DIMENSION TYPES)'. This - procedure returns a KEY which is `equal?' to the COLUMN-NUMBERth - element of the list which was passed to create COMBINED-KEY. The - list TYPES must have at least KEY-DIMENSION elements. - - - Function: make-key->list key-dimension types - Returns a procedure which accepts objects produced by application - of the result of `(make-list-keyifier KEY-DIMENSION TYPES)'. This - procedure returns a list of KEYs which are elementwise `equal?' to - the list which was passed to create COMBINED-KEY. - -In the following functions, the KEY argument can always be assumed to -be the value returned by a call to a _keyify_ routine. - -In contrast, a MATCH-KEYS argument is a list of length equal to the -number of primary keys. The MATCH-KEYS restrict the actions of the -table command to those records whose primary keys all satisfy the -corresponding element of the MATCH-KEYS list. The elements and their -actions are: - - `#f' - The false value matches any key in the corresponding position. - - an object of type procedure - This procedure must take a single argument, the key in the - corresponding position. Any key for which the procedure - returns a non-false value is a match; Any key for which the - procedure returns a `#f' is not. - - other values - Any other value matches only those keys `equal?' to it. - -The KEY-DIMENSION and COLUMN-TYPES arguments are needed to decode the -combined-keys for matching with MATCH-KEYS. - - - Function: for-each-key handle procedure key-dimension column-types - match-keys - Calls PROCEDURE once with each KEY in the table opened in HANDLE - which satisfy MATCH-KEYS in an unspecified order. An unspecified - value is returned. - - - Function: map-key handle procedure key-dimension column-types - match-keys - Returns a list of the values returned by calling PROCEDURE once - with each KEY in the table opened in HANDLE which satisfy - MATCH-KEYS in an unspecified order. - - - Function: ordered-for-each-key handle procedure key-dimension - column-types match-keys - Calls PROCEDURE once with each KEY in the table opened in HANDLE - which satisfy MATCH-KEYS in the natural order for the types of the - primary key fields of that table. An unspecified value is - returned. + Why relational database? For motivations and design issues see +`http://swissnet.ai.mit.edu/~jaffer/DBManifesto.html'. - - Function: delete* handle key-dimension column-types match-keys - Removes all rows which satisfy MATCH-KEYS from the table opened in - HANDLE. An unspecified value is returned. +* Menu: - - Function: present? handle key - Returns a non-`#f' value if there is a row associated with KEY in - the table opened in HANDLE and `#f' otherwise. +* Using Databases:: 'databases | +* Table Operations:: +* Database Interpolation:: 'database-interpolate | +* Embedded Commands:: 'database-commands +* Database Macros:: 'within-database | +* Database Browser:: 'database-browse - - Function: delete handle key - Removes the row associated with KEY from the table opened in - HANDLE. An unspecified value is returned. + +File: slib.info, Node: Using Databases, Next: Table Operations, Prev: Relational Database, Up: Relational Database + | +Using Databases +--------------- - - Function: make-getter key-dimension types - Returns a procedure which takes arguments HANDLE and KEY. This - procedure returns a list of the non-primary values of the relation - (in the base table opened in HANDLE) whose primary key is KEY if - it exists, and `#f' otherwise. +`(require 'databases)' - - Function: make-putter key-dimension types - Returns a procedure which takes arguments HANDLE and KEY and - VALUE-LIST. This procedure associates the primary key KEY with - the values in VALUE-LIST (in the base table opened in HANDLE) and - returns an unspecified value. +This enhancement wraps a utility layer on `relational-database' which +provides: - - Function: supported-type? symbol - Returns `#t' if SYMBOL names a type allowed as a column value by - the implementation, and `#f' otherwise. At a minimum, an - implementation must support the types `integer', `symbol', - `string', `boolean', and `base-id'. + * Identification of open databases by filename. - - Function: supported-key-type? symbol - Returns `#t' if SYMBOL names a type allowed as a key value by the - implementation, and `#f' otherwise. At a minimum, an - implementation must support the types `integer', and `symbol'. + * Automatic sharing of open (immutable) databases. -`integer' - Scheme exact integer. + * Automatic loading of base-table package when creating a database. -`symbol' - Scheme symbol. + * Detection and automatic loading of the appropriate base-table + package when opening a database. -`boolean' - `#t' or `#f'. + * Table and data definition from Scheme lists. -`base-id' - Objects suitable for passing as the BASE-ID parameter to - `open-table'. The value of CATALOG-ID must be an acceptable - `base-id'. +Database Sharing +................ - -File: slib.info, Node: Relational Database, Next: Weight-Balanced Trees, Prev: Base Table, Up: Database Packages +"Auto-sharing" refers to a call to the procedure `open-database' +returning an already open database (procedure), rather than opening the +database file a second time. -Relational Database -=================== + _Note:_ Databases returned by `open-database' do not include + wrappers applied by packages like *Note Embedded Commands::. But + wrapped databases do work as arguments to these functions. - `(require 'relational-database)' +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. - This package implements a database system inspired by the Relational -Model (`E. F. Codd, A Relational Model of Data for Large Shared Data -Banks'). An SLIB relational database implementation can be created -from any *Note Base Table:: implementation. +This next set of procedures mirror the whole-database methods in *Note +Database Operations::. Except for `create-database', each procedure +will accept either a filename or database procedure for its first +argument. -* Menu: + - Function: create-database filename base-table-type + FILENAME should be a string naming a file; or `#f'. | + BASE-TABLE-TYPE must be a symbol naming a feature which can be | + passed to `require'. `create-database' returns a new, open | + relational database (with base-table type BASE-TABLE-TYPE) | + associated with FILENAME, or a new ephemeral database if FILENAME | + is `#f'. | + + `create-database' is the only run-time use of require in SLIB | + which crosses module boundaries. When BASE-TABLE-TYPE is | + `require'd by `create-database'; it adds an association of | + BASE-TABLE-TYPE with its "relational-system" procedure to | + MDBM:*DATABASES*. | + + alist-table is the default base-table type: | + | + (require 'databases) | + (define my-rdb (create-database "my.db" 'alist-table)) | + | +Only `alist-table' and base-table modules which have been `require'd | +will dispatch correctly from the `open-database' procedures. | +Therefore, either pass two arguments to `open-database', or require the | +base-table of your database file uses before calling `open-database' | +with one argument. | + | + - Procedure: open-database! rdb base-table-type | + Returns _mutable_ open relational database or #f. -* Motivations:: Database Manifesto -* Creating and Opening Relational Databases:: -* Relational Database Operations:: -* Table Operations:: -* Catalog Representation:: -* Unresolved Issues:: -* Database Utilities:: 'database-utilities -* Database Reports:: -* Database Browser:: 'database-browse + - Function: open-database rdb base-table-type + Returns an open relational database associated with RDB. The + database will be opened with base-table type BASE-TABLE-TYPE). - -File: slib.info, Node: Motivations, Next: Creating and Opening Relational Databases, Prev: Relational Database, Up: Relational Database + - Function: open-database rdb + Returns an open relational database associated with RDB. + `open-database' will attempt to deduce the correct base-table-type. -Motivations ------------ + - Function: write-database rdb filename + Writes the mutable relational-database RDB to FILENAME. - Most nontrivial programs contain databases: Makefiles, configure -scripts, file backup, calendars, editors, source revision control, CAD -systems, display managers, menu GUIs, games, parsers, debuggers, -profilers, and even error reporting are all rife with databases. Coding -databases is such a common activity in programming that many may not be -aware of how often they do it. - - A database often starts as a dispatch in a program. The author, -perhaps because of the need to make the dispatch configurable, the need -for correlating dispatch in other routines, or because of changes or -growth, devises a data structure to contain the information, a routine -for interpreting that data structure, and perhaps routines for -augmenting and modifying the stored data. The dispatch must be -converted into this form and tested. - - The programmer may need to devise an interactive program for enabling -easy examination and modification of the information contained in this -database. Often, in an attempt to foster modularity and avoid delays in -release, intermediate file formats for the database information are -devised. It often turns out that users prefer modifying these -intermediate files with a text editor to using the interactive program -in order to do operations (such as global changes) not forseen by the -program's author. - - In order to address this need, the conscientious software engineer may -even provide a scripting language to allow users to make repetitive -database changes. Users will grumble that they need to read a large -manual and learn yet another programming language (even if it _almost_ -has language "xyz" syntax) in order to do simple configuration. - - All of these facilities need to be designed, coded, debugged, -documented, and supported; often causing what was very simple in concept -to become a major developement project. - - This view of databases just outlined is somewhat the reverse of the -view of the originators of the "Relational Model" of database -abstraction. The relational model was devised to unify and allow -interoperation of large multi-user databases running on diverse -platforms. A fairly general purpose "Comprehensive Language" for -database manipulations is mandated (but not specified) as part of the -relational model for databases. - - One aspect of the Relational Model of some importance is that the -"Comprehensive Language" must be expressible in some form which can be -stored in the database. This frees the programmer from having to make -programs data-driven in order to use a database. - - This package includes as one of its basic supported types Scheme -"expression"s. This type allows expressions as defined by the Scheme -standards to be stored in the database. Using `slib:eval' retrieved -expressions can be evaluated (in the top-level environment). Scheme's -`lambda' facilitates closure of environments, modularity, etc. so that -procedures (which could not be stored directly most databases) can -still be effectively retrieved. Since `slib:eval' evaluates -expressions in the top-level environment, built-in and user defined -procedures can be easily accessed by name. - - This package's purpose is to standardize (through a common interface) -database creation and usage in Scheme programs. The relational model's -provision for inclusion of language expressions as data as well as the -description (in tables, of course) of all of its tables assures that -relational databases are powerful enough to assume the roles currently -played by thousands of ad-hoc routines and data formats. - -Such standardization to a relational-like model brings many benefits: - - * Tables, fields, domains, and types can be dealt with by name in - programs. - - * The underlying database implementation can be changed (for - performance or other reasons) by changing a single line of code. - - * The formats of tables can be easily extended or changed without - altering code. - - * Consistency checks are specified as part of the table descriptions. - Changes in checks need only occur in one place. - - * All the configuration information which the developer wishes to - group together is easily grouped, without needing to change - programs aware of only some of these tables. - - * Generalized report generators, interactive entry programs, and - other database utilities can be part of a shared library. The - burden of adding configurability to a program is greatly reduced. - - * Scheme is the "comprehensive language" for these databases. - Scripting for configuration no longer needs to be in a separate - language with additional documentation. - - * Scheme's latent types mesh well with the strict typing and logical - requirements of the relational model. - - * Portable formats allow easy interchange of data. The included - table descriptions help prevent misinterpretation of format. - - -File: slib.info, Node: Creating and Opening Relational Databases, Next: Relational Database Operations, Prev: Motivations, Up: Relational Database - -Creating and Opening Relational Databases ------------------------------------------ + - Function: sync-database rdb + Writes the mutable relational-database RDB to the filename it was + opened with. - - Function: make-relational-system base-table-implementation - Returns a procedure implementing a relational database using the - BASE-TABLE-IMPLEMENTATION. - - All of the operations of a base table implementation are accessed - through a procedure defined by `require'ing that implementation. - Similarly, all of the operations of the relational database - implementation are accessed through the procedure returned by - `make-relational-system'. For instance, a new relational database - could be created from the procedure returned by - `make-relational-system' by: - - (require 'alist-table) - (define relational-alist-system - (make-relational-system alist-table)) - (define create-alist-database - (relational-alist-system 'create-database)) - (define my-database - (create-alist-database "mydata.db")) - -What follows are the descriptions of the methods available from -relational system returned by a call to `make-relational-system'. - - - Function: create-database filename - Returns an open, nearly empty relational database associated with - FILENAME. The only tables defined are the system catalog and - domain table. Calling the `close-database' method on this database - and possibly other operations will cause FILENAME to be written - to. If FILENAME is `#f' a temporary, non-disk based database will - be created if such can be supported by the underlying base table - implelentation. If the database cannot be created as specified - `#f' is returned. For the fields and layout of descriptor tables, - *Note Catalog Representation:: - - - Function: open-database filename mutable? - Returns an open relational database associated with FILENAME. If - MUTABLE? is `#t', this database will have methods capable of - effecting change to the database. If MUTABLE? is `#f', only - methods for inquiring the database will be available. Calling the - `close-database' (and possibly other) method on a MUTABLE? - database will cause FILENAME to be written to. If the database - cannot be opened as specified `#f' is returned. - - -File: slib.info, Node: Relational Database Operations, Next: Table Operations, Prev: Creating and Opening Relational Databases, Up: Relational Database - -Relational Database Operations ------------------------------- + - Function: solidify-database rdb + Syncs RDB and makes it immutable. -These are the descriptions of the methods available from an open -relational database. A method is retrieved from a database by calling -the database with the symbol name of the operation. For example: + - Function: close-database rdb + RDB will only be closed when the count of `open-database' - + `close-database' calls for RDB (and its filename) is 0. + `close-database' returns #t if successful; and #f otherwise. - (define my-database - (create-alist-database "mydata.db")) - (define telephone-table-desc - ((my-database 'create-table) 'telephone-table-desc)) - - - Function: close-database - Causes the relational database to be written to its associated - file (if any). If the write is successful, subsequent operations - to this database will signal an error. If the operations completed - successfully, `#t' is returned. Otherwise, `#f' is returned. - - - Function: write-database filename - Causes the relational database to be written to FILENAME. If the - write is successful, also causes the database to henceforth be - associated with FILENAME. Calling the `close-database' (and - possibly other) method on this database will cause FILENAME to be - written to. If FILENAME is `#f' this database will be changed to - a temporary, non-disk based database if such can be supported by - the underlying base table implelentation. If the operations - completed successfully, `#t' is returned. Otherwise, `#f' is - returned. + - Function: mdbm:report + Prints a table of open database files. The columns are the + base-table type, number of opens, `!' for mutable, the filename, + and the lock certificate (if locked). - - Function: sync-database - Causes any pending updates to the database file to be written out. - If the operations completed successfully, `#t' is returned. - Otherwise, `#f' is returned. + (mdbm:report) + -| + alist-table 003 /usr/local/lib/slib/clrnamdb.scm + alist-table 001 ! sdram.db jaffer@aubrey.jaffer.3166:1038628199 - - Function: table-exists? table-name - Returns `#t' if TABLE-NAME exists in the system catalog, otherwise - returns `#f'. +Opening Tables | +.............. | + | + - Function: open-table rdb table-name | + RDB must be a relational database and TABLE-NAME a symbol. | + | + `open-table' returns a "methods" procedure for an existing | + relational table in RDB if it exists and can be opened for | + reading, otherwise returns `#f'. | + | + - Procedure: open-table! rdb table-name | + RDB must be a relational database and TABLE-NAME a symbol. | + | + `open-table!' returns a "methods" procedure for an existing | + relational table in RDB if it exists and can be opened in mutable | + mode, otherwise returns `#f'. | + | +Defining Tables +............... + + - Function: define-domains rdb row5 ... | + Adds the domain rows ROW5 ... to the `*domains-data*' table in | + RDB. The format of the row is given in *Note Catalog + Representation::. | + | + (define-domains rdb '(permittivity #f complex? c64 #f)) | + | + - Function: add-domain rdb row5 | + Use `define-domains' instead. | + | + - Function: define-tables rdb spec-0 ... + Adds tables as specified in SPEC-0 ... to the open + relational-database RDB. Each SPEC has the form: - - Function: open-table table-name mutable? - Returns a "methods" procedure for an existing relational table in - this database if it exists and can be opened in the mode indicated - by MUTABLE?, otherwise returns `#f'. + (<name> <descriptor-name> <descriptor-name> <rows>) + or + (<name> <primary-key-fields> <other-fields> <rows>) -These methods will be present only in databases which are MUTABLE?. + where <name> is the table name, <descriptor-name> is the symbol + name of a descriptor table, <primary-key-fields> and + <other-fields> describe the primary keys and other fields + respectively, and <rows> is a list of data rows to be added to the + table. - - Function: delete-table table-name - Removes and returns the TABLE-NAME row from the system catalog if - the table or view associated with TABLE-NAME gets removed from the - database, and `#f' otherwise. + <primary-key-fields> and <other-fields> are lists of field + descriptors of the form: - - Function: create-table table-desc-name - Returns a methods procedure for a new (open) relational table for - describing the columns of a new base table in this database, - otherwise returns `#f'. For the fields and layout of descriptor - tables, *Note Catalog Representation::. + (<column-name> <domain>) + or + (<column-name> <domain> <column-integrity-rule>) - - Function: create-table table-name table-desc-name - Returns a methods procedure for a new (open) relational table with - columns as described by TABLE-DESC-NAME, otherwise returns `#f'. + where <column-name> is the column name, <domain> is the domain of + the column, and <column-integrity-rule> is an expression whose + value is a procedure of one argument (which returns `#f' to signal + an error). - - Function: create-view ?? - - Function: project-table ?? - - Function: restrict-table ?? - - Function: cart-prod-tables ?? - Not yet implemented. + If <domain> is not a defined domain name and it matches the name of + this table or an already defined (in one of SPEC-0 ...) single key + field table, a foreign-key domain will be created for it. | - -File: slib.info, Node: Table Operations, Next: Catalog Representation, Prev: Relational Database Operations, Up: Relational Database +Listing Tables +.............. -Table Operations ----------------- + - Function: list-table-definition rdb table-name + If symbol TABLE-NAME exists in the open relational-database 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 `list-table-definition', when passed as an + argument to `define-tables', will recreate the table. + + +File: slib.info, Node: Table Operations, Next: Database Interpolation, Prev: Using Databases, Up: Relational Database + | +Table Operations | +---------------- | These are the descriptions of the methods available from an open -relational table. A method is retrieved from a table by calling the -table with the symbol name of the operation. For example: +relational table. A method is retrieved from a table by calling the | +table with the symbol name of the operation. For example: | + + ((plat 'get 'processor) 'djgpp) => i386 | + +Some operations described below require primary key arguments. Primary | +keys arguments are denoted KEY1 KEY2 .... It is an error to call an | +operation for a table which takes primary key arguments with the wrong | +number of primary keys for that table. | + + - Operation on relational-table: get column-name | + Returns a procedure of arguments KEY1 KEY2 ... which returns the | + value for the COLUMN-NAME column of the row associated with | + primary keys KEY1, KEY2 ... if that row exists in the table, or | + `#f' otherwise. | + + ((plat 'get 'processor) 'djgpp) => i386 | + ((plat 'get 'processor) 'be-os) => #f | + +* Menu: | + +* Single Row Operations:: | +* Match-Keys:: | +* Multi-Row Operations:: | +* Indexed Sequential Access Methods:: | +* Sequential Index Operations:: | +* Table Administration:: | + + +File: slib.info, Node: Single Row Operations, Next: Match-Keys, Prev: Table Operations, Up: Table Operations + | +Single Row Operations | +..................... | + +The term "row" used below refers to a Scheme list of values (one for | +each column) in the order specified in the descriptor (table) for this | +table. Missing values appear as `#f'. Primary keys must not be | +missing. | + | + - Operation on relational-table: row:insert | + Adds the row ROW to this table. If a row for the primary key(s) | + specified by ROW already exists in this table an error is | + signaled. The value returned is unspecified. | (define telephone-table-desc - ((my-database 'create-table) 'telephone-table-desc)) - (require 'common-list-functions) + ((my-database 'create-table) 'telephone-table-desc)) | (define ndrp (telephone-table-desc 'row:insert)) (ndrp '(1 #t name #f string)) (ndrp '(2 #f telephone @@ -6448,38 +8483,70 @@ table with the symbol name of the operation. For example: (string->list d)))) string)) -Some operations described below require primary key arguments. Primary -keys arguments are denoted KEY1 KEY2 .... It is an error to call an -operation for a table which takes primary key arguments with the wrong -number of primary keys for that table. - -The term "row" used below refers to a Scheme list of values (one for -each column) in the order specified in the descriptor (table) for this -table. Missing values appear as `#f'. Primary keys must not be -missing. + - Operation on relational-table: row:update | + Returns a procedure of one argument, ROW, which adds the row, ROW, | + to this table. If a row for the primary key(s) specified by ROW | + already exists in this table, it will be overwritten. The value | + returned is unspecified. | - - Function: get column-name + - Operation on relational-table: row:retrieve | Returns a procedure of arguments KEY1 KEY2 ... which returns the - value for the COLUMN-NAME column of the row associated with - primary keys KEY1, KEY2 ... if that row exists in the table, or + row associated with primary keys KEY1, KEY2 ... if it exists, or | `#f' otherwise. - ((plat 'get 'processor) 'djgpp) => i386 - ((plat 'get 'processor) 'be-os) => #f + ((plat 'row:retrieve) 'linux) => (linux i386 linux gcc) | + ((plat 'row:retrieve) 'multics) => #f | - - Function: get* column-name + - Operation on relational-table: row:remove | + Returns a procedure of arguments KEY1 KEY2 ... which removes and | + returns the row associated with primary keys KEY1, KEY2 ... if it | + exists, or `#f' otherwise. | + | + - Operation on relational-table: row:delete | + Returns a procedure of arguments KEY1 KEY2 ... which deletes the | + row associated with primary keys KEY1, KEY2 ... if it exists. The | + value returned is unspecified. | + | + +File: slib.info, Node: Match-Keys, Next: Multi-Row Operations, Prev: Single Row Operations, Up: Table Operations + | +Match-Keys | +.......... | + | +The (optional) MATCH-KEY1 ... arguments are used to restrict actions of | +a whole-table operation to a subset of that table. Those procedures | +(returned by methods) which accept match-key arguments will accept any | +number of match-key arguments between zero and the number of primary | +keys in the table. Any unspecified MATCH-KEY arguments default to `#f'. | + | +The MATCH-KEY1 ... restrict the actions of the table command to those | +records whose primary keys each satisfy the corresponding MATCH-KEY | +argument. The arguments and their actions are: | + | + `#f' | + The false value matches any key in the corresponding position. | + | + an object of type procedure | + This procedure must take a single argument, the key in the | + corresponding position. Any key for which the procedure | + returns a non-false value is a match; Any key for which the | + procedure returns a `#f' is not. | + | + other values | + Any other value matches only those keys `equal?' to it. | + | + - Operation on relational-table: get* column-name | Returns a procedure of optional arguments MATCH-KEY1 ... which returns a list of the values for the specified column for all rows in this table. The optional MATCH-KEY1 ... arguments restrict - actions to a subset of the table. See the match-key description - below for details. + actions to a subset of the table. | ((plat 'get* 'processor)) => - (i386 8086 i386 8086 i386 i386 8086 m68000 + (i386 i8086 i386 i8086 i386 i386 i8086 m68000 | m68000 m68000 m68000 m68000 powerpc) ((plat 'get* 'processor) #f) => - (i386 8086 i386 8086 i386 i386 8086 m68000 + (i386 i8086 i386 i8086 i386 i386 i8086 m68000 | m68000 m68000 m68000 m68000 powerpc) (define (a-key? key) @@ -6492,19 +8559,17 @@ missing. (atari-st-turbo-c atari-st-gcc amiga-sas/c-5.10 amiga-aztec amiga-dice-c aix) - - Function: row:retrieve - Returns a procedure of arguments KEY1 KEY2 ... which returns the - row associated with primary keys KEY1, KEY2 ... if it exists, or - `#f' otherwise. - - ((plat 'row:retrieve) 'linux) => (linux i386 linux gcc) - ((plat 'row:retrieve) 'multics) => #f + +File: slib.info, Node: Multi-Row Operations, Next: Indexed Sequential Access Methods, Prev: Match-Keys, Up: Table Operations + | +Multi-Row Operations | +.................... | - - Function: row:retrieve* - Returns a procedure of optional arguments MATCH-KEY1 ... which + - Operation on relational-table: row:retrieve* | + Returns a procedure of optional arguments MATCH-KEY1 ... which returns a list of all rows in this table. The optional MATCH-KEY1 - ... arguments restrict actions to a subset of the table. See the - match-key description below for details. + ... arguments restrict actions to a subset of the table. For | + details see *Note Match-Keys::. | ((plat 'row:retrieve*) a-key?) => ((atari-st-turbo-c m68000 atari turbo-c) @@ -6514,278 +8579,358 @@ missing. (amiga-dice-c m68000 amiga dice-c) (aix powerpc aix -)) - - Function: row:remove - Returns a procedure of arguments KEY1 KEY2 ... which removes and - returns the row associated with primary keys KEY1, KEY2 ... if it - exists, or `#f' otherwise. - - - Function: row:remove* + - Operation on relational-table: row:remove* | Returns a procedure of optional arguments MATCH-KEY1 ... which removes and returns a list of all rows in this table. The optional - MATCH-KEY1 ... arguments restrict actions to a subset of the - table. See the match-key description below for details. + MATCH-KEY1 ... arguments restrict actions to a subset of the table. | - - Function: row:delete - Returns a procedure of arguments KEY1 KEY2 ... which deletes the - row associated with primary keys KEY1, KEY2 ... if it exists. The - value returned is unspecified. - - - Function: row:delete* - Returns a procedure of optional arguments MATCH-KEY1 ... which + - Operation on relational-table: row:delete* | + Returns a procedure of optional arguments MATCH-KEY1 ... which Deletes all rows from this table. The optional MATCH-KEY1 ... - arguments restrict deletions to a subset of the table. See the - match-key description below for details. The value returned is - unspecified. The descriptor table and catalog entry for this - table are not affected. - - - Function: row:update - Returns a procedure of one argument, ROW, which adds the row, ROW, - to this table. If a row for the primary key(s) specified by ROW - already exists in this table, it will be overwritten. The value - returned is unspecified. - - - Function: row:update* + arguments restrict deletions to a subset of the table. The value | + returned is unspecified. The descriptor table and catalog entry | + for this table are not affected. | + + - Operation on relational-table: for-each-row | + Returns a procedure of arguments PROC MATCH-KEY1 ... which calls | + PROC with each ROW in this table. The optional MATCH-KEY1 ... | + arguments restrict actions to a subset of the table. For details | + see *Note Match-Keys::. | + +Note that `row:insert*' and `row:update*' do _not_ use match-keys. | + | + - Operation on relational-table: row:insert* | Returns a procedure of one argument, ROWS, which adds each row in the list of rows, ROWS, to this table. If a row for the primary key specified by an element of ROWS already exists in this table, - it will be overwritten. The value returned is unspecified. + an error is signaled. The value returned is unspecified. | - - Function: row:insert - Adds the row ROW to this table. If a row for the primary key(s) - specified by ROW already exists in this table an error is - signaled. The value returned is unspecified. - - - Function: row:insert* + - Operation on relational-table: row:update* | Returns a procedure of one argument, ROWS, which adds each row in the list of rows, ROWS, to this table. If a row for the primary key specified by an element of ROWS already exists in this table, - an error is signaled. The value returned is unspecified. + it will be overwritten. The value returned is unspecified. | - - Function: for-each-row + +File: slib.info, Node: Indexed Sequential Access Methods, Next: Sequential Index Operations, Prev: Multi-Row Operations, Up: Table Operations + | +Indexed Sequential Access Methods | +................................. | + | +"Indexed Sequential Access Methods" are a way of arranging database | +information so that records can be accessed both by key and by key | +sequence (ordering). "ISAM" is not part of Codd's relational model. | +Hardcore relational programmers might use some least-upper-bound join | +for every row to get them into an order. | + | +Associative memory in B-Trees is an example of a database | +implementation which can support a native key ordering. SLIB's | +`alist-table' implementation uses `sort' to implement | +`for-each-row-in-order', but does not support `isam-next' and | +`isam-prev'. | + | +The multi-primary-key ordering employed by these operations is the | +lexicographic collation of those primary-key fields in their given | +order. For example: | + | + (12 a 34) < (12 a 36) < (12 b 1) < (13 a 0) | + | + +File: slib.info, Node: Sequential Index Operations, Next: Table Administration, Prev: Indexed Sequential Access Methods, Up: Table Operations + | +Sequential Index Operations | +........................... | + | +The following procedures are individually optional depending on the | +base-table implememtation. If an operation is _not_ supported, then | +calling the table with that operation symbol will return false. | + | + - Operation on relational-table: for-each-row-in-order | Returns a procedure of arguments PROC MATCH-KEY1 ... which calls PROC with each ROW in this table in the (implementation-dependent) - natural ordering for rows. The optional MATCH-KEY1 ... arguments - restrict actions to a subset of the table. See the match-key - description below for details. - - _Real_ relational programmers would use some least-upper-bound join - for every row to get them in order; But we don't have joins yet. - -The (optional) MATCH-KEY1 ... arguments are used to restrict actions of -a whole-table operation to a subset of that table. Those procedures -(returned by methods) which accept match-key arguments will accept any -number of match-key arguments between zero and the number of primary -keys in the table. Any unspecified MATCH-KEY arguments default to `#f'. - -The MATCH-KEY1 ... restrict the actions of the table command to those -records whose primary keys each satisfy the corresponding MATCH-KEY -argument. The arguments and their actions are: - - `#f' - The false value matches any key in the corresponding position. - - an object of type procedure - This procedure must take a single argument, the key in the - corresponding position. Any key for which the procedure - returns a non-false value is a match; Any key for which the - procedure returns a `#f' is not. - - other values - Any other value matches only those keys `equal?' to it. - - - Function: close-table - Subsequent operations to this table will signal an error. - - - Constant: column-names - - Constant: column-foreigns - - Constant: column-domains - - Constant: column-types + natural, repeatable ordering for rows. The optional MATCH-KEY1 | + ... arguments restrict actions to a subset of the table. For | + details see *Note Match-Keys::. | + + - Operation on relational-table: isam-next | + Returns a procedure of arguments KEY1 KEY2 ... which returns the | + key-list identifying the lowest record higher than KEY1 KEY2 ... | + which is stored in the relational-table; or false if no higher | + record is present. | + + - Operation on relational-table: isam-next column-name | + The symbol COLUMN-NAME names a key field. In the list returned by | + `isam-next', that field, or a field to its left, will be changed. | + This allows one to skip over less significant key fields. | + + - Operation on relational-table: isam-prev | + Returns a procedure of arguments KEY1 KEY2 ... which returns the | + key-list identifying the highest record less than KEY1 KEY2 ... | + which is stored in the relational-table; or false if no lower | + record is present. | + + - Operation on relational-table: isam-prev index | + The symbol COLUMN-NAME names a key field. In the list returned by | + `isam-next', that field, or a field to its left, will be changed. | + This allows one to skip over less significant key fields. | + + For example, if a table has key fields: | + (col1 col2) | + (9 5) | + (9 6) | + (9 7) | + (9 8) | + (12 5) | + (12 6) | + (12 7) | + + Then: | + ((table 'isam-next) '(9 5)) => (9 6) | + ((table 'isam-next 'col2) '(9 5)) => (9 6) | + ((table 'isam-next 'col1) '(9 5)) => (12 5) | + ((table 'isam-prev) '(12 7)) => (12 6) | + ((table 'isam-prev 'col2) '(12 7)) => (12 6) | + ((table 'isam-prev 'col1) '(12 7)) => (9 8) | + + +File: slib.info, Node: Table Administration, Prev: Sequential Index Operations, Up: Table Operations + | +Table Administration | +.................... | + | + - Operation on relational-table: column-names | + - Operation on relational-table: column-foreigns | + - Operation on relational-table: column-domains | + - Operation on relational-table: column-types | Return a list of the column names, foreign-key table names, domain names, or type names respectively for this table. These 4 methods are different from the others in that the list is returned, rather than a procedure to obtain the list. - - Constant: primary-limit + - Operation on relational-table: primary-limit | Returns the number of primary keys fields in the relations in this table. + - Operation on relational-table: close-table | + Subsequent operations to this table will signal an error. | + | -File: slib.info, Node: Catalog Representation, Next: Unresolved Issues, Prev: Table Operations, Up: Relational Database - -Catalog Representation +File: slib.info, Node: Database Interpolation, Next: Embedded Commands, Prev: Table Operations, Up: Relational Database + | +Database Interpolation | ---------------------- -Each database (in an implementation) has a "system catalog" which -describes all the user accessible tables in that database (including -itself). - -The system catalog base table has the following fields. `PRI' -indicates a primary key for that table. - - PRI table-name - column-limit the highest column number - coltab-name descriptor table name - bastab-id data base table identifier - user-integrity-rule - view-procedure A scheme thunk which, when called, - produces a handle for the view. coltab - and bastab are specified if and only if - view-procedure is not. - -Descriptors for base tables (not views) are tables (pointed to by -system catalog). Descriptor (base) tables have the fields: - - PRI column-number sequential integers from 1 - primary-key? boolean TRUE for primary key components - column-name - column-integrity-rule - domain-name - -A "primary key" is any column marked as `primary-key?' in the -corresponding descriptor table. All the `primary-key?' columns must -have lower column numbers than any non-`primary-key?' columns. Every -table must have at least one primary key. Primary keys must be -sufficient to distinguish all rows from each other in the table. All of -the system defined tables have a single primary key. - -This package currently supports tables having from 1 to 4 primary keys -if there are non-primary columns, and any (natural) number if _all_ -columns are primary keys. If you need more than 4 primary keys, I would -like to hear what you are doing! - -A "domain" is a category describing the allowable values to occur in a -column. It is described by a (base) table with the fields: - - PRI domain-name - foreign-table - domain-integrity-rule - type-id - type-param - -The "type-id" field value is a symbol. This symbol may be used by the -underlying base table implementation in storing that field. - -If the `foreign-table' field is non-`#f' then that field names a table -from the catalog. The values for that domain must match a primary key -of the table referenced by the TYPE-PARAM (or `#f', if allowed). This -package currently does not support composite foreign-keys. - -The types for which support is planned are: - atom - symbol - string [<length>] - number [<base>] - money <currency> - date-time - boolean - - foreign-key <table-name> - expression - virtual <expression> +`(require 'database-interpolate)' | - -File: slib.info, Node: Unresolved Issues, Next: Database Utilities, Prev: Catalog Representation, Up: Relational Database +Indexed sequential access methods allow finding the keys (having | +associations) closest to a given value. This facilitates the | +interpolation of associations between those in the table. | -Unresolved Issues ------------------ + - Function: interpolate-from-table table column | + TABLE should be a relational table with one numeric primary key | + field which supports the `isam-prev' and `isam-next' operations. | + COLUMN should be a symbol or exact positive integer designating a | + numerically valued column of TABLE. | - Although `rdms.scm' is not large, I found it very difficult to write -(six rewrites). I am not aware of any other examples of a generalized -relational system (although there is little new in CS). I left out -several aspects of the Relational model in order to simplify the job. -The major features lacking (which might be addressed portably) are -views, transaction boundaries, and protection. - - Protection needs a model for specifying priveledges. Given how -operations are accessed from handles it should not be difficult to -restrict table accesses to those allowed for that user. - - The system catalog has a field called `view-procedure'. This should -allow a purely functional implementation of views. This will work but -is unsatisfying for views resulting from a "select"ion (subset of -rows); for whole table operations it will not be possible to reduce the -number of keys scanned over when the selection is specified only by an -opaque procedure. - - Transaction boundaries present the most intriguing area. Transaction -boundaries are actually a feature of the "Comprehensive Language" of the -Relational database and not of the database. Scheme would seem to -provide the opportunity for an extremely clean semantics for transaction -boundaries since the builtin procedures with side effects are small in -number and easily identified. - - These side-effect builtin procedures might all be portably redefined -to versions which properly handled transactions. Compiled library -routines would need to be recompiled as well. Many system extensions -(delete-file, system, etc.) would also need to be redefined. - -There are 2 scope issues that must be resolved for multiprocess -transaction boundaries: - -Process scope - The actions captured by a transaction should be only for the - process which invoked the start of transaction. Although standard - Scheme does not provide process primitives as such, `dynamic-wind' - would provide a workable hook into process switching for many - implementations. - -Shared utilities with state - Some shared utilities have state which should _not_ be part of a - transaction. An example would be calling a pseudo-random number - generator. If the success of a transaction depended on the - pseudo-random number and failed, the state of the generator would - be set back. Subsequent calls would keep returning the same - number and keep failing. - - Pseudo-random number generators are not reentrant; thus they would - require locks in order to operate properly in a multiprocess - environment. Are all examples of utilities whose state should not - be part of transactions also non-reentrant? If so, perhaps - suspending transaction capture for the duration of locks would - solve this problem. - - -File: slib.info, Node: Database Utilities, Next: Database Reports, Prev: Unresolved Issues, Up: Relational Database - -Database Utilities ------------------- + `interpolate-from-table' calculates and returns a value | + proportionally intermediate between its values in the next and | + previous key records contained in TABLE. For keys larger than all | + the stored keys the value associated with the largest stored key | + is used. For keys smaller than all the stored keys the value | + associated with the smallest stored key is used. | + + +File: slib.info, Node: Embedded Commands, Next: Database Macros, Prev: Database Interpolation, Up: Relational Database + | +Embedded Commands +----------------- - `(require 'database-utilities)' +`(require 'database-commands)' This enhancement wraps a utility layer on `relational-database' which provides: - * Automatic loading of the appropriate base-table package when - opening a database. * Automatic execution of initialization commands stored in database. * Transparent execution of database commands stored in `*commands*' table in database. -Also included are utilities which provide: - * Data definition from Scheme lists and + When an enhanced relational-database is called with a symbol which +matches a NAME in the `*commands*' table, the associated procedure +expression is evaluated and applied to the enhanced +relational-database. A procedure should then be returned which the user +can invoke on (optional) arguments. + + The command `*initialize*' is special. If present in the +`*commands*' table, `open-database' or `open-database!' will return the +value of the `*initialize*' command. Notice that arbitrary code can be +run when the `*initialize*' procedure is automatically applied to the +enhanced relational-database. - * Report generation + Note also that if you wish to shadow or hide from the user +relational-database methods described in *Note Database Operations::, +this can be done by a dispatch in the closure returned by the +`*initialize*' expression rather than by entries in the `*commands*' +table if it is desired that the underlying methods remain accessible to +code in the `*commands*' table. -for any SLIB relational database. +* Menu: - - Function: create-database filename base-table-type - Returns an open, nearly empty enhanced (with `*commands*' table) - relational database (with base-table type BASE-TABLE-TYPE) - associated with FILENAME. +* Database Extension:: +* Command Intrinsics:: +* Define-tables Example:: +* The *commands* Table:: +* Command Service:: +* Command Example:: + + +File: slib.info, Node: Database Extension, Next: Command Intrinsics, Prev: Embedded Commands, Up: Embedded Commands + +Database Extension +.................. - - Function: open-database filename - - Function: open-database filename base-table-type - Returns an open enchanced relational database associated with + - Function: wrap-command-interface rdb + Returns relational database RDB wrapped with additional commands + defined in its *commands* table. + + - Function: add-command-tables rdb + The relational database RDB must be mutable. ADD-COMMAND-TABLES + adds a *command* table to RDB; then returns + `(wrap-command-interface RDB)'. + + - Function: define-*commands* rdb spec-0 ... + Adds commands to the `*commands*' table as specified in SPEC-0 ... + to the open relational-database RDB. Each SPEC has the form: + + ((<name> <rdb>) "comment" <expression1> <expression2> ...) + or + ((<name> <rdb>) <expression1> <expression2> ...) + + where <name> is the command name, <rdb> is a formal passed the + calling relational database, "comment" describes the command, and + <expression1>, <expression1>, ... are the body of the procedure. + + `define-*commands*' adds to the `*commands*' table a command + <name>: + + (lambda (<name> <rdb>) <expression1> <expression2> ...) + + + - Function: open-command-database filename + - Function: open-command-database filename base-table-type + Returns an open enhanced relational database associated with FILENAME. The database will be opened with base-table type BASE-TABLE-TYPE) if supplied. If BASE-TABLE-TYPE is not supplied, - `open-database' will attempt to deduce the correct + `open-command-database' will attempt to deduce the correct base-table-type. If the database can not be opened or if it lacks the `*commands*' table, `#f' is returned. - - Function: open-database! filename - - Function: open-database! filename base-table-type - Returns _mutable_ open enchanced relational database ... + - Function: open-command-database! filename + - Function: open-command-database! filename base-table-type + Returns _mutable_ open enhanced relational database ... + + - Function: open-command-database database + Returns DATABASE if it is an immutable relational database; #f + otherwise. + + - Function: open-command-database! database + Returns DATABASE if it is a mutable relational database; #f + otherwise. + + +File: slib.info, Node: Command Intrinsics, Next: Define-tables Example, Prev: Database Extension, Up: Embedded Commands + +Command Intrinsics +.................. + +Some commands are defined in all extended relational-databases. The are +called just like *Note Database Operations::. + + - Operation on relational-database: add-domain domain-row | + Adds DOMAIN-ROW to the "domains" table if there is no row in the + domains table associated with key `(car DOMAIN-ROW)' and returns + `#t'. Otherwise returns `#f'. + + For the fields and layout of the domain table, *Note Catalog + Representation::. Currently, these fields are + * domain-name + + * foreign-table + + * domain-integrity-rule + + * type-id + + * type-param + + The following example adds 3 domains to the `build' database. + `Optstring' is either a string or `#f'. `filename' is a string + and `build-whats' is a symbol. + + (for-each (build 'add-domain) + '((optstring #f + (lambda (x) (or (not x) (string? x))) + string + #f) + (filename #f #f string #f) + (build-whats #f #f symbol #f))) + + - Operation on relational-database: delete-domain domain-name | + Removes and returns the DOMAIN-NAME row from the "domains" table. + + - Operation on relational-database: domain-checker domain | + Returns a procedure to check an argument for conformance to domain + DOMAIN. + + +File: slib.info, Node: Define-tables Example, Next: The *commands* Table, Prev: Command Intrinsics, Up: Embedded Commands + +Define-tables Example +..................... + +The following example shows a new database with the name of `foo.db' +being created with tables describing processor families and +processor/os/compiler combinations. The database is then solidified; +saved and changed to immutable. + + (require 'databases) + (define my-rdb (create-database "foo.db" 'alist-table)) + (define-tables my-rdb + '(processor-family + ((family atom)) + ((also-ran processor-family)) + ((m68000 #f) + (m68030 m68000) + (i386 i8086) | + (i8086 #f) | + (powerpc #f))) + + '(platform + ((name symbol)) + ((processor processor-family) + (os symbol) + (compiler symbol)) + ((aix powerpc aix -) + (amiga-dice-c m68000 amiga dice-c) + (amiga-aztec m68000 amiga aztec) + (amiga-sas/c-5.10 m68000 amiga sas/c) + (atari-st-gcc m68000 atari gcc) + (atari-st-turbo-c m68000 atari turbo-c) + (borland-c-3.1 i8086 ms-dos borland-c) | + (djgpp i386 ms-dos gcc) + (linux i386 linux gcc) + (microsoft-c i8086 ms-dos microsoft-c) | + (os/2-emx i386 os/2 gcc) + (turbo-c-2 i8086 ms-dos turbo-c) | + (watcom-9.0 i386 ms-dos watcom)))) + + (solidify-database my-rdb) + + +File: slib.info, Node: The *commands* Table, Next: Command Service, Prev: Define-tables Example, Up: Embedded Commands + +The *commands* Table +.................... The table `*commands*' in an "enhanced" relational-database has the fields (with domains): @@ -6802,7 +8947,7 @@ The intent of this table is to be of a form such that different user-interfaces (for instance, pull-down menus or plain-text queries) can operate from the same table. A `parameter-list' table has the following fields: - PRI index uint + PRI index ordinal | name symbol arity parameter-arity domain domain @@ -6843,27 +8988,11 @@ of the default value or values as appropriate. Note that since the needed for this column, "sticky" defaults can be implemented using shared state with the domain-integrity-rule. -Invoking Commands -................. - - When an enhanced relational-database is called with a symbol which -matches a NAME in the `*commands*' table, the associated procedure -expression is evaluated and applied to the enhanced -relational-database. A procedure should then be returned which the user -can invoke on (optional) arguments. - - The command `*initialize*' is special. If present in the -`*commands*' table, `open-database' or `open-database!' will return the -value of the `*initialize*' command. Notice that arbitrary code can be -run when the `*initialize*' procedure is automatically applied to the -enhanced relational-database. + +File: slib.info, Node: Command Service, Next: Command Example, Prev: The *commands* Table, Up: Embedded Commands - Note also that if you wish to shadow or hide from the user -relational-database methods described in *Note Relational Database -Operations::, this can be done by a dispatch in the closure returned by -the `*initialize*' expression rather than by entries in the -`*commands*' table if it is desired that the underlying methods remain -accessible to code in the `*commands*' table. +Command Service +............... - Function: make-command-server rdb table-name Returns a procedure of 2 arguments, a (symbol) command and a @@ -6910,16 +9039,26 @@ accessible to code in the `*commands*' table. A list of lists of `(alias parameter-name)'. There can be more than one alias per PARAMETER-NAME. - For information about parameters, *Note Parameter lists::. Here is an -example of setting up a command with arguments and parsing those -arguments from a `getopt' style argument list (*note Getopt::). +For information about parameters, *Note Parameter lists::. - (require 'database-utilities) - (require 'fluid-let) + +File: slib.info, Node: Command Example, Prev: Command Service, Up: Embedded Commands + +Command Example +............... + +Here is an example of setting up a command with arguments and parsing +those arguments from a `getopt' style argument list (*note Getopt::). + + (require 'database-commands) + (require 'databases) + (require 'getopt-parameters) (require 'parameters) (require 'getopt) + (require 'fluid-let) + (require 'printf) - (define my-rdb (create-database #f 'alist-table)) + (define my-rdb (add-command-tables (create-database #f 'alist-table))) (define-tables my-rdb '(foo-params @@ -6931,13 +9070,13 @@ arguments from a `getopt' style argument list (*note Getopt::). (lambda (pl) '()) #f "zero or more symbols") (3 nary1-symbols nary1 symbol (lambda (pl) '(symb)) #f "one or more symbols") - (4 optional-number optional uint + (4 optional-number optional ordinal | (lambda (pl) '()) #f "zero or one number") (5 flag boolean boolean (lambda (pl) '(#f)) #f "a boolean flag"))) '(foo-pnames ((name string)) - ((parameter-index uint)) + ((parameter-index ordinal)) | (("s" 1) ("single-string" 1) ("n" 2) @@ -6960,15 +9099,13 @@ arguments from a `getopt' style argument list (*note Getopt::). (lambda (rdb) (lambda args (print args))) "test command arguments")))) - (define (dbutil:serve-command-line rdb command-table - command argc argv) - (set! argv (if (vector? argv) (vector->list argv) argv)) + (define (dbutil:serve-command-line rdb command-table command argv) + (set! *argv* (if (vector? argv) (vector->list argv) argv)) ((make-command-server rdb command-table) command (lambda (comname comval options positions arities types defaulters dirs aliases) - (apply comval (getopt->arglist - argc argv options positions + (apply comval (getopt->arglist options positions arities types defaulters dirs aliases))))) (define (cmd . opts) @@ -7016,56 +9153,53 @@ arguments from a `getopt' style argument list (*note Getopt::). ERROR: getopt->parameter-list "unrecognized option" "-?" - Some commands are defined in all extended relational-databases. The -are called just like *Note Relational Database Operations::. + +File: slib.info, Node: Database Macros, Next: Database Browser, Prev: Embedded Commands, Up: Relational Database + | +Database Macros +--------------- - - Function: add-domain domain-row - Adds DOMAIN-ROW to the "domains" table if there is no row in the - domains table associated with key `(car DOMAIN-ROW)' and returns - `#t'. Otherwise returns `#f'. +`(require 'within-database)' - For the fields and layout of the domain table, *Note Catalog - Representation::. Currently, these fields are - * domain-name + The object-oriented programming interface to SLIB relational databases +has failed to support clear, understandable, and modular code-writing +for database applications. - * foreign-table + This seems to be a failure of the object-oriented paradigm where the +type of an object is not manifest (or even traceable) in source code. - * domain-integrity-rule + `within-database', along with the `databases' package, reorganizes +high-level database functions toward a more declarative style. Using +this package, one can tag database table and command declarations for +emacs: - * type-id + etags -lscheme -r'/ *(define-\(command\|table\) (\([^; \t]+\)/\2/' \ + source1.scm ... - * type-param +* Menu: - The following example adds 3 domains to the `build' database. - `Optstring' is either a string or `#f'. `filename' is a string - and `build-whats' is a symbol. +* Within-database Example:: - (for-each (build 'add-domain) - '((optstring #f - (lambda (x) (or (not x) (string? x))) - string - #f) - (filename #f #f string #f) - (build-whats #f #f symbol #f))) + - Function: within-database database statement-1 ... + `within-database' creates a lexical scope in which the commands + `define-table' and `define-command' create tables and + `*commands*'-table entries respectively in open relational + database DATABASE. - - Function: delete-domain domain-name - Removes and returns the DOMAIN-NAME row from the "domains" table. + `within-database' Returns DATABASE. - - Function: domain-checker domain - Returns a procedure to check an argument for conformance to domain - DOMAIN. - -Defining Tables -............... + - Syntax: define-command (<name> <rdb>) "comment" <expression1> + <expression2> ... + - Syntax: define-command (<name> <rdb>) <expression1> <expression2> ... + Adds to the `*commands*' table a command <name>: - - Procedure: define-tables rdb spec-0 ... - Adds tables as specified in SPEC-0 ... to the open - relational-database RDB. Each SPEC has the form: + (lambda (<name> <rdb>) <expression1> <expression2> ...) - (<name> <descriptor-name> <descriptor-name> <rows>) - or - (<name> <primary-key-fields> <other-fields> <rows>) + - Syntax: define-table <name> <descriptor-name> <descriptor-name> + <rows> + - Syntax: define-table <name> <primary-key-fields> <other-fields> + <rows> where <name> is the table name, <descriptor-name> is the symbol name of a descriptor table, <primary-key-fields> and <other-fields> describe the primary keys and other fields @@ -7086,203 +9220,676 @@ Defining Tables If <domain> is not a defined domain name and it matches the name of this table or an already defined (in one of SPEC-0 ...) single key - field table, a foriegn-key domain will be created for it. + field table, a foreign-key domain will be created for it. | -The following example shows a new database with the name of `foo.db' -being created with tables describing processor families and -processor/os/compiler combinations. -The database command `define-tables' is defined to call `define-tables' -with its arguments. The database is also configured to print `Welcome' -when the database is opened. The database is then closed and reopened. + +File: slib.info, Node: Within-database Example, Prev: Database Macros, Up: Database Macros - (require 'database-utilities) - (define my-rdb (create-database "foo.db" 'alist-table)) - - (define-tables my-rdb - '(*commands* - ((name symbol)) - ((parameters parameter-list) - (procedure expression) - (documentation string)) - ((define-tables - no-parameters - no-parameter-names - (lambda (rdb) (lambda specs (apply define-tables rdb specs))) - "Create or Augment tables from list of specs") - (*initialize* - no-parameters - no-parameter-names - (lambda (rdb) (display "Welcome") (newline) rdb) - "Print Welcome")))) +Within-database Example +....................... + +Here is an example of `within-database' macros: + + (require 'within-database) - ((my-rdb 'define-tables) - '(processor-family - ((family atom)) - ((also-ran processor-family)) - ((m68000 #f) - (m68030 m68000) - (i386 8086) - (8086 #f) - (powerpc #f))) + (define my-rdb + (add-command-tables + (create-database "foo.db" 'alist-table))) - '(platform - ((name symbol)) - ((processor processor-family) - (os symbol) - (compiler symbol)) - ((aix powerpc aix -) - (amiga-dice-c m68000 amiga dice-c) + (within-database my-rdb + (define-command (*initialize* rdb) + "Print Welcome" + (display "Welcome") + (newline) + rdb) + (define-command (without-documentation rdb) + (display "without-documentation called") + (newline)) + (define-table (processor-family + ((family atom)) + ((also-ran processor-family))) + (m68000 #f) + (m68030 m68000) + (i386 i8086) | + (i8086 #f) | + (powerpc #f)) + (define-table (platform + ((name symbol)) + ((processor processor-family) + (os symbol) + (compiler symbol))) + (aix powerpc aix -) + ;; ... (amiga-aztec m68000 amiga aztec) (amiga-sas/c-5.10 m68000 amiga sas/c) (atari-st-gcc m68000 atari gcc) - (atari-st-turbo-c m68000 atari turbo-c) - (borland-c-3.1 8086 ms-dos borland-c) - (djgpp i386 ms-dos gcc) - (linux i386 linux gcc) - (microsoft-c 8086 ms-dos microsoft-c) - (os/2-emx i386 os/2 gcc) - (turbo-c-2 8086 ms-dos turbo-c) - (watcom-9.0 i386 ms-dos watcom)))) + ;; ... + (watcom-9.0 i386 ms-dos watcom)) + (define-command (get-processor rdb) + "Get processor for given platform." + (((rdb 'open-table) 'platform #f) 'get 'processor))) - ((my-rdb 'close-database)) + (close-database my-rdb) - (set! my-rdb (open-database "foo.db" 'alist-table)) + (set! my-rdb (open-command-database! "foo.db")) -| Welcome - -Listing Tables -.............. - - - Procedure: list-table-definition rdb table-name - If symbol TABLE-NAME exists in the open relational-database 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 `list-table-definition', when passed as an - argument to `define-tables', will recreate the table. + + (my-rdb 'without-documentation) + -| + without-documentation called + + ((my-rdb 'get-processor) 'amiga-sas/c-5.10) + => m68000 + + (close-database my-rdb) -File: slib.info, Node: Database Reports, Next: Database Browser, Prev: Database Utilities, Up: Relational Database - -Database Reports +File: slib.info, Node: Database Browser, Prev: Database Macros, Up: Relational Database + | +Database Browser | ---------------- -Code for generating database reports is in `report.scm'. After writing -it using `format', I discovered that Common-Lisp `format' is not -useable for this application because there is no mechanismm for -truncating fields. `report.scm' needs to be rewritten using `printf'. - - - Procedure: create-report rdb destination report-name table - - Procedure: create-report rdb destination report-name - The symbol REPORT-NAME must be primary key in the table named - `*reports*' in the relational database RDB. DESTINATION is a - port, string, or symbol. If DESTINATION is a: - - port - The table is created as ascii text and written to that port. - - string - The table is created as ascii text and written to the file - named by DESTINATION. - - symbol - DESTINATION is the primary key for a row in the table named - *printers*. - - The report is prepared as follows: - - * `Format' (*note Format::) is called with the `header' field - and the (list of) `column-names' of the table. - - * `Format' is called with the `reporter' field and (on - successive calls) each record in the natural order for the - table. A count is kept of the number of newlines output by - format. When the number of newlines to be output exceeds the - number of lines per page, the set of lines will be broken if - there are more than `minimum-break' left on this page and the - number of lines for this row is larger or equal to twice - `minimum-break'. - - * `Format' is called with the `footer' field and the (list of) - `column-names' of the table. The footer field should not - output a newline. - - * A new page is output. +(require 'database-browse) | - * This entire process repeats until all the rows are output. + - Procedure: browse database | + Prints the names of all the tables in DATABASE and sets browse's | + default to DATABASE. | - Each row in the table *reports* has the fields: + - Procedure: browse | + Prints the names of all the tables in the default database. | -name - The report name. + - Procedure: browse table-name | + For each record of the table named by the symbol TABLE-NAME, | + prints a line composed of all the field values. | -default-table - The table to report on if none is specified. + - Procedure: browse pathname | + Opens the database named by the string PATHNAME, prints the names | + of all its tables, and sets browse's default to the database. | -header, footer - A `format' string. At the beginning and end of each page - respectively, `format' is called with this string and the (list of) - column-names of this table. + - Procedure: browse database table-name | + Sets browse's default to DATABASE and prints the records of the | + table named by the symbol TABLE-NAME. | -reporter - A `format' string. For each row in the table, `format' is called - with this string and the row. - -minimum-break - The minimum number of lines into which the report lines for a row - can be broken. Use `0' if a row's lines should not be broken over - page boundaries. - - Each row in the table *printers* has the fields: - -name - The printer name. - -print-procedure - The procedure to call to actually print. + - Procedure: browse pathname table-name | + Opens the database named by the string PATHNAME and sets browse's | + default to it; `browse' prints the records of the table named by | + the symbol TABLE-NAME. | + | -File: slib.info, Node: Database Browser, Prev: Database Reports, Up: Relational Database +File: slib.info, Node: Relational Infrastructure, Next: Weight-Balanced Trees, Prev: Relational Database, Up: Database Packages + | +Relational Infrastructure | +========================= | -Database Browser ----------------- +* Menu: | - (require 'database-browse) +* Base Table:: | +* Catalog Representation:: | +* Relational Database Objects:: | +* Database Operations:: | - - Procedure: browse database - Prints the names of all the tables in DATABASE and sets browse's - default to DATABASE. + +File: slib.info, Node: Base Table, Next: Catalog Representation, Prev: Relational Infrastructure, Up: Relational Infrastructure + | +Base Table | +---------- | - - Procedure: browse - Prints the names of all the tables in the default database. +A "base-table" is the primitive database layer upon which SLIB | +relational databases are built. At the minimum, it must support the | +types integer, symbol, string, and boolean. The base-table may restrict | +the size of integers, symbols, and strings it supports. | - - Procedure: browse table-name - For each record of the table named by the symbol TABLE-NAME, - prints a line composed of all the field values. + A base table implementation is available as the value of the | +identifier naming it (eg. ALIST-TABLE) after requiring the symbol of | +that name. | - - Procedure: browse pathname - Opens the database named by the string PATHNAME, prints the names - of all its tables, and sets browse's default to the database. + - Feature: alist-table | + `(require 'alist-table)' | - - Procedure: browse database table-name - Sets browse's default to DATABASE and prints the records of the - table named by the symbol TABLE-NAME. + Association-list base tables support all Scheme types and are | + suitable for small databases. In order to be retrieved after | + being written to a file, the data stored should include only | + objects which are readable and writeable in the Scheme | + implementation. | - - Procedure: browse pathname table-name - Opens the database named by the string PATHNAME and sets browse's - default to it; `browse' prints the records of the table named by - the symbol TABLE-NAME. + The "alist-table" base-table implementation is included in the | + SLIB distribution. | + "WB" is a B-tree database package with SCM interfaces. Being | +disk-based, WB databases readily store and access hundreds of megabytes | +of data. WB comes with two base-table embeddings. | + | + - Feature: wb-table | + `(require 'wb-table)' | + | + `wb-table' supports scheme expressions for keys and values whose | + text representations are less than 255 characters in length. | + *Note wb-table: (wb)wb-table. | + | + - Feature: rwb-isam | + `(require 'rwb-isam)' | + | + "rwb-isam" is a sophisticated base-table implementation built on | + WB and SCM which uses binary numerical formats for key and non-key | + fields. It supports IEEE floating-point and fixed-precision | + integer keys with the correct numerical collation order. | + | + This rest of this section documents the interface for a base table | +implementation from which the *Note Relational Database:: package | +constructs a Relational system. It will be of interest primarily to | +those wishing to port or write new base-table implementations. | + | + - Variable: *base-table-implementations* | + To support automatic dispatch for `open-database', each base-table | + module adds an association to *BASE-TABLE-IMPLEMENTATIONS* when | + loaded. This association is the list of the base-table symbol and | + the value returned by `(make-relational-system BASE-TABLE)'. | + | +* Menu: | + | +* The Base:: | +* Base Tables:: | +* Base Field Types:: | +* Composite Keys:: | +* Base Record Operations:: | +* Match Keys:: | +* Aggregate Base Operations:: | +* Base ISAM Operations:: | -File: slib.info, Node: Weight-Balanced Trees, Prev: Relational Database, Up: Database Packages +File: slib.info, Node: The Base, Next: Base Tables, Prev: Base Table, Up: Base Table + | +The Base | +........ | + +All of these functions are accessed through a single procedure by | +calling that procedure with the symbol name of the operation. A | +procedure will be returned if that operation is supported and `#f' | +otherwise. For example: | + + (require 'alist-table) | + (define my-base (alist-table 'make-base)) | + my-base => *a procedure* | + (define foo (alist-table 'foo)) | + foo => #f | + + - Operation on base-table: make-base filename key-dimension | + column-types | + Returns a new, open, low-level database (collection of tables) | + associated with FILENAME. This returned database has an empty | + table associated with CATALOG-ID. The positive integer | + KEY-DIMENSION is the number of keys composed to make a PRIMARY-KEY | + for the catalog table. The list of symbols COLUMN-TYPES describes | + the types of each column for that table. If the database cannot | + be created as specified, `#f' is returned. | + + Calling the `close-base' method on this database and possibly other | + operations will cause FILENAME to be written to. If FILENAME is | + `#f' a temporary, non-disk based database will be created if such | + can be supported by the base table implelentation. | + + - Operation on base-table: open-base filename mutable | + Returns an open low-level database associated with FILENAME. If | + MUTABLE is `#t', this database will have methods capable of | + effecting change to the database. If MUTABLE is `#f', only | + methods for inquiring the database will be available. If the | + database cannot be opened as specified `#f' is returned. | + + Calling the `close-base' (and possibly other) method on a MUTABLE | + database will cause FILENAME to be written to. | + + - Operation on base-table: write-base lldb filename | + Causes the low-level database LLDB to be written to FILENAME. If | + the write is successful, also causes LLDB to henceforth be | + associated with FILENAME. Calling the `close-database' (and | + possibly other) method on LLDB may cause FILENAME to be written | + to. If FILENAME is `#f' this database will be changed to a | + temporary, non-disk based database if such can be supported by the | + underlying base table implelentation. If the operations completed | + successfully, `#t' is returned. Otherwise, `#f' is returned. | + + - Operation on base-table: sync-base lldb | + Causes the file associated with the low-level database LLDB to be | + updated to reflect its current state. If the associated filename | + is `#f', no action is taken and `#f' is returned. If this | + operation completes successfully, `#t' is returned. Otherwise, | + `#f' is returned. | + | + - Operation on base-table: close-base lldb | + Causes the low-level database LLDB to be written to its associated | + file (if any). If the write is successful, subsequent operations | + to LLDB will signal an error. If the operations complete | + successfully, `#t' is returned. Otherwise, `#f' is returned. | + +File: slib.info, Node: Base Tables, Next: Base Field Types, Prev: The Base, Up: Base Table + | +Base Tables | +........... | + | + - Operation on base-table: make-table lldb key-dimension column-types | + Returns the ordinal BASE-ID for a new base table, otherwise | + returns `#f'. The base table can then be opened using | + `(open-table LLDB BASE-ID)'. The positive integer KEY-DIMENSION | + is the number of keys composed to make a PRIMARY-KEY for this | + table. The list of symbols COLUMN-TYPES describes the types of | + each column. | + | + - Operation on base-table: open-table lldb base-id key-dimension | + column-types | + Returns a HANDLE for an existing base table in the low-level | + database LLDB if that table exists and can be opened in the mode | + indicated by MUTABLE, otherwise returns `#f'. | + | + As with `make-table', the positive integer KEY-DIMENSION is the | + number of keys composed to make a PRIMARY-KEY for this table. The | + list of symbols COLUMN-TYPES describes the types of each column. | + | + - Operation on base-table: kill-table lldb base-id key-dimension | + column-types | + Returns `#t' if the base table associated with BASE-ID was removed | + from the low level database LLDB, and `#f' otherwise. | + | + - Operation on base-table: catalog-id | + A constant BASE-ID ordinal suitable for passing as a parameter to | + `open-table'. CATALOG-ID will be used as the base table for the | + system catalog. | + | + +File: slib.info, Node: Base Field Types, Next: Composite Keys, Prev: Base Tables, Up: Base Table + | +Base Field Types | +................ | + | + - Operation on base-table: supported-type? symbol | + Returns `#t' if SYMBOL names a type allowed as a column value by | + the implementation, and `#f' otherwise. At a minimum, an | + implementation must support the types `integer', `ordinal', | + `symbol', `string', and `boolean'. | + | + - Operation on base-table: supported-key-type? symbol | + Returns `#t' if SYMBOL names a type allowed as a key value by the | + implementation, and `#f' otherwise. At a minimum, an | + implementation must support the types `ordinal', and `symbol'. | + | +An "ordinal" is an exact positive integer. The other types are | +standard Scheme. | + | + +File: slib.info, Node: Composite Keys, Next: Base Record Operations, Prev: Base Field Types, Up: Base Table + | +Composite Keys | +.............. | + | + - Operation on base-table: make-keyifier-1 type | + Returns a procedure which accepts a single argument which must be | + of type TYPE. This returned procedure returns an object suitable | + for being a KEY argument in the functions whose descriptions | + follow. | + | + Any 2 arguments of the supported type passed to the returned | + function which are not `equal?' must result in returned values | + which are not `equal?'. | + | + - Operation on base-table: make-list-keyifier key-dimension types | + The list of symbols TYPES must have at least KEY-DIMENSION | + elements. Returns a procedure which accepts a list of length | + KEY-DIMENSION and whose types must corresopond to the types named | + by TYPES. This returned procedure combines the elements of its | + list argument into an object suitable for being a KEY argument in | + the functions whose descriptions follow. | + | + Any 2 lists of supported types (which must at least include | + symbols and non-negative integers) passed to the returned function | + which are not `equal?' must result in returned values which are not | + `equal?'. | + | + - Operation on base-table: make-key-extractor key-dimension types | + column-number | + Returns a procedure which accepts objects produced by application | + of the result of `(make-list-keyifier KEY-DIMENSION TYPES)'. This | + procedure returns a KEY which is `equal?' to the COLUMN-NUMBERth | + element of the list which was passed to create COMPOSITE-KEY. The | + list TYPES must have at least KEY-DIMENSION elements. | + | + - Operation on base-table: make-key->list key-dimension types | + Returns a procedure which accepts objects produced by application | + of the result of `(make-list-keyifier KEY-DIMENSION TYPES)'. This | + procedure returns a list of KEYs which are elementwise `equal?' to | + the list which was passed to create COMPOSITE-KEY. | + | + +File: slib.info, Node: Base Record Operations, Next: Match Keys, Prev: Composite Keys, Up: Base Table + | +Base Record Operations | +...................... | + | +In the following functions, the KEY argument can always be assumed to | +be the value returned by a call to a _keyify_ routine. | + | + - Operation on base-table: present? handle key | + Returns a non-`#f' value if there is a row associated with KEY in | + the table opened in HANDLE and `#f' otherwise. | + | + - Operation on base-table: make-getter key-dimension types | + Returns a procedure which takes arguments HANDLE and KEY. This | + procedure returns a list of the non-primary values of the relation | + (in the base table opened in HANDLE) whose primary key is KEY if | + it exists, and `#f' otherwise. | + | +`make-getter-1' is a new operation. The relational-database module | +works with older base-table implementations by using `make-getter'. | + | + - Operation on base-table: make-getter-1 key-dimension types index | + Returns a procedure which takes arguments HANDLE and KEY. This | + procedure returns the value of the INDEXth field (in the base | + table opened in HANDLE) whose primary key is KEY if it exists, and | + `#f' otherwise. | + | + INDEX must be larger than KEY-DIMENSION. | + | + - Operation on base-table: make-putter key-dimension types | + Returns a procedure which takes arguments HANDLE and KEY and | + VALUE-LIST. This procedure associates the primary key KEY with | + the values in VALUE-LIST (in the base table opened in HANDLE) and | + returns an unspecified value. | + | + - Operation on base-table: delete handle key | + Removes the row associated with KEY from the table opened in | + HANDLE. An unspecified value is returned. | + | + +File: slib.info, Node: Match Keys, Next: Aggregate Base Operations, Prev: Base Record Operations, Up: Base Table + | +Match Keys | +.......... | + | +A MATCH-KEYS argument is a list of length equal to the number of | +primary keys. The MATCH-KEYS restrict the actions of the table command | +to those records whose primary keys all satisfy the corresponding | +element of the MATCH-KEYS list. The elements and their actions are: | + | + `#f' | + The false value matches any key in the corresponding position. | + | + an object of type procedure | + This procedure must take a single argument, the key in the | + corresponding position. Any key for which the procedure | + returns a non-false value is a match; Any key for which the | + procedure returns a `#f' is not. | + | + other values | + Any other value matches only those keys `equal?' to it. | + | + +File: slib.info, Node: Aggregate Base Operations, Next: Base ISAM Operations, Prev: Match Keys, Up: Base Table + | +Aggregate Base Operations | +......................... | + | +The KEY-DIMENSION and COLUMN-TYPES arguments are needed to decode the | +composite-keys for matching with MATCH-KEYS. | + | + - Operation on base-table: delete* handle key-dimension column-types | + match-keys | + Removes all rows which satisfy MATCH-KEYS from the table opened in | + HANDLE. An unspecified value is returned. | + | + - Operation on base-table: for-each-key handle procedure key-dimension | + column-types match-keys | + Calls PROCEDURE once with each KEY in the table opened in HANDLE | + which satisfy MATCH-KEYS in an unspecified order. An unspecified | + value is returned. | + | + - Operation on base-table: map-key handle procedure key-dimension | + column-types match-keys | + Returns a list of the values returned by calling PROCEDURE once | + with each KEY in the table opened in HANDLE which satisfy | + MATCH-KEYS in an unspecified order. | + | + +File: slib.info, Node: Base ISAM Operations, Prev: Aggregate Base Operations, Up: Base Table + | +Base ISAM Operations | +.................... | + | +These operations are optional for a Base-Table implementation. | + | + - Operation on base-table: ordered-for-each-key handle procedure | + key-dimension column-types match-keys | + Calls PROCEDURE once with each KEY in the table opened in HANDLE | + which satisfy MATCH-KEYS in the natural order for the types of the | + primary key fields of that table. An unspecified value is | + returned. | + | + - Operation on base-table: make-nexter handle key-dimension | + column-types index | + Returns a procedure of arguments KEY1 KEY2 ... which returns the | + key-list identifying the lowest record higher than KEY1 KEY2 ... | + which is stored in the base-table and which differs in column | + INDEX or a lower indexed key; or false if no higher record is | + present. | + | + - Operation on base-table: make-prever handle key-dimension | + column-types index | + Returns a procedure of arguments KEY1 KEY2 ... which returns the | + key-list identifying the highest record less than KEY1 KEY2 ... | + which is stored in the base-table and which differs in column | + INDEX or a lower indexed key; or false if no higher record is | + present. | + | + +File: slib.info, Node: Catalog Representation, Next: Relational Database Objects, Prev: Base Table, Up: Relational Infrastructure + | +Catalog Representation | +---------------------- | + | +Each database (in an implementation) has a "system catalog" which | +describes all the user accessible tables in that database (including | +itself). | + | +The system catalog base table has the following fields. `PRI' | +indicates a primary key for that table. | + | + PRI table-name | + column-limit the highest column number | + coltab-name descriptor table name | + bastab-id data base table identifier | + user-integrity-rule | + view-procedure A scheme thunk which, when called, | + produces a handle for the view. coltab | + and bastab are specified if and only if | + view-procedure is not. | + | +Descriptors for base tables (not views) are tables (pointed to by | +system catalog). Descriptor (base) tables have the fields: | + | + PRI column-number sequential integers from 1 | + primary-key? boolean TRUE for primary key components | + column-name | + column-integrity-rule | + domain-name | + | +A "primary key" is any column marked as `primary-key?' in the | +corresponding descriptor table. All the `primary-key?' columns must | +have lower column numbers than any non-`primary-key?' columns. Every | +table must have at least one primary key. Primary keys must be | +sufficient to distinguish all rows from each other in the table. All of | +the system defined tables have a single primary key. | + | +A "domain" is a category describing the allowable values to occur in a | +column. It is described by a (base) table with the fields: | + | + PRI domain-name | + foreign-table | + domain-integrity-rule | + type-id | + type-param | + | +The "type-id" field value is a symbol. This symbol may be used by the | +underlying base table implementation in storing that field. | + | +If the `foreign-table' field is non-`#f' then that field names a table | +from the catalog. The values for that domain must match a primary key | +of the table referenced by the TYPE-PARAM (or `#f', if allowed). This | +package currently does not support composite foreign-keys. | + | +The types for which support is planned are: | + atom | + symbol | + string [<length>] | + number [<base>] | + money <currency> | + date-time | + boolean | + | + foreign-key <table-name> | + expression | + virtual <expression> | + | + +File: slib.info, Node: Relational Database Objects, Next: Database Operations, Prev: Catalog Representation, Up: Relational Infrastructure + | +Relational Database Objects | +--------------------------- | + | +This object-oriented interface is deprecated for typical database | +applications; *Note Using Databases:: provides an application programmer | +interface which is easier to understand and use. | + | + - Function: make-relational-system base-table-implementation | + Returns a procedure implementing a relational database using the | + BASE-TABLE-IMPLEMENTATION. | + | + All of the operations of a base table implementation are accessed | + through a procedure defined by `require'ing that implementation. | + Similarly, all of the operations of the relational database | + implementation are accessed through the procedure returned by | + `make-relational-system'. For instance, a new relational database | + could be created from the procedure returned by | + `make-relational-system' by: | + | + (require 'alist-table) | + (define relational-alist-system | + (make-relational-system alist-table)) | + (define create-alist-database | + (relational-alist-system 'create-database)) | + (define my-database | + (create-alist-database "mydata.db")) | + | +What follows are the descriptions of the methods available from | +relational system returned by a call to `make-relational-system'. | + | + - Operation on relational-system: create-database filename | + Returns an open, nearly empty relational database associated with | + FILENAME. The only tables defined are the system catalog and | + domain table. Calling the `close-database' method on this database | + and possibly other operations will cause FILENAME to be written | + to. If FILENAME is `#f' a temporary, non-disk based database will | + be created if such can be supported by the underlying base table | + implelentation. If the database cannot be created as specified | + `#f' is returned. For the fields and layout of descriptor tables, | + *Note Catalog Representation:: | + | + - Operation on relational-system: open-database filename mutable? | + Returns an open relational database associated with FILENAME. If | + MUTABLE? is `#t', this database will have methods capable of | + effecting change to the database. If MUTABLE? is `#f', only | + methods for inquiring the database will be available. Calling the | + `close-database' (and possibly other) method on a MUTABLE? | + database will cause FILENAME to be written to. If the database | + cannot be opened as specified `#f' is returned. | + | + +File: slib.info, Node: Database Operations, Prev: Relational Database Objects, Up: Relational Infrastructure + | +Database Operations | +------------------- | + | +This object-oriented interface is deprecated for typical database | +applications; *Note Using Databases:: provides an application programmer | +interface which is easier to understand and use. | + | +These are the descriptions of the methods available from an open | +relational database. A method is retrieved from a database by calling | +the database with the symbol name of the operation. For example: | + | + (define my-database | + (create-alist-database "mydata.db")) | + (define telephone-table-desc | + ((my-database 'create-table) 'telephone-table-desc)) | + | + - Operation on relational-database: close-database | + Causes the relational database to be written to its associated | + file (if any). If the write is successful, subsequent operations | + to this database will signal an error. If the operations completed | + successfully, `#t' is returned. Otherwise, `#f' is returned. | + | + - Operation on relational-database: write-database filename | + Causes the relational database to be written to FILENAME. If the | + write is successful, also causes the database to henceforth be | + associated with FILENAME. Calling the `close-database' (and | + possibly other) method on this database will cause FILENAME to be | + written to. If FILENAME is `#f' this database will be changed to | + a temporary, non-disk based database if such can be supported by | + the underlying base table implelentation. If the operations | + completed successfully, `#t' is returned. Otherwise, `#f' is | + returned. | + | + - Operation on relational-database: sync-database | + Causes any pending updates to the database file to be written out. | + If the operations completed successfully, `#t' is returned. | + Otherwise, `#f' is returned. | + | + - Operation on relational-database: solidify-database | + Causes any pending updates to the database file to be written out. | + If the writes completed successfully, then the database is | + changed to be immutable and `#t' is returned. Otherwise, `#f' is | + returned. | + | + - Operation on relational-database: table-exists? table-name | + Returns `#t' if TABLE-NAME exists in the system catalog, otherwise | + returns `#f'. | + | + - Operation on relational-database: open-table table-name mutable? | + Returns a "methods" procedure for an existing relational table in | + this database if it exists and can be opened in the mode indicated | + by MUTABLE?, otherwise returns `#f'. | + | +These methods will be present only in mutable databases. | + | + - Operation on relational-database: delete-table table-name | + Removes and returns the TABLE-NAME row from the system catalog if | + the table or view associated with TABLE-NAME gets removed from the | + database, and `#f' otherwise. | + | + - Operation on relational-database: create-table table-desc-name | + Returns a methods procedure for a new (open) relational table for | + describing the columns of a new base table in this database, | + otherwise returns `#f'. For the fields and layout of descriptor | + tables, *Note Catalog Representation::. | + | + - Operation on relational-database: create-table table-name | + table-desc-name | + Returns a methods procedure for a new (open) relational table with | + columns as described by TABLE-DESC-NAME, otherwise returns `#f'. | + | + - Operation on relational-database: create-view ?? | + - Operation on relational-database: project-table ?? | + - Operation on relational-database: restrict-table ?? | + - Operation on relational-database: cart-prod-tables ?? | + Not yet implemented. | + | + +File: slib.info, Node: Weight-Balanced Trees, Prev: Relational Infrastructure, Up: Database Packages + | Weight-Balanced Trees ===================== - `(require 'wt-tree)' +`(require 'wt-tree)' Balanced binary trees are a useful data structure for maintaining large sets of ordered objects or sets of associations whose keys are @@ -7365,7 +9972,7 @@ File: slib.info, Node: Construction of Weight-Balanced Trees, Next: Basic Oper Construction of Weight-Balanced Trees ------------------------------------- - Binary trees require there to be a total order on the keys used to +Binary trees require there to be a total order on the keys used to arrange the elements in the tree. Weight balanced trees are organized by _types_, where the type is an object encapsulating the ordering relation. Creating a tree is a two-stage process. First a tree type @@ -7442,15 +10049,11 @@ File: slib.info, Node: Basic Operations on Weight-Balanced Trees, Next: Advanc Basic Operations on Weight-Balanced Trees ----------------------------------------- - This section describes the basic tree operations on weight balanced +This section describes the basic tree operations on weight balanced trees. These operations are the usual tree operations for insertion, deletion and lookup, some predicates and a procedure for determining the number of associations in a tree. - - - procedure+: wt-tree? object - Returns `#t' if OBJECT is a weight-balanced tree, otherwise - returns `#f'. - + | - procedure+: wt-tree/empty? wt-tree Returns `#t' if WT-TREE contains no associations, otherwise returns `#f'. @@ -7506,7 +10109,7 @@ File: slib.info, Node: Advanced Operations on Weight-Balanced Trees, Next: Ind Advanced Operations on Weight-Balanced Trees -------------------------------------------- - In the following the _size_ of a tree is the number of associations +In the following the _size_ of a tree is the number of associations that the tree contains, and a _smaller_ tree contains fewer associations. @@ -7630,7 +10233,7 @@ File: slib.info, Node: Indexing Operations on Weight-Balanced Trees, Prev: Adv Indexing Operations on Weight-Balanced Trees -------------------------------------------- - Weight balanced trees support operations that view the tree as sorted +Weight balanced trees support operations that view the tree as sorted sequence of associations. Elements of the sequence can be accessed by position, and the position of an element in the sequence can be determined, both in logarthmic time. @@ -7654,11 +10257,9 @@ determined, both in logarthmic time. Indexing can be used to find the median and maximum keys in the tree as follows: - median: (wt-tree/index WT-TREE - (quotient (wt-tree/size WT-TREE) 2)) - - maximum: (wt-tree/index WT-TREE - (-1+ (wt-tree/size WT-TREE))) + median: (wt-tree/index WT-TREE (quotient (wt-tree/size WT-TREE) 2)) + + maximum: (wt-tree/index WT-TREE (-1+ (wt-tree/size WT-TREE))) - procedure+: wt-tree/rank wt-tree key Determines the 0-based position of KEY in the sorted sequence of @@ -7713,68 +10314,147 @@ Other Packages * Menu: * Data Structures:: Various data structures. -* Sorting and Searching:: | +* Sorting and Searching:: * Procedures:: Miscellaneous utility procedures. * Standards Support:: Support for Scheme Standards. * Session Support:: REPL and Debugging. -* Extra-SLIB Packages:: +* System Interface:: 'system, 'getenv, and other programs. +* Extra-SLIB Packages:: Outside the envelope. | File: slib.info, Node: Data Structures, Next: Sorting and Searching, Prev: Other Packages, Up: Other Packages - | + Data Structures =============== * Menu: * Arrays:: 'array +* Subarrays:: 'subarray * Array Mapping:: 'array-for-each * Association Lists:: 'alist * Byte:: 'byte +* Byte/Number Conversions:: 'byte-number | +* MAT-File Format:: 'matfile * Portable Image Files:: 'pnm * Collections:: 'collect * Dynamic Data Type:: 'dynamic * Hash Tables:: 'hash-table -* Hashing:: 'hash, 'sierpinski, 'soundex * Object:: 'object * Priority Queues:: 'priority-queue * Queues:: 'queue -* Records:: 'record | +* Records:: 'record -File: slib.info, Node: Arrays, Next: Array Mapping, Prev: Data Structures, Up: Data Structures +File: slib.info, Node: Arrays, Next: Subarrays, Prev: Data Structures, Up: Data Structures Arrays ------ - `(require 'array)' +`(require 'array)' - Function: array? obj Returns `#t' if the OBJ is an array, and `#f' if not. -_Note:_ Arrays are not disjoint from other Scheme types. Strings and | -vectors also satisfy `array?'. A disjoint array predicate can be | -written: | - | - (define (strict-array? obj) | - (and (array? obj) (not (string? obj)) (not (vector? obj)))) | - | - - Function: array=? array1 array2 | - Returns `#t' if ARRAY1 and ARRAY2 have the same rank and shape and | - the corresponding elements of ARRAY1 and ARRAY2 are `equal?'. | - | - (array=? (make-array 'foo 3 3) (make-array 'foo '(0 2) '(1 2))) | - => #t | - | - - Function: make-array initial-value bound1 bound2 ... - Creates and returns an array with dimensions BOUND1, BOUND2, ... | - and filled with INITIAL-VALUE. | +_Note:_ Arrays are not disjoint from other Scheme types. Strings and +vectors also satisfy `array?'. A disjoint array predicate can be +written: + + (define (strict-array? obj) + (and (array? obj) (not (string? obj)) (not (vector? obj)))) + + - Function: array=? array1 array2 + Returns `#t' if ARRAY1 and ARRAY2 have the same rank and shape and + the corresponding elements of ARRAY1 and ARRAY2 are `equal?'. + + (array=? (create-array '#(foo) 3 3) + (create-array '#(foo) '(0 2) '(0 2))) + => #t + + - Function: create-array prototype bound1 bound2 ... + Creates and returns an array of type PROTOTYPE with dimensions + BOUND1, BOUND2, ... and filled with elements from PROTOTYPE. + PROTOTYPE must be an array, vector, or string. The + implementation-dependent type of the returned array will be the + same as the type of 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 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 PROTOTYPE. + +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. | + + - Function: ac64 z + - Function: ac64 + Returns a high-precision complex uniform-array prototype. + + - Function: ac32 z + - Function: ac32 + Returns a complex uniform-array prototype. + + - Function: ar64 x + - Function: ar64 + Returns a high-precision real uniform-array prototype. + + - Function: ar32 x + - Function: ar32 + Returns a real uniform-array prototype. + + - Function: as64 n + - Function: as64 + Returns an exact signed integer uniform-array prototype with at + least 64 bits of precision. + + - Function: as32 n + - Function: as32 + Returns an exact signed integer uniform-array prototype with at + least 32 bits of precision. + + - Function: as16 n + - Function: as16 + Returns an exact signed integer uniform-array prototype with at + least 16 bits of precision. + + - Function: as8 n + - Function: as8 + Returns an exact signed integer uniform-array prototype with at + least 8 bits of precision. + + - Function: au64 k + - Function: au64 + Returns an exact non-negative integer uniform-array prototype with + at least 64 bits of precision. + + - Function: au32 k + - Function: au32 + Returns an exact non-negative integer uniform-array prototype with + at least 32 bits of precision. + + - Function: au16 k + - Function: au16 + Returns an exact non-negative integer uniform-array prototype with + at least 16 bits of precision. + + - Function: au8 k + - Function: au8 + Returns an exact non-negative integer uniform-array prototype with + at least 8 bits of precision. + + - Function: at1 bool + - Function: at1 + Returns a boolean uniform-array prototype. When constructing an array, BOUND is either an inclusive range of indices expressed as a two element list, or an upper bound expressed as a single integer. So - (make-array 'foo 3 3) == (make-array 'foo '(0 2) '(0 2)) + (create-array '#(foo) 3 3) == (create-array '#(foo) '(0 2) '(0 2)) - Function: make-shared-array array mapper bound1 bound2 ... `make-shared-array' can be used to create shared subarrays of other @@ -7783,7 +10463,7 @@ a single integer. So linear, and its range must stay within the bounds of the old array, but it can be otherwise arbitrary. A simple 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) @@ -7800,37 +10480,123 @@ a single integer. So 0 is returned. - Function: array-shape array - Returns a list of inclusive bounds. | - | - (array-shape (make-array 'foo 3 5)) + Returns a list of inclusive bounds. + + (array-shape (create-array '#() 3 5)) => ((0 2) (0 4)) - Function: array-dimensions array `array-dimensions' is similar to `array-shape' but replaces - elements with a 0 minimum with one greater than the maximum. | - | - (array-dimensions (make-array 'foo 3 5)) + elements with a 0 minimum with one greater than the maximum. + + (array-dimensions (create-array '#() 3 5)) => (3 5) - - Function: array-in-bounds? array index1 index2 ... | + - Function: array-in-bounds? array index1 index2 ... Returns `#t' if its arguments would be acceptable to `array-ref'. - Function: array-ref array index1 index2 ... - Returns the (INDEX1, INDEX2, ...) element of ARRAY. | + Returns the (INDEX1, INDEX2, ...) element of ARRAY. - - Function: array-set! array obj index1 index2 ... | - Stores OBJ in the (INDEX1, INDEX2, ...) element of ARRAY. The | - value returned by `array-set!' is unspecified. | + - Procedure: array-set! array obj index1 index2 ... | + Stores OBJ in the (INDEX1, INDEX2, ...) element of ARRAY. The + value returned by `array-set!' is unspecified. -File: slib.info, Node: Array Mapping, Next: Association Lists, Prev: Arrays, Up: Data Structures +File: slib.info, Node: Subarrays, Next: Array Mapping, Prev: Arrays, Up: Data Structures + +Subarrays +--------- + +`(require 'subarray)' + + - Function: subarray array select ... + selects a subset of an array. For ARRAY of rank n, there must be + at least n SELECTS arguments. For 0 <= j < n, SELECTSj is either + an integer, a list of two integers within the range for the jth + index, or #f. + + When SELECTSj is a list of two integers, then the jth index is + restricted to that subrange in the returned array. + + When SELECTSj is #f, then the full range of the jth index is + accessible in the returned array. An elided argument is + equivalent to #f. + + When SELECTSj is an integer, then the rank of the returned array is + less than ARRAY, and only elements whose jth index equals SELECTSj + are shared. + + > (define ra '#2A((a b c) (d e f))) + #<unspecified> + > (subarray ra 0 #f) + #1A(a b c) + > (subarray ra 1 #f) + #1A(d e f) + > (subarray ra #f 1) + #1A(b e) + > (subarray ra '(0 1) #f) + #2A((a b c) (d e f)) + > (subarray ra #f '(0 1)) + #2A((a b) (d e)) + > (subarray ra #f '(1 2)) + #2A((b c) (e f)) + + - Function: subarray0 array select ... + Behaves like subarray, but aligns the returned array origin to 0 + .... + + - Function: array-align array coord ... + Returns an array shared with ARRAY but with a different origin. + The COORDS are the exact integer coordinates of the new origin. + Indexes corresponding to missing or #f coordinates are not + realigned. + + For example: + (define ra2 (create-array '#(5) '(5 9) '(-4 0))) + (array-shape ra2) => ((5 9) (-4 0)) + (array-shape (array-align ra2 0 0)) => ((0 4) (0 4)) + (array-shape (array-align ra2 0)) => ((0 4) (-4 0)) + (array-shape (array-align ra2)) => ((5 9) (-4 0)) + (array-shape (array-align ra2 0 #f)) => ((0 4) (-4 0)) + (array-shape (array-align ra2 #f 0)) => ((5 9) (0 4)) + + - Function: array-trim array trim ... + Returns a subarray sharing contents with ARRAY except for slices + removed from either side of each dimension. Each of the TRIMS is + an exact integer indicating how much to trim. A positive S trims + the data from the lower end and reduces the upper bound of the + result; a negative S trims from the upper end and increases the + lower bound. + + For example: + (array-trim '#(0 1 2 3 4) 1) => #1A(1 2 3 4) ;; shape is ((0 3)) + (array-trim '#(0 1 2 3 4) -1) => #1A(0 1 2 3) ;; shape is ((1 4)) + + (require 'array-for-each) + (define (centered-difference ra) + (array-map - (array-trim ra 1) (array-trim ra -1))) + (define (forward-difference ra) + (array-map - (array-trim ra 1) ra)) + (define (backward-difference ra) + (array-map - ra (array-trim ra -1))) + + (centered-difference '#(0 1 3 5 9 22)) + => #1A(3 4 6 17) ;;shape is ((1 4)) + (backward-difference '#(0 1 3 5 9 22)) + => #1A(1 2 2 4 13) ;; shape is ((1 5)) + (forward-difference '#(0 1 3 5 9 22)) + => #(1 2 2 4 13) ;; shape is ((0 4)) + + +File: slib.info, Node: Array Mapping, Next: Association Lists, Prev: Subarrays, Up: Data Structures Array Mapping ------------- - `(require 'array-for-each)' +`(require 'array-for-each)' - - Function: array-map! array0 proc array1 ... + - Procedure: array-map! array0 proc array1 ... | ARRAY1, ... must have the same number of dimensions as ARRAY0 and have a range for each index which includes the range for the corresponding index in ARRAY0. PROC is applied to each tuple of @@ -7838,32 +10604,40 @@ Array Mapping corresponding element in ARRAY0. The value returned is unspecified. The order of application is unspecified. - - Function: array-for-each PROC ARRAY0 ... + - Function: array-map prototype proc array1 array2 ... | + ARRAY2, ... must have the same number of dimensions as ARRAY1 and | + have a range for each index which includes the range for the | + corresponding index in ARRAY1. PROC is applied to each tuple of | + elements of ARRAY1, ARRAY2, ... and the result is stored as the | + corresponding element in a new array of type PROTOTYPE. The new | + array is returned. The order of application is unspecified. | + | + - Function: array-for-each proc array0 ... | PROC is applied to each tuple of elements of ARRAY0 ... in row-major order. The value returned is unspecified. - - Function: array-indexes ARRAY + - Function: array-indexes array | Returns an array of lists of indexes for ARRAY such that, if LI is a list of indexes for which ARRAY is defined, (equal? LI (apply array-ref (array-indexes ARRAY) LI)). - - Function: array-index-map! array proc + - Procedure: array-index-map! array proc | applies PROC to the indices of each element of ARRAY in turn, storing the result in the corresponding element. The value returned and the order of application are unspecified. One can implement ARRAY-INDEXES as (define (array-indexes array) - (let ((ra (apply make-array #f (array-shape array)))) + (let ((ra (apply create-array '#() (array-shape array)))) (array-index-map! ra (lambda x x)) ra)) Another example: (define (apl:index-generator n) - (let ((v (make-uniform-vector n 1))) + (let ((v (make-vector n 1))) (array-index-map! v (lambda (i) i)) v)) - - Function: array-copy! source destination + - Procedure: array-copy! source destination | Copies every element from vector or array SOURCE to the corresponding element of DESTINATION. DESTINATION must have the same rank as SOURCE, and be at least as large in each dimension. @@ -7875,7 +10649,7 @@ File: slib.info, Node: Association Lists, Next: Byte, Prev: Array Mapping, U Association Lists ----------------- - `(require 'alist)' +`(require 'alist)' Alist functions provide utilities for treating a list of key-value pairs as an associative database. These functions take an equality @@ -7902,6 +10676,7 @@ tables for improved performance. value associated with KEY will be lost. This returned procedure may or may not have side effects on its ALIST argument. An example of correct usage is: + (define put (alist-associator string-ci=?)) (define alist '()) (set! alist (put alist "Foo" 9)) @@ -7911,6 +10686,7 @@ tables for improved performance. an alist with an association whose KEY is key removed. This returned procedure may or may not have side effects on its ALIST argument. An example of correct usage is: + (define rem (alist-remover string-ci=?)) (set! alist (rem alist "foo")) @@ -7924,14 +10700,14 @@ tables for improved performance. be a function of 2 arguments. The returned value is unspecified. -File: slib.info, Node: Byte, Next: Portable Image Files, Prev: Association Lists, Up: Data Structures - +File: slib.info, Node: Byte, Next: Byte/Number Conversions, Prev: Association Lists, Up: Data Structures + | Byte ---- - `(require 'byte)' +`(require 'byte)' - Some algorithms are expressed in terms of arrays of small integers. +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 "byte". @@ -7941,58 +10717,306 @@ character sets. These functions abstract the notion of a "byte". BYTES using zero-origin indexing. - Procedure: byte-set! bytes k byte - K must be a valid index of BYTES%, and BYTE must be a small - integer. `Byte-set!' stores BYTE in element K of BYTES and - returns an unspecified value. - - - Function: make-bytes k + K must be a valid index of BYTES, and BYTE must be a small | + nonnegative integer. `byte-set!' stores BYTE in element K of | + BYTES and returns an unspecified value. | + | - Function: make-bytes k byte - `Make-bytes' returns a newly allocated byte-array of length K. If + - Function: make-bytes k | + `make-bytes' returns a newly allocated byte-array of length K. If | BYTE is given, then all elements of the byte-array are initialized to BYTE, otherwise the contents of the byte-array are unspecified. - - Function: bytes-length bytes `bytes-length' returns length of byte-array BYTES. + - Function: bytes byte ... + Returns a newly allocated byte-array composed of the small | + nonnegative arguments. | + + - Function: bytes->list bytes + `bytes->list' returns a newly allocated list of the bytes that | + make up the given byte-array. | + | + - Function: list->bytes bytes + `list->bytes' returns a newly allocated byte-array formed from the | + small nonnegative integers in the list BYTES. | + +`Bytes->list' and `list->bytes' are inverses so far as `equal?' is | +concerned. | - - Function: write-byte byte + - Function: bytes-copy bytes | + Returns a newly allocated copy of the given BYTES. | + | + - Procedure: bytes-reverse! bytes | + Reverses the order of byte-array BYTES. | + | + - Function: bytes-reverse bytes | + Returns a newly allocated bytes-array consisting of the elements of | + BYTES in reverse order. | + | +Input and output of bytes should be with ports opened in "binary" mode | +(*note Input/Output::). Calling `open-file' with 'rb or 'wb modes | +argument will return a binary port if the Scheme implementation +supports it. + | - Function: write-byte byte port + - Function: write-byte byte | Writes the byte BYTE (not an external representation of the byte) to the given PORT and returns an unspecified value. The PORT argument may be omitted, in which case it defaults to the value returned by `current-output-port'. - - - - Function: read-byte + | - Function: read-byte port + - Function: read-byte | Returns the next byte available from the input PORT, updating the PORT to point to the following byte. If no more bytes are - available, an end of file object is returned. PORT may be + available, an end-of-file object is returned. PORT may be | omitted, in which case it defaults to the value returned by `current-input-port'. +When reading and writing binary numbers with `read-bytes' and | +`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. | + | +Once read in, SLIB treats byte sequences as big-endian. The multi-byte | +sequences produced and used by number conversion routines *note | +Byte/Number Conversions:: are always big-endian. | + | + - Function: read-bytes n port | + - Function: read-bytes n | + `read-bytes' returns a newly allocated bytes-array filled with | + `(abs N)' bytes read from PORT. If 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 `(abs N)' if PORT reaches end-of-file. | + | + PORT may be omitted, in which case it defaults to the value | + returned by `current-input-port'. | + | + - Function: write-bytes bytes n port | + - Function: write-bytes bytes n | + `write-bytes' writes `(abs N)' bytes to output-port PORT. If N is | + positive, then the first byte written is index 0 of BYTES; | + otherwise the last byte written is index 0 of BYTES. | + `write-bytes' returns an unspecified value. | + | + PORT may be omitted, in which case it defaults to the value | + returned by `current-output-port'. | + | +`substring-read!' and `substring-write' provide lower-level procedures | +for reading and writing blocks of bytes. The relative size of START | +and END determines the order of writing. | + | + - Procedure: substring-read! string start end port | + - Procedure: substring-read! string start end | + Fills STRING with up to `(abs (- START END))' bytes read from | + PORT. The first byte read is stored at index STRING. | + `substring-read!' returns the number of bytes read. | + | + PORT may be omitted, in which case it defaults to the value | + returned by `current-input-port'. | + | + - Function: substring-write string start end port | + - Function: substring-write string start end | + `substring-write' writes `(abs (- START END))' bytes to | + output-port PORT. The first byte written is index START of | + STRING. `substring-write' returns the number of bytes written. | + | + PORT may be omitted, in which case it defaults to the value | + returned by `current-output-port'. | - - Function: bytes byte ... - Returns a newly allocated byte-array composed of the arguments. + +File: slib.info, Node: Byte/Number Conversions, Next: MAT-File Format, Prev: Byte, Up: Data Structures + | +Byte/Number Conversions | +----------------------- | + | +`(require 'byte-number)' | + | +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 `read-bytes' and `write-bytes' *Note | +read-bytes: Byte. | + | +The sign of the length argument to bytes/integer conversion procedures | +determines the signedness of the number. | + | + - Function: bytes->integer bytes n | + Converts the first `(abs N)' bytes of big-endian BYTES array to an | + integer. If N is negative then the integer coded by the bytes are | + treated as two's-complement (can be negative). | + | + (bytes->integer (bytes 0 0 0 15) -4) => 15 | + (bytes->integer (bytes 0 0 0 15) 4) => 15 | + (bytes->integer (bytes 255 255 255 255) -4) => -1 | + (bytes->integer (bytes 255 255 255 255) 4) => 4294967295 | + (bytes->integer (bytes 128 0 0 0) -4) => -2147483648 | + (bytes->integer (bytes 128 0 0 0) 4) => 2147483648 | + | + - Function: integer->bytes n len | + Converts the integer N to a byte-array of `(abs N)' bytes. If N | + and LEN are both negative, then the bytes in the returned array | + are coded two's-complement. | + | + (bytes->list (integer->bytes 15 -4)) => (0 0 0 15) | + (bytes->list (integer->bytes 15 4)) => (0 0 0 15) | + (bytes->list (integer->bytes -1 -4)) => (255 255 255 255) + (bytes->list (integer->bytes 4294967295 4)) => (255 255 255 255) + (bytes->list (integer->bytes -2147483648 -4)) => (128 0 0 0) | + (bytes->list (integer->bytes 2147483648 4)) => (128 0 0 0) | + | + - Function: bytes->ieee-float bytes | + BYTES must be a 4-element byte-array. `bytes->ieee-float' | + calculates and returns the value of BYTES interpreted as a | + big-endian IEEE 4-byte (32-bit) number. | + | + (bytes->ieee-float (bytes #x40 0 0 0)) => 2.0 | + (bytes->ieee-float (bytes #x40 #xd0 0 0)) => 6.5 | + (bytes->ieee-float (bytes #xc0 #xd0 0 0)) => -6.5 | + | + (bytes->ieee-float (bytes 0 #x80 0 0)) => 11.754943508222875e-39 | + (bytes->ieee-float (bytes 0 #x40 0 0)) => 5.877471754111437e-39 | + (bytes->ieee-float (bytes 0 0 0 1)) => 1.401298464324817e-45 | + | + (bytes->ieee-float (bytes #xff #x80 0 0)) => -1/0 | + (bytes->ieee-float (bytes #x7f #x80 0 0)) => 1/0 | + (bytes->ieee-float (bytes #x7f #x80 0 1)) => 0/0 | + | + - Function: bytes->ieee-double bytes | + BYTES must be a 8-element byte-array. `bytes->ieee-double' | + calculates and returns the value of BYTES interpreted as a | + big-endian IEEE 8-byte (64-bit) number. | + | + (bytes->ieee-double (bytes 0 0 0 0 0 0 0 0)) => 0.0 | + (bytes->ieee-double (bytes #x40 0 0 0 0 0 0 0)) => 2 | + (bytes->ieee-double (bytes #x40 #x1A 0 0 0 0 0 0)) => 6.5 | + (bytes->ieee-double (bytes #xC0 #x1A 0 0 0 0 0 0)) => -6.5 | + | + (bytes->ieee-double (bytes 0 8 0 0 0 0 0 0)) => 11.125369292536006e-309 | + (bytes->ieee-double (bytes 0 4 0 0 0 0 0 0)) => 5.562684646268003e-309 | + (bytes->ieee-double (bytes 0 0 0 0 0 0 0 1)) => 4.0e-324 | + | + (bytes->ieee-double (bytes #xFF #xF0 0 0 0 0 0 0)) => -1/0 | + (bytes->ieee-double (bytes #x7F #xF0 0 0 0 0 0 0)) => 1/0 | + (bytes->ieee-double (bytes #x7F #xF8 0 0 0 0 0 0)) => 0/0 | + | + - Function: ieee-float->bytes x | + Returns a 4-element byte-array encoding the IEEE single-precision | + floating-point of X. | + | + (bytes->list (ieee-float->bytes 2.0)) => (64 0 0 0) + (bytes->list (ieee-float->bytes 6.5)) => (64 208 0 0) + (bytes->list (ieee-float->bytes -6.5)) => (192 208 0 0) + | + (bytes->list (ieee-float->bytes 11.754943508222875e-39)) => ( 0 128 0 0) + (bytes->list (ieee-float->bytes 5.877471754111438e-39)) => ( 0 64 0 0) + (bytes->list (ieee-float->bytes 1.401298464324817e-45)) => ( 0 0 0 1) + | + (bytes->list (ieee-float->bytes -1/0)) => (255 128 0 0) + (bytes->list (ieee-float->bytes 1/0)) => (127 128 0 0) + (bytes->list (ieee-float->bytes 0/0)) => (127 128 0 1) + | + - Function: ieee-double->bytes x | + Returns a 8-element byte-array encoding the IEEE double-precision | + floating-point of X. | + | + (bytes->list (ieee-double->bytes 2.0)) => (64 0 0 0 0 0 0 0) | + (bytes->list (ieee-double->bytes 6.5)) => (64 26 0 0 0 0 0 0) | + (bytes->list (ieee-double->bytes -6.5)) => (192 26 0 0 0 0 0 0) | + | + (bytes->list (ieee-double->bytes 11.125369292536006e-309)) | + => ( 0 8 0 0 0 0 0 0) | + (bytes->list (ieee-double->bytes 5.562684646268003e-309)) | + => ( 0 4 0 0 0 0 0 0) | + (bytes->list (ieee-double->bytes 4.0e-324)) | + => ( 0 0 0 0 0 0 0 1) | + | + (bytes->list (ieee-double->bytes -1/0)) => (255 240 0 0 0 0 0 0) | + (bytes->list (ieee-double->bytes 1/0)) => (127 240 0 0 0 0 0 0) | + (bytes->list (ieee-double->bytes 0/0)) => (127 248 0 0 0 0 0 0) | + | +Byte Collation Order | +.................... | + | +The `string<?' ordering of big-endian byte-array representations of | +fixed and IEEE floating-point numbers agrees with the numerical | +ordering only when those numbers are non-negative. | + | +Straighforward modification of these formats can extend the | +byte-collating order to work for their entire ranges. This agreement | +enables the full range of numbers as keys in | +"indexed-sequential-access-method" databases. | + | + - Procedure: integer-byte-collate! byte-vector | + Modifies sign bit of BYTE-VECTOR so that `string<?' ordering of | + two's-complement byte-vectors matches numerical order. | + `integer-byte-collate!' returns BYTE-VECTOR and is its own | + functional inverse. | + | + - Function: integer-byte-collate byte-vector | + Returns copy of BYTE-VECTOR with sign bit modified so that | + `string<?' ordering of two's-complement byte-vectors matches | + numerical order. `integer-byte-collate' is its own functional | + inverse. | + | + - Procedure: ieee-byte-collate! byte-vector | + Modifies BYTE-VECTOR so that `string<?' ordering of IEEE | + floating-point byte-vectors matches numerical order. | + `ieee-byte-collate!' returns BYTE-VECTOR. | + | + - Procedure: ieee-byte-decollate! byte-vector | + Given BYTE-VECTOR modified by `IEEE-byte-collate!', reverses the | + BYTE-VECTOR modifications. | + | + - Function: ieee-byte-collate byte-vector | + Returns copy of BYTE-VECTOR encoded so that `string<?' ordering of | + IEEE floating-point byte-vectors matches numerical order. | + | + - Function: ieee-byte-decollate byte-vector | + Given BYTE-VECTOR returned by `IEEE-byte-collate', reverses the | + BYTE-VECTOR modifications. | + | + +File: slib.info, Node: MAT-File Format, Next: Portable Image Files, Prev: Byte/Number Conversions, Up: Data Structures + | +MAT-File Format +--------------- +`(require 'matfile)' - - Function: bytes->list bytes - - Function: list->bytes bytes - `Bytes->list' returns a newly allocated list of the bytes that - make up the given byte-array. `List->bytes' returns a newly - allocated byte-array formed from the small integers in the list - BYTES. `Bytes->list' and `list->bytes' are inverses so far as - `equal?' is concerned. +`http://www.mathworks.com/access/helpdesk/help/pdf_doc/matlab/matfile_format.pdf' + +This package reads MAT-File Format version 4 (MATLAB) binary data +files. MAT-files written from big-endian or little-endian computers +having IEEE format numbers are currently supported. Support for files +written from VAX or Cray machines could also be added. +The numeric and text matrix types handled; support for "sparse" +matrices awaits a sample file. + + - Function: matfile:read filename + FILENAME should be a string naming an existing file containing a + MATLAB Version 4 MAT-File. The `matfile:read' procedure reads + matrices from the file and returns a list of the results; a list + of the name string and array for each matrix. + + - Function: matfile:load filename + FILENAME should be a string naming an existing file containing a + MATLAB Version 4 MAT-File. The `matfile:load' procedure reads + matrices from the file and defines the `string-ci->symbol' for + each matrix to its corresponding array. `matfile:load' returns a + list of the symbols defined. -File: slib.info, Node: Portable Image Files, Next: Collections, Prev: Byte, Up: Data Structures +File: slib.info, Node: Portable Image Files, Next: Collections, Prev: MAT-File Format, Up: Data Structures Portable Image Files -------------------- - `(require 'pnm)' +`(require 'pnm)' - Function: pnm:type-dimensions path The string PATH must name a "portable bitmap graphics" file. @@ -8020,7 +11044,6 @@ Portable Image Files RGB (full color) image; red, green, and blue interleaved pixel values are from 0 to MAXVAL - - Function: pnm:image-file->array path array Reads the "portable bitmap graphics" file named by PATH into ARRAY. ARRAY must be the correct size and type for PATH. ARRAY @@ -8030,12 +11053,11 @@ Portable Image Files `pnm:image-file->array' creates and returns an array with the "portable bitmap graphics" file named by PATH read into it. - - - Procedure: pnm:array-write type array maxval path + - Function: pnm:array-write type array maxval path comment ... | Writes the contents of ARRAY to a TYPE image file named PATH. The file will have pixel values between 0 and MAXVAL, which must be compatible with TYPE. For `pbm' files, MAXVAL must be `1'. - + COMMENTs are included in the file header. File: slib.info, Node: Collections, Next: Dynamic Data Type, Prev: Portable Image Files, Up: Data Structures @@ -8043,16 +11065,17 @@ File: slib.info, Node: Collections, Next: Dynamic Data Type, Prev: Portable I Collections ----------- - `(require 'collect)' +`(require 'collect)' - Routines for managing collections. Collections are aggregate data +Routines for managing collections. Collections are aggregate data structures supporting iteration over their elements, similar to the Dylan(TM) language, but with a different interface. They have "elements" indexed by corresponding "keys", although the keys may be implicit (as with lists). - New types of collections may be defined as YASOS objects (*note +New types of collections may be defined as YASOS objects (*note Yasos::). They must support the following operations: + * `(collection? SELF)' (always returns `#t'); * `(size SELF)' returns the number of elements in the collection; @@ -8068,15 +11091,15 @@ Yasos::). They must support the following operations: * `(gen-keys SELF)' is like `gen-elts', but yields the collection's keys in order. - They might support specialized `for-each-key' and `for-each-elt' +They might support specialized `for-each-key' and `for-each-elt' operations. - Function: collection? obj A predicate, true initially of lists, vectors and strings. New sorts of collections must answer `#t' to `collection?'. - - Procedure: map-elts proc collection1 ... | - - Procedure: do-elts proc collection1 ... | + - Procedure: map-elts proc collection1 ... + - Procedure: do-elts proc collection1 ... PROC is a procedure taking as many arguments as there are COLLECTIONS (at least one). The COLLECTIONS are iterated over in their natural order and PROC is applied to the elements yielded by @@ -8091,8 +11114,8 @@ operations. (map-elts + (list 1 2 3) (vector 1 2 3)) => #(2 4 6) - - Procedure: map-keys proc collection1 ... | - - Procedure: do-keys proc collection1 ... | + - Procedure: map-keys proc collection1 ... + - Procedure: do-keys proc collection1 ... These are analogous to `map-elts' and `do-elts', but each iteration is over the COLLECTIONS' _keys_ rather than their elements. @@ -8106,10 +11129,10 @@ operations. These are like `do-keys' and `do-elts' but only for a single collection; they are potentially more efficient. - - Function: reduce proc seed collection1 ... | - A generalization of the list-based `comlist:reduce-init' (*note - Lists as sequences::) to collections which will shadow the - list-based version if `(require 'collect)' follows `(require + - Function: reduce proc seed collection1 ... + A generalization of the list-based `reduce-init' (*note Lists as | + sequences::) to collections which will shadow the list-based | + version if `(require 'collect)' follows `(require | 'common-list-functions)' (*note Common List Functions::). Examples: @@ -8118,7 +11141,7 @@ operations. (reduce union '() '((a b c) (b c d) (d a))) => (c b d a). - - Function: any? pred collection1 ... | + - Function: any? pred collection1 ... A generalization of the list-based `some' (*note Lists as sequences::) to collections. @@ -8126,7 +11149,7 @@ operations. (any? odd? (list 2 3 4 5)) => #t - - Function: every? pred collection1 ... | + - Function: every? pred collection1 ... A generalization of the list-based `every' (*note Lists as sequences::) to collections. @@ -8203,8 +11226,7 @@ operations. ) ((FOR-EACH-ELT self proc) (for-each (lambda (bucket) (proc (cdr bucket))) table) - ) - ) ) ) + ) ) ) ) File: slib.info, Node: Dynamic Data Type, Next: Hash Tables, Prev: Collections, Up: Data Structures @@ -8212,7 +11234,7 @@ File: slib.info, Node: Dynamic Data Type, Next: Hash Tables, Prev: Collection Dynamic Data Type ----------------- - `(require 'dynamic)' +`(require 'dynamic)' - Function: make-dynamic obj Create and returns a new "dynamic" whose global value is OBJ. @@ -8242,12 +11264,12 @@ Dynamic Data Type The `dynamic-bind' macro is not implemented. -File: slib.info, Node: Hash Tables, Next: Hashing, Prev: Dynamic Data Type, Up: Data Structures +File: slib.info, Node: Hash Tables, Next: Object, Prev: Dynamic Data Type, Up: Data Structures Hash Tables ----------- - `(require 'hash-table)' +`(require 'hash-table)' - Function: predicate->hash pred Returns a hash function (like `hashq', `hashv', or `hash') @@ -8255,12 +11277,12 @@ Hash Tables `eq?', `eqv?', `equal?', `=', `char=?', `char-ci=?', `string=?', or `string-ci=?'. - A hash table is a vector of association lists. +A hash table is a vector of association lists. - Function: make-hash-table k Returns a vector of K empty (association) lists. - Hash table functions provide utilities for an associative database. +Hash table functions provide utilities for an associative database. These functions take an equality predicate, PRED, as an argument. PRED should be `eq?', `eqv?', `equal?', `=', `char=?', `char-ci=?', `string=?', or `string-ci=?'. @@ -8272,9 +11294,9 @@ should be `eq?', `eqv?', `equal?', `=', `char=?', `char-ci=?', `#f' if no key in HASHTAB is PRED-equal to the first argument. - Function: hash-inquirer pred - Returns a procedure of 2 arguments, HASHTAB and KEY, which returns | - the value associated with KEY in HASHTAB or `#f' if KEY does not | - appear in HASHTAB. | + Returns a procedure of 2 arguments, HASHTAB and KEY, which returns + the value associated with KEY in HASHTAB or `#f' if KEY does not + appear in HASHTAB. - Function: hash-associator pred Returns a procedure of 3 arguments, HASHTAB, KEY, and VALUE, which @@ -8296,128 +11318,23 @@ should be `eq?', `eqv?', `equal?', `=', `char=?', `char-ci=?', must be a function of 2 arguments. The returned value is unspecified. + - Function: hash-rehasher pred | + `hash-rehasher' accepts a hash table predicate and returns a | + function of two arguments HASHTAB and NEW-K which is specialized | + for that predicate. | + | + This function is used for nondestrutively resizing a hash table. | + HASHTAB should be an existing hash-table using PRED, 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. | + | -File: slib.info, Node: Hashing, Next: Object, Prev: Hash Tables, Up: Data Structures - -Hashing -------- - - `(require 'hash)' - - These hashing functions are for use in quickly classifying objects. -Hash tables use these functions. - - - Function: hashq obj k - - Function: hashv obj k - - Function: hash obj k - Returns an exact non-negative integer less than K. For each - non-negative integer less than K there are arguments OBJ for which - the hashing functions applied to OBJ and K returns that integer. - - For `hashq', `(eq? obj1 obj2)' implies `(= (hashq obj1 k) (hashq - obj2))'. - - For `hashv', `(eqv? obj1 obj2)' implies `(= (hashv obj1 k) (hashv - obj2))'. - - For `hash', `(equal? obj1 obj2)' implies `(= (hash obj1 k) (hash - obj2))'. - - `hash', `hashv', and `hashq' return in time bounded by a constant. - Notice that items having the same `hash' implies the items have - the same `hashv' implies the items have the same `hashq'. - - `(require 'sierpinski)' - - - Function: make-sierpinski-indexer max-coordinate - Returns a procedure (eg hash-function) of 2 numeric arguments which - preserves _nearness_ in its mapping from NxN to N. - - MAX-COORDINATE is the maximum coordinate (a positive integer) of a - population of points. The returned procedures is a function that - takes the x and y coordinates of a point, (non-negative integers) - and returns an integer corresponding to the relative position of - that point along a Sierpinski curve. (You can think of this as - computing a (pseudo-) inverse of the Sierpinski spacefilling - curve.) - - Example use: Make an indexer (hash-function) for integer points - lying in square of integer grid points [0,99]x[0,99]: - (define space-key (make-sierpinski-indexer 100)) - Now let's compute the index of some points: - (space-key 24 78) => 9206 - (space-key 23 80) => 9172 - - Note that locations (24, 78) and (23, 80) are near in index and - therefore, because the Sierpinski spacefilling curve is - continuous, we know they must also be near in the plane. Nearness - in the plane does not, however, necessarily correspond to nearness - in index, although it _tends_ to be so. - - Example applications: - * Sort points by Sierpinski index to get heuristic solution to - _travelling salesman problem_. For details of performance, - see L. Platzman and J. Bartholdi, "Spacefilling curves and the - Euclidean travelling salesman problem", JACM 36(4):719-737 - (October 1989) and references therein. - - * Use Sierpinski index as key by which to store 2-dimensional - data in a 1-dimensional data structure (such as a table). - Then locations that are near each other in 2-d space will - tend to be near each other in 1-d data structure; and - locations that are near in 1-d data structure will be near in - 2-d space. This can significantly speed retrieval from - secondary storage because contiguous regions in the plane - will tend to correspond to contiguous regions in secondary - storage. (This is a standard technique for managing CAD/CAM - or geographic data.) - - - `(require 'soundex)' - - - Function: soundex name - Computes the _soundex_ hash of NAME. Returns a string of an - initial letter and up to three digits between 0 and 6. Soundex - supposedly has the property that names that sound similar in normal - English pronunciation tend to map to the same key. - - Soundex was a classic algorithm used for manual filing of personal - records before the advent of computers. It performs adequately for - English names but has trouble with other languages. - - See Knuth, Vol. 3 `Sorting and searching', pp 391-2 - - To manage unusual inputs, `soundex' omits all non-alphabetic - characters. Consequently, in this implementation: - - (soundex <string of blanks>) => "" - (soundex "") => "" - - Examples from Knuth: - - (map soundex '("Euler" "Gauss" "Hilbert" "Knuth" - "Lloyd" "Lukasiewicz")) - => ("E460" "G200" "H416" "K530" "L300" "L222") - - (map soundex '("Ellery" "Ghosh" "Heilbronn" "Kant" - "Ladd" "Lissajous")) - => ("E460" "G200" "H416" "K530" "L300" "L222") - - Some cases in which the algorithm fails (Knuth): - - (map soundex '("Rogers" "Rodgers")) => ("R262" "R326") - - (map soundex '("Sinclair" "St. Clair")) => ("S524" "S324") - - (map soundex '("Tchebysheff" "Chebyshev")) => ("T212" "C121") - - -File: slib.info, Node: Object, Next: Priority Queues, Prev: Hashing, Up: Data Structures +File: slib.info, Node: Object, Next: Priority Queues, Prev: Hash Tables, Up: Data Structures Macroless Object System ----------------------- - `(require 'object)' +`(require 'object)' This is the Macroless Object System written by Wade Humeniuk (whumeniu@datap.ca). Conceptual Tributes: *Note Yasos::, MacScheme's @@ -8555,7 +11472,7 @@ Examples Inverter Documentation ...................... - Inheritance: +Inheritance: <inverter>::(<number> <description>) Generic-methods <inverter>::value => <number>::value @@ -8568,7 +11485,7 @@ Inverter Documentation Number Documention .................. - Inheritance +Inheritance <number>::() Slots <number>::<x> @@ -8643,8 +11560,11 @@ File: slib.info, Node: Priority Queues, Next: Queues, Prev: Object, Up: Data Priority Queues --------------- - `(require 'priority-queue)' +`(require 'priority-queue)' +This algorithm for priority queues is due to `Introduction to | +Algorithms' by T. Cormen, C. Leiserson, R. Rivest. 1989 MIT Press. | + | - Function: make-heap pred<? Returns a binary heap suitable which can be used for priority queue operations. @@ -8656,21 +11576,18 @@ Priority Queues Inserts ITEM into HEAP. ITEM can be inserted multiple times. The value returned is unspecified. - - Function: heap-extract-max! heap + - Procedure: heap-extract-max! heap | Returns the item which is larger than all others according to the PRED<? argument to `make-heap'. If there are no items in HEAP, an error is signaled. - - The algorithm for priority queues was taken from `Introduction to -Algorithms' by T. Cormen, C. Leiserson, R. Rivest. 1989 MIT Press. - + | File: slib.info, Node: Queues, Next: Records, Prev: Priority Queues, Up: Data Structures Queues ------ - `(require 'queue)' +`(require 'queue)' A "queue" is a list where elements can be added to both the front and rear, and removed from the front (i.e., they are what are often called @@ -8688,30 +11605,32 @@ rear, and removed from the front (i.e., they are what are often called - Procedure: queue-push! q datum Adds DATUM to the front of queue Q. - - Procedure: enquque! q datum + - Procedure: enqueue! q datum Adds DATUM to the rear of queue Q. - All of the following functions raise an error if the queue Q is empty. - + - Procedure: dequeue! q | + - Procedure: queue-pop! q | + Both of these procedures remove and return the datum at the front | + of the queue. `queue-pop!' is used to suggest that the queue is | + being used like a stack. | + All of the following functions raise an error if the queue Q is empty. | + | + - Procedure: dequeue-all! q + Removes and returns (the list) of all contents of queue Q. + | - Function: queue-front q Returns the datum at the front of the queue Q. - Function: queue-rear q Returns the datum at the rear of the queue Q. - - - Prcoedure: queue-pop! q - - Procedure: dequeue! q - Both of these procedures remove and return the datum at the front - of the queue. `queue-pop!' is used to suggest that the queue is - being used like a stack. - + | File: slib.info, Node: Records, Prev: Queues, Up: Data Structures - | + Records ------- - `(require 'record)' +`(require 'record)' The Record package provides a facility for user to define their own record data types. @@ -8779,27 +11698,30 @@ supported. File: slib.info, Node: Sorting and Searching, Next: Procedures, Prev: Data Structures, Up: Other Packages - | -Sorting and Searching | -===================== | + +Sorting and Searching +===================== * Menu: * Common List Functions:: 'common-list-functions -* Tree Operations:: 'tree | +* Tree Operations:: 'tree * Chapter Ordering:: 'chapter-order * Sorting:: 'sort -* Topological Sort:: Keep your socks on. | +* Topological Sort:: Keep your socks on. +* Hashing:: 'hash +* Space-Filling Curves:: 'hilbert and 'sierpinski +* Soundex:: Dimension Reduction of Last Names * String Search:: Also Search from a Port. -* Sequence Comparison:: 'diff and longest-common-subsequence | +* Sequence Comparison:: 'diff and longest-common-subsequence File: slib.info, Node: Common List Functions, Next: Tree Operations, Prev: Sorting and Searching, Up: Sorting and Searching - | + Common List Functions --------------------- - `(require 'common-list-functions)' +`(require 'common-list-functions)' The procedures below follow the Common LISP equivalents apart from optional arguments in some cases. @@ -8818,8 +11740,8 @@ File: slib.info, Node: List construction, Next: Lists as sets, Prev: Common L List construction ................. - - Function: make-list k | - - Function: make-list k init | + - Function: make-list k + - Function: make-list k init `make-list' creates and returns a list of K elements. If INIT is included, all elements in the list are initialized to INIT. @@ -8829,10 +11751,11 @@ List construction (make-list 5 'foo) => (foo foo foo foo foo) - - Function: list* obj1 obj2 ... | + - Function: list* obj1 obj2 ... Works like `list' except that the cdr of the last pair is the last argument unless there is only one argument, when the result is just that argument. Sometimes called `cons*'. E.g.: + (list* 1) => 1 (list* 1 2 3) @@ -8871,7 +11794,7 @@ File: slib.info, Node: Lists as sets, Next: Lists as sequences, Prev: List co Lists as sets ............. - `eqv?' is used to test for membership by procedures which treat lists +`eqv?' is used to test for membership by procedures which treat lists as sets. - Function: adjoin e l @@ -8886,46 +11809,58 @@ as sets. => (foo bar baz bang) - Function: union l1 l2 - `union' returns the combination of L1 and L2. Duplicates between - L1 and L2 are culled. Duplicates within L1 or within L2 may or - may not be removed. + `union' returns a list of all elements that are in L1 or L2. + Duplicates between L1 and L2 are culled. Duplicates within L1 or + within L2 may or may not be removed. Example: (union '(1 2 3 4) '(5 6 7 8)) - => (8 7 6 5 1 2 3 4) | - (union '(1 2 3 4) '(3 4 5 6)) - => (6 5 1 2 3 4) | + => (1 2 3 4 5 6 7 8) + (union '(0 1 2 3 4) '(3 4 5 6)) + => (5 6 0 1 2 3 4) - Function: intersection l1 l2 - `intersection' returns all elements that are in both L1 and L2. + `intersection' returns a list of all elements that are in both L1 + and L2. Example: (intersection '(1 2 3 4) '(3 4 5 6)) - => (3 4) | + => (3 4) (intersection '(1 2 3 4) '(5 6 7 8)) => () - Function: set-difference l1 l2 - `set-difference' returns all elements that are in L1 but not in L2. + `set-difference' returns a list of all elements that are in L1 but + not in L2. Example: (set-difference '(1 2 3 4) '(3 4 5 6)) - => (1 2) | + => (1 2) (set-difference '(1 2 3 4) '(1 2 3 4 5 6)) => () + - Function: subset? list1 list2 + Returns `#t' if every element of LIST1 is `eqv?' an element of + LIST2; otherwise returns `#f'. + + Example: + (subset? '(1 2 3 4) '(3 4 5 6)) + => #f + (subset? '(1 2 3 4) '(6 5 4 3 2 1 0)) + => #t + - Function: member-if pred lst - `member-if' returns LST if `(PRED ELEMENT)' is `#t' for any - ELEMENT in LST. Returns `#f' if PRED does not apply to any - ELEMENT in LST. + `member-if' returns the list headed by the first element of LST to + satisfy `(PRED ELEMENT)'. `Member-if' returns `#f' if PRED + returns `#f' for every ELEMENT in LST. Example: - (member-if vector? '(1 2 3 4)) + (member-if vector? '(a 2 b 4)) => #f - (member-if number? '(1 2 3 4)) - => (1 2 3 4) + (member-if number? '(a 2 b 4)) + => (2 b 4) - - Function: some pred lst1 lst2 ... | + - Function: some pred lst1 lst2 ... PRED is a boolean function of as many arguments as there are list arguments to `some' i.e., LST plus any optional arguments. PRED is applied to successive elements of the list arguments in order. @@ -8940,10 +11875,10 @@ as sets. (some odd? '(2 4 6 8)) => #f - (some > '(2 3) '(1 4)) + (some > '(1 3) '(2 4)) => #f - - Function: every pred lst1 lst2 ... | + - Function: every pred lst1 lst2 ... `every' is analogous to `some' except it returns `#t' if every application of PRED is `#t' and `#f' otherwise. @@ -8957,11 +11892,11 @@ as sets. (every > '(2 3) '(1 4)) => #f - - Function: notany pred lst1 ... | + - Function: notany pred lst1 ... `notany' is analogous to `some' but returns `#t' if no application of PRED returns `#t' or `#f' as soon as any one does. - - Function: notevery pred lst1 ... | + - Function: notevery pred lst1 ... `notevery' is analogous to `some' but returns `#t' as soon as an application of PRED returns `#f', and `#f' otherwise. @@ -9013,10 +11948,10 @@ as sets. Example: (remove 1 '(1 2 1 3 1 4 1 5)) - => (2 3 4 5) | + => (2 3 4 5) (remove 'foo '(bar baz bang)) - => (bar baz bang) | + => (bar baz bang) - Function: remove-if pred lst `remove-if' removes all ELEMENTs from LST where `(PRED ELEMENT)' @@ -9027,7 +11962,7 @@ as sets. => () (remove-if even? '(1 2 3 4 5 6 7 8)) - => (1 3 5 7) | + => (1 3 5 7) - Function: remove-if-not pred lst `remove-if-not' removes all ELEMENTs from LST for which `(PRED @@ -9037,7 +11972,7 @@ as sets. (remove-if-not number? '(foo bar baz)) => () (remove-if-not odd? '(1 2 3 4 5 6 7 8)) - => (1 3 5 7) | + => (1 3 5 7) - Function: has-duplicates? lst returns `#t' if 2 members of LST are `equal?', `#f' otherwise. @@ -9057,10 +11992,10 @@ as sets. Example: (remove-duplicates '(1 2 3 4)) - => (1 2 3 4) | + => (1 2 3 4) (remove-duplicates '(2 4 3 4)) - => (2 4 3) | + => (2 4 3) File: slib.info, Node: Lists as sequences, Next: Destructive list operations, Prev: Lists as sets, Up: Common List Functions @@ -9230,7 +12165,7 @@ File: slib.info, Node: Destructive list operations, Next: Non-List functions, Destructive list operations ........................... - These procedures may mutate the list they operate on, but any such +These procedures may mutate the list they operate on, but any such mutation is undefined. - Procedure: nconc args @@ -9244,8 +12179,8 @@ mutation is undefined. (define (subsets set) (if (null? set) '(()) - (append (mapcar (lambda (sub) (cons (car set) sub)) - (subsets (cdr set))) + (append (map (lambda (sub) (cons (car set) sub)) + (subsets (cdr set))) (subsets (cdr set))))) But that does way more consing than you need. Instead, you could replace the `append' with `nconc', since you don't have any need @@ -9275,6 +12210,7 @@ mutation is undefined. Some people have been confused about how to use `nreverse', thinking that it doesn't return a value. It needs to be pointed out that + (set! lst (nreverse lst)) is the proper usage, not @@ -9287,21 +12223,22 @@ mutation is undefined. Destructive versions of `remove' `remove-if', and `remove-if-not'. Example: - (define lst '(foo bar baz bang)) + (define lst (list 'foo 'bar 'baz 'bang)) (delete 'foo lst) => (bar baz bang) lst => (foo bar baz bang) - (define lst '(1 2 3 4 5 6 7 8 9)) + (define lst (list 1 2 3 4 5 6 7 8 9)) (delete-if odd? lst) => (2 4 6 8) lst => (1 2 4 6 8) Some people have been confused about how to use `delete', - `delete-if', and `delete-if', thinking that they dont' return a + `delete-if', and `delete-if', thinking that they don't return a value. It needs to be pointed out that + (set! lst (delete el lst)) is the proper usage, not @@ -9314,7 +12251,7 @@ File: slib.info, Node: Non-List functions, Prev: Destructive list operations, Non-List functions .................. - - Function: and? arg1 ... | + - Function: and? arg1 ... `and?' checks to see if all its arguments are true. If they are, `and?' returns `#t', otherwise, `#f'. (In contrast to `and', this is a function, so all arguments are always evaluated and in an @@ -9326,7 +12263,7 @@ Non-List functions (and #f 1 2) => #f - - Function: or? arg1 ... | + - Function: or? arg1 ... `or?' checks to see if any of its arguments are true. If any is true, `or?' returns `#t', and `#f' otherwise. (To `or' as `and?' is to `and'.) @@ -9349,26 +12286,26 @@ Non-List functions File: slib.info, Node: Tree Operations, Next: Chapter Ordering, Prev: Common List Functions, Up: Sorting and Searching - | + Tree operations --------------- - `(require 'tree)' +`(require 'tree)' These are operations that treat lists a representations of trees. - - Function: subst new old tree - - Function: subst new old tree equ? | + - Function: subst new old tree | - Function: substq new old tree - Function: substv new old tree + - Function: subst new old tree equ? | `subst' makes a copy of TREE, substituting NEW for every subtree or leaf of TREE which is `equal?' to OLD and returns a modified tree. The original TREE is unchanged, but may share parts with the result. `substq' and `substv' are similar, but test against OLD using - `eq?' and `eqv?' respectively. If `subst' is called with a fourth | - argument, EQU? is the equality predicate. | + `eq?' and `eqv?' respectively. If `subst' is called with a fourth + argument, EQU? is the equality predicate. Examples: (substq 'tempest 'hurricane '(shakespeare wrote (the hurricane))) @@ -9393,11 +12330,11 @@ Tree operations File: slib.info, Node: Chapter Ordering, Next: Sorting, Prev: Tree Operations, Up: Sorting and Searching - | + Chapter Ordering ---------------- - `(require 'chapter-order)' +`(require 'chapter-order)' The `chap:' functions deal with strings which are ordered like chapter numbers (or letters) in a book. Each section of the string @@ -9432,11 +12369,11 @@ like case. File: slib.info, Node: Sorting, Next: Topological Sort, Prev: Chapter Ordering, Up: Sorting and Searching - | + Sorting ------- - `(require 'sort)' +`(require 'sort)' Many Scheme systems provide some kind of sorting functions. They do not, however, always provide the _same_ sorting functions, and those @@ -9526,8 +12463,8 @@ as saying when `x' must _not_ precede `y'. ...' for which `(less? y x)'). Returns `#f' when the sequence contains at least one out-of-order - pair. It is an error if the sequence is neither a list nor a - vector. + pair. It is an error if the sequence is not a list, vector, or | + string. | - Function: merge list1 list2 less? This merges two lists, producing a completely new list as result. @@ -9550,18 +12487,19 @@ as saying when `x' must _not_ precede `y'. done per iteration. (For example, we only have one `null?' test per iteration.) + - Function: sort sequence less? - Accepts either a list or a vector, and returns a new sequence - which is sorted. The new sequence is the same type as the input. - Always `(sorted? (sort sequence less?) less?)'. The original - sequence is not altered in any way. The new sequence shares its - _elements_ with the old one; no elements are copied. + Accepts either a list, vector, or string; and returns a new | + sequence which is sorted. The new sequence is the same type as | + the input. Always `(sorted? (sort sequence less?) less?)'. The | + original sequence is not altered in any way. The new sequence | + shares its _elements_ with the old one; no elements are copied. | - Procedure: sort! sequence less? Returns its sorted result in the original boxes. If the original sequence is a list, no new storage is allocated at all. If the - original sequence is a vector, the sorted elements are put back in - the same vector. + original sequence is a vector or string, the sorted elements are | + put back in the same vector or string. | Some people have been confused about how to use `sort!', thinking that it doesn't return a value. It needs to be pointed out that @@ -9572,6 +12510,7 @@ as saying when `x' must _not_ precede `y'. Note that these functions do _not_ accept a CL-style `:key' argument. A simple device for obtaining the same expressiveness is to define + (define (keyed less? key) (lambda (x y) (less? (key x) (key y)))) @@ -9584,12 +12523,12 @@ in Common LISP, just write in Scheme. -File: slib.info, Node: Topological Sort, Next: String Search, Prev: Sorting, Up: Sorting and Searching - | +File: slib.info, Node: Topological Sort, Next: Hashing, Prev: Sorting, Up: Sorting and Searching + Topological Sort ---------------- - `(require 'topological-sort)' or `(require 'tsort)' +`(require 'topological-sort)' or `(require 'tsort)' The algorithm is inspired by Cormen, Leiserson and Rivest (1990) `Introduction to Algorithms', chapter 23. @@ -9614,6 +12553,7 @@ The algorithm is inspired by Cormen, Leiserson and Rivest (1990) Time complexity: O (|V| + |E|) Example (from Cormen): + Prof. Bumstead topologically sorts his clothing when getting dressed. The first argument to `tsort' describes which garments he needs to put on before others. (For example, @@ -9634,12 +12574,181 @@ The algorithm is inspired by Cormen, Leiserson and Rivest (1990) (socks undershorts pants shoes watch shirt belt tie jacket) -File: slib.info, Node: String Search, Next: Sequence Comparison, Prev: Topological Sort, Up: Sorting and Searching - | +File: slib.info, Node: Hashing, Next: Space-Filling Curves, Prev: Topological Sort, Up: Sorting and Searching + +Hashing +------- + +`(require 'hash)' + + These hashing functions are for use in quickly classifying objects. +Hash tables use these functions. + + - Function: hashq obj k + - Function: hashv obj k + - Function: hash obj k + Returns an exact non-negative integer less than K. For each + non-negative integer less than K there are arguments OBJ for which + the hashing functions applied to OBJ and K returns that integer. + + For `hashq', `(eq? obj1 obj2)' implies `(= (hashq obj1 k) (hashq + obj2))'. + + For `hashv', `(eqv? obj1 obj2)' implies `(= (hashv obj1 k) (hashv + obj2))'. + + For `hash', `(equal? obj1 obj2)' implies `(= (hash obj1 k) (hash + obj2))'. + + `hash', `hashv', and `hashq' return in time bounded by a constant. + Notice that items having the same `hash' implies the items have + the same `hashv' implies the items have the same `hashq'. + + +File: slib.info, Node: Space-Filling Curves, Next: Soundex, Prev: Hashing, Up: Sorting and Searching + +Space-Filling Curves +-------------------- + +* Menu: + +* Peano-Hilbert Space-Filling Curve:: +* Sierpinski Curve:: + + +File: slib.info, Node: Peano-Hilbert Space-Filling Curve, Next: Sierpinski Curve, Prev: Space-Filling Curves, Up: Space-Filling Curves + +Peano-Hilbert Space-Filling Curve +................................. + +`(require 'hilbert-fill)' + +The "Peano-Hilbert Space-Filling Curve" is a one-to-one mapping between +a unit line segment and an N-dimensional unit cube. + +The integer procedures map the non-negative integers to an arbitrarily +large N-dimensional cube with its corner at the origin and all +coordinates are non-negative. + +For any exact nonnegative integers SCALAR and RANK, + + (= SCALAR (hilbert-coordinates->integer + (integer->hilbert-coordinates SCALAR RANK))) + => #t + + - Function: integer->hilbert-coordinates scalar rank + Returns a list of RANK integer coordinates corresponding to exact + non-negative integer SCALAR. The lists returned by + `integer->hilbert-coordinates' for SCALAR arguments 0 and 1 will + differ in the first element. + + - Function: hilbert-coordinates->integer coords + Returns an exact non-negative integer corresponding to COORDS, a + list of non-negative integer coordinates. + + +File: slib.info, Node: Sierpinski Curve, Prev: Peano-Hilbert Space-Filling Curve, Up: Space-Filling Curves + +Sierpinski Curve +................ + +`(require 'sierpinski)' + + - Function: make-sierpinski-indexer max-coordinate + Returns a procedure (eg hash-function) of 2 numeric arguments which + preserves _nearness_ in its mapping from NxN to N. + + MAX-COORDINATE is the maximum coordinate (a positive integer) of a + population of points. The returned procedures is a function that + takes the x and y coordinates of a point, (non-negative integers) + and returns an integer corresponding to the relative position of + that point along a Sierpinski curve. (You can think of this as + computing a (pseudo-) inverse of the Sierpinski spacefilling + curve.) + + Example use: Make an indexer (hash-function) for integer points + lying in square of integer grid points [0,99]x[0,99]: + (define space-key (make-sierpinski-indexer 100)) + Now let's compute the index of some points: + (space-key 24 78) => 9206 + (space-key 23 80) => 9172 + + Note that locations (24, 78) and (23, 80) are near in index and + therefore, because the Sierpinski spacefilling curve is + continuous, we know they must also be near in the plane. Nearness + in the plane does not, however, necessarily correspond to nearness + in index, although it _tends_ to be so. + + Example applications: + * Sort points by Sierpinski index to get heuristic solution to + _travelling salesman problem_. For details of performance, + see L. Platzman and J. Bartholdi, "Spacefilling curves and the + Euclidean travelling salesman problem", JACM 36(4):719-737 + (October 1989) and references therein. + + * Use Sierpinski index as key by which to store 2-dimensional + data in a 1-dimensional data structure (such as a table). + Then locations that are near each other in 2-d space will + tend to be near each other in 1-d data structure; and + locations that are near in 1-d data structure will be near in + 2-d space. This can significantly speed retrieval from + secondary storage because contiguous regions in the plane + will tend to correspond to contiguous regions in secondary + storage. (This is a standard technique for managing CAD/CAM + or geographic data.) + + + +File: slib.info, Node: Soundex, Next: String Search, Prev: Space-Filling Curves, Up: Sorting and Searching + +Soundex +------- + +`(require 'soundex)' + + - Function: soundex name + Computes the _soundex_ hash of NAME. Returns a string of an + initial letter and up to three digits between 0 and 6. Soundex + supposedly has the property that names that sound similar in normal + English pronunciation tend to map to the same key. + + Soundex was a classic algorithm used for manual filing of personal + records before the advent of computers. It performs adequately for + English names but has trouble with other languages. + + See Knuth, Vol. 3 `Sorting and searching', pp 391-2 + + To manage unusual inputs, `soundex' omits all non-alphabetic + characters. Consequently, in this implementation: + + (soundex <string of blanks>) => "" + (soundex "") => "" + + Examples from Knuth: + + (map soundex '("Euler" "Gauss" "Hilbert" "Knuth" + "Lloyd" "Lukasiewicz")) + => ("E460" "G200" "H416" "K530" "L300" "L222") + + (map soundex '("Ellery" "Ghosh" "Heilbronn" "Kant" + "Ladd" "Lissajous")) + => ("E460" "G200" "H416" "K530" "L300" "L222") + + Some cases in which the algorithm fails (Knuth): + + (map soundex '("Rogers" "Rodgers")) => ("R262" "R326") + + (map soundex '("Sinclair" "St. Clair")) => ("S524" "S324") + + (map soundex '("Tchebysheff" "Chebyshev")) => ("T212" "C121") + + +File: slib.info, Node: String Search, Next: Sequence Comparison, Prev: Soundex, Up: Sorting and Searching + String Search ------------- - `(require 'string-search)' +`(require 'string-search)' - Procedure: string-index string char - Procedure: string-index-ci string char @@ -9651,8 +12760,8 @@ String Search Returns the index of the last occurence of CHAR within STRING, or `#f' if the STRING does not contain a character CHAR. - - procedure: substring? pattern string - - procedure: substring-ci? pattern string + - Procedure: substring? pattern string | + - Procedure: substring-ci? pattern string | Searches STRING to see if some substring of STRING is equal to PATTERN. `substring?' returns the index of the first character of the first substring of STRING that is equal to PATTERN; or `#f' if @@ -9690,172 +12799,206 @@ String Search - Function: string-subst txt old1 new1 ... Returns a copy of string TXT with all occurrences of string OLD1 - in TXT replaced with NEW1, OLD2 replaced with NEW2 .... + in TXT replaced with NEW1; then OLD2 replaced with NEW2 .... + Matches are found from the left. Matches do not overlap. + + - Function: count-newlines str | + Returns the number of `#\newline' characters in string STR. File: slib.info, Node: Sequence Comparison, Prev: String Search, Up: Sorting and Searching - | -Sequence Comparison | -------------------- | - | - `(require 'diff)' | - | -This package implements the algorithm: | - | - S. Wu, E. Myers, U. Manber, and W. Miller, | - "An O(NP) Sequence Comparison Algorithm," | - Information Processing Letters 35, 6 (1990), 317-323. | - <http://www.cs.arizona.edu/people/gene/vita.html> | - | -If the items being sequenced are text lines, then the computed | -edit-list is equivalent to the output of the "diff" utility program. | -If the items being sequenced are words, then it is like the lesser | -known "spiff" program. | - | -The values returned by `diff:edit-length' can be used to gauge the | -degree of match between two sequences. | - | -I believe that this algorithm is currently the fastest for these tasks, | -but genome sequencing applications fuel extensive research in this area. | - | - - Function: diff:longest-common-subsequence array1 array2 =? | - - Function: diff:longest-common-subsequence array1 array2 | - ARRAY1 and ARRAY2 are one-dimensional arrays. The procedure =? is | - used to compare sequence tokens for equality. =? defaults to | - `eqv?'. `diff:longest-common-subsequence' returns a | - one-dimensional array of length `(quotient (- (+ len1 len2) | - (fp:edit-length ARRAY1 ARRAY2)) 2)' holding the longest sequence | - common to both ARRAYs. | - | - - Function: diff:edits array1 array2 =? | - - Function: diff:edits array1 array2 | - ARRAY1 and ARRAY2 are one-dimensional arrays. The procedure =? is | - used to compare sequence tokens for equality. =? defaults to | - `eqv?'. `diff:edits' returns a list of length `(fp:edit-length | - ARRAY1 ARRAY2)' composed of a shortest sequence of edits | - transformaing ARRAY1 to ARRAY2. | - | - Each edit is a list of an integer and a symbol: | - (J insert) | - Inserts `(array-ref ARRAY1 J)' into the sequence. | - | - (K delete) | - Deletes `(array-ref ARRAY2 K)' from the sequence. | - | - - Function: diff:edit-length array1 array2 =? | - - Function: diff:edit-length array1 array2 | - ARRAY1 and ARRAY2 are one-dimensional arrays. The procedure =? is | - used to compare sequence tokens for equality. =? defaults to | - `eqv?'. `diff:edit-length' returns the length of the shortest | - sequence of edits transformaing ARRAY1 to ARRAY2. | - | - (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)) | - => #(f g h i j k l m) | - | - (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)) | - => 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))) | - -| | - ((3 insert) ; e | - (4 delete) ; c | - (6 delete) ; h | - (7 insert) ; p | - (8 insert) ; q | - (9 insert)) ; r | - | + +Sequence Comparison +------------------- + +`(require 'diff)' + +`diff:edit-length' implements the algorithm: + + S. Wu, E. Myers, U. Manber, and W. Miller, + "An O(NP) Sequence Comparison Algorithm," + Information Processing Letters 35, 6 (1990), 317-323. + <http://www.cs.arizona.edu/people/gene/vita.html> + +The values returned by `diff:edit-length' can be used to gauge the +degree of match between two sequences. + +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. | + +If the items being sequenced are text lines, then the computed +edit-list is equivalent to the output of the "diff" utility program. +If the items being sequenced are words, then it is like the lesser +known "spiff" program. + + - Function: diff:longest-common-subsequence array1 array2 =? p-lim + - Function: diff:longest-common-subsequence array1 array2 =? + ARRAY1 and ARRAY2 are one-dimensional arrays. The procedure =? is + used to compare sequence tokens for equality. + + The non-negative integer P-LIM, if provided, is maximum number of + deletions of the shorter sequence to allow. + `diff:longest-common-subsequence' will return `#f' if more + deletions would be necessary. + + `diff:longest-common-subsequence' returns a one-dimensional array + of length `(quotient (- (+ len1 len2) (diff:edit-length ARRAY1 + ARRAY2)) 2)' holding the longest sequence common to both ARRAYs. + + - Function: diff:edits array1 array2 =? p-lim + - Function: diff:edits array1 array2 =? + ARRAY1 and ARRAY2 are one-dimensional arrays. The procedure =? is + used to compare sequence tokens for equality. + + The non-negative integer P-LIM, if provided, is maximum number of + deletions of the shorter sequence to allow. `diff:edits' will + return `#f' if more deletions would be necessary. + + `diff:edits' returns a vector of length `(diff:edit-length ARRAY1 + ARRAY2)' composed of a shortest sequence of edits transformaing + ARRAY1 to ARRAY2. + + Each edit is an integer: + K > 0 + Inserts `(array-ref ARRAY1 (+ -1 J))' into the sequence. + + K < 0 + Deletes `(array-ref ARRAY2 (- -1 K))' from the sequence. + + - Function: diff:edit-length array1 array2 =? p-lim + - Function: diff:edit-length array1 array2 =? + ARRAY1 and ARRAY2 are one-dimensional arrays. The procedure =? is + used to compare sequence tokens for equality. + + The non-negative integer P-LIM, if provided, is maximum number of + deletions of the shorter sequence to allow. `diff:edit-length' + will return `#f' if more deletions would be necessary. + + `diff:edit-length' returns the length of the shortest sequence of + edits transformaing ARRAY1 to ARRAY2. + + (diff:longest-common-subsequence "fghiejcklm" "fgehijkpqrlm" eqv?) + => "fghijklm" + + (diff:edit-length "fghiejcklm" "fgehijkpqrlm" eqv?) + => 6 + + (diff:edits "fghiejcklm" "fgehijkpqrlm" eqv?) + => #As32(3 -5 -7 8 9 10) + ; e c h p q r + File: slib.info, Node: Procedures, Next: Standards Support, Prev: Sorting and Searching, Up: Other Packages - | -Procedures | -========== | - | - Anything that doesn't fall neatly into any of the other categories | -winds up here. | - | -* Menu: | - | -* Type Coercion:: 'coerce | -* String-Case:: 'string-case | -* String Ports:: 'string-port | -* Line I/O:: 'line-i/o | -* Multi-Processing:: 'process | -* Metric Units:: Portable manifest types for numeric values. | - | + +Procedures +========== + +Anything that doesn't fall neatly into any of the other categories winds +up here. + +* Menu: + +* Type Coercion:: 'coerce +* String-Case:: 'string-case +* String Ports:: 'string-port +* Line I/O:: 'line-i/o +* Multi-Processing:: 'process +* Metric Units:: Portable manifest types for numeric values. + File: slib.info, Node: Type Coercion, Next: String-Case, Prev: Procedures, Up: Procedures - | -Type Coercion | -------------- | - | - `(require 'coerce)' | - | - - Function: type-of obj | - Returns a symbol name for the type of OBJ. | - | - - Function: coerce obj result-type | - Converts and returns OBJ of type `char', `number', `string', | - `symbol', `list', or `vector' to RESULT-TYPE (which must be one of | - these symbols). | - | + +Type Coercion +------------- + +`(require 'coerce)' + + - Function: type-of obj + Returns a symbol name for the type of OBJ. + + - Function: coerce obj result-type + Converts and returns OBJ of type `char', `number', `string', + `symbol', `list', or `vector' to RESULT-TYPE (which must be one of + these symbols). + File: slib.info, Node: String-Case, Next: String Ports, Prev: Type Coercion, Up: Procedures - | -String-Case | ------------ | - | - `(require 'string-case)' | - | - - Procedure: string-upcase str | - - Procedure: string-downcase str | - - Procedure: string-capitalize str | - The obvious string conversion routines. These are non-destructive. | - | - - Function: string-upcase! str | - - Function: string-downcase! str | - - Function: string-captialize! str | - The destructive versions of the functions above. | - | - - Function: string-ci->symbol str | - Converts string STR to a symbol having the same case as if the | - symbol had been `read'. | - | - - Function: symbol-append obj1 ... | - Converts OBJ1 ... to strings, appends them, and converts to a | - symbol which is returned. Strings and numbers are converted to | - read's symbol case; the case of symbol characters is not changed. | - #f is converted to the empty string (symbol). | - | + +String-Case +----------- + +`(require 'string-case)' + + - Procedure: string-upcase str + - Procedure: string-downcase str + - Procedure: string-capitalize str + The obvious string conversion routines. These are non-destructive. + + - Function: string-upcase! str + - Function: string-downcase! str + - Function: string-capitalize! str | + The destructive versions of the functions above. + + - Function: string-ci->symbol str + Converts string STR to a symbol having the same case as if the + symbol had been `read'. + + - Function: symbol-append obj1 ... + Converts OBJ1 ... to strings, appends them, and converts to a + symbol which is returned. Strings and numbers are converted to + read's symbol case; the case of symbol characters is not changed. + #f is converted to the empty string (symbol). + + - Function: StudlyCapsExpand str delimiter + - Function: StudlyCapsExpand str + DELIMITER must be a string or character. If absent, DELIMITER + defaults to `-'. `StudlyCapsExpand' returns a copy of STR where + DELIMITER is inserted between each lower-case character + immediately followed by an upper-case character; and between two + upper-case characters immediately followed by a lower-case + character. + + (StudlyCapsExpand "aX" " ") => "a X" + (StudlyCapsExpand "aX" "..") => "a..X" + (StudlyCapsExpand "AX") => "AX" + (StudlyCapsExpand "Ax") => "Ax" + (StudlyCapsExpand "AXLE") => "AXLE" + (StudlyCapsExpand "aAXACz") => "a-AXA-Cz" + (StudlyCapsExpand "AaXACz") => "Aa-XA-Cz" + (StudlyCapsExpand "AAaXACz") => "A-Aa-XA-Cz" + (StudlyCapsExpand "AAaXAC") => "A-Aa-XAC" + + File: slib.info, Node: String Ports, Next: Line I/O, Prev: String-Case, Up: Procedures - | -String Ports | ------------- | - | - `(require 'string-port)' | - | - - Procedure: call-with-output-string proc | - PROC must be a procedure of one argument. This procedure calls | - PROC with one argument: a (newly created) output port. When the | - function returns, the string composed of the characters written | - into the port is returned. | - | - - Procedure: call-with-input-string string proc | - PROC must be a procedure of one argument. This procedure calls | - PROC with one argument: an (newly created) input port from which | - STRING's contents may be read. When PROC returns, the port is | - closed and the value yielded by the procedure PROC is returned. | - | + +String Ports +------------ + +`(require 'string-port)' + + - Procedure: call-with-output-string proc + PROC must be a procedure of one argument. This procedure calls + PROC with one argument: a (newly created) output port. When the + function returns, the string composed of the characters written + into the port is returned. + + - Procedure: call-with-input-string string proc + PROC must be a procedure of one argument. This procedure calls + PROC with one argument: an (newly created) input port from which + STRING's contents may be read. When PROC returns, the port is + closed and the value yielded by the procedure PROC is returned. + File: slib.info, Node: Line I/O, Next: Multi-Processing, Prev: String Ports, Up: Procedures - | + Line I/O -------- - `(require 'line-i/o)' +`(require 'line-i/o)' - Function: read-line - Function: read-line port @@ -9866,8 +13009,8 @@ Line I/O which case it defaults to the value returned by `current-input-port'. - - Function: read-line! string - - Function: read-line! string port + - Procedure: read-line! string | + - Procedure: read-line! string port | Fills STRING with characters up to, but not including a newline or end of file, updating the PORT to point to the last character read or following the newline if it was read. If no characters are @@ -9883,11 +13026,13 @@ Line I/O an unspecified value. The PORT argument may be omitted, in which case it defaults to the value returned by `current-input-port'. - - Function: display-file path - - Function: display-file path port - Displays the contents of the file named by PATH to PORT. The PORT - argument may be ommited, in which case it defaults to the value - returned by `current-output-port'. + - Function: system->line command tmp | + - Function: system->line command | + COMMAND must be a string. The string TMP, if supplied, is a path | + to use as a temporary file. `system->line' calls `system' with | + COMMAND as argument, redirecting stdout to file TMP. | + `system->line' returns a string containing the first line of | + output from TMP. | File: slib.info, Node: Multi-Processing, Next: Metric Units, Prev: Line I/O, Up: Procedures @@ -9895,7 +13040,7 @@ File: slib.info, Node: Multi-Processing, Next: Metric Units, Prev: Line I/O, Multi-Processing ---------------- - `(require 'process)' +`(require 'process)' This module implements asynchronous (non-polled) time-sliced multi-processing in the SCM Scheme implementation using procedures @@ -9923,7 +13068,7 @@ File: slib.info, Node: Metric Units, Prev: Multi-Processing, Up: Procedures Metric Units ------------ - `(require 'metric-units)' +`(require 'metric-units)' <http://swissnet.ai.mit.edu/~jaffer/MIXF.html> @@ -10006,7 +13151,7 @@ SI Prefixes Binary Prefixes ............... - These binary prefixes are valid only with the units B (byte) and bit. +These binary prefixes are valid only with the units B (byte) and bit. However, decimal prefixes can also be used with bit; and decimal multiple (not submultiple) prefixes can also be used with B (byte). @@ -10119,6 +13264,7 @@ Standards Support * Menu: +* RnRS:: Revised Reports on Scheme * With-File:: 'with-file * Transcripts:: 'transcript * Rev2 Procedures:: 'rev2-procedures @@ -10126,19 +13272,52 @@ Standards Support * Multi-argument / and -:: 'multiarg/and- * Multi-argument Apply:: 'multiarg-apply * Rationalize:: 'rationalize -* Promises:: 'promise +* Promises:: 'delay | * Dynamic-Wind:: 'dynamic-wind * Eval:: 'eval * Values:: 'values -* SRFI:: 'http://srfi.schemers.org/srfi-0/srfi-0.html | +* SRFI:: 'http://srfi.schemers.org/srfi-0/srfi-0.html -File: slib.info, Node: With-File, Next: Transcripts, Prev: Standards Support, Up: Standards Support +File: slib.info, Node: RnRS, Next: With-File, Prev: Standards Support, Up: Standards Support + +RnRS +---- + +The `r2rs', `r3rs', `r4rs', and `r5rs' features attempt to provide +procedures and macros to bring a Scheme implementation to the desired +version of Scheme. + + - Feature: r2rs + Requires features implementing procedures and optional procedures + specified by `Revised^2 Report on the Algorithmic Language Scheme'; + namely `rev3-procedures' and `rev2-procedures'. + + - Feature: r3rs + Requires features implementing procedures and optional procedures + specified by `Revised^3 Report on the Algorithmic Language Scheme'; + namely `rev3-procedures'. + + _Note:_ SLIB already mandates the `r3rs' procedures which can be + portably implemented in `r4rs' implementations. + + - Feature: r4rs + Requires features implementing procedures and optional procedures + specified by `Revised^4 Report on the Algorithmic Language Scheme'; + namely `rev4-optional-procedures'. + + - Feature: r5rs + Requires features implementing procedures and optional procedures + specified by `Revised^5 Report on the Algorithmic Language Scheme'; + namely `values', `macro', and `eval'. + + +File: slib.info, Node: With-File, Next: Transcripts, Prev: RnRS, Up: Standards Support With-File --------- - `(require 'with-file)' +`(require 'with-file)' - Function: with-input-from-file file thunk - Function: with-output-to-file file thunk @@ -10150,7 +13329,7 @@ File: slib.info, Node: Transcripts, Next: Rev2 Procedures, Prev: With-File, Transcripts ----------- - `(require 'transcript)' +`(require 'transcript)' - Function: transcript-on filename - Function: transcript-off filename @@ -10163,11 +13342,11 @@ File: slib.info, Node: Rev2 Procedures, Next: Rev4 Optional Procedures, Prev: Rev2 Procedures --------------- - `(require 'rev2-procedures)' +`(require 'rev2-procedures)' The procedures below were specified in the `Revised^2 Report on Scheme'. *N.B.*: The symbols `1+' and `-1+' are not `R4RS' syntax. -Scheme->C, for instance, barfs on this module. +Scheme->C, for instance, chokes on this module. - Procedure: substring-move-left! string1 start1 end1 string2 start2 - Procedure: substring-move-right! string1 start1 end1 string2 start2 @@ -10192,7 +13371,7 @@ Scheme->C, for instance, barfs on this module. - Function: string-null? str == `(= 0 (string-length STR))' - - Procedure: append! pair1 ... | + - Procedure: append! pair1 ... Destructively appends its arguments. Equivalent to `nconc'. - Function: 1+ n @@ -10215,7 +13394,7 @@ File: slib.info, Node: Rev4 Optional Procedures, Next: Multi-argument / and -, Rev4 Optional Procedures ------------------------ - `(require 'rev4-optional-procedures)' +`(require 'rev4-optional-procedures)' For the specification of these optional procedures, *Note Standard procedures: (r4rs)Standard procedures. @@ -10242,21 +13421,14 @@ File: slib.info, Node: Multi-argument / and -, Next: Multi-argument Apply, Pr Multi-argument / and - ---------------------- - `(require 'mutliarg/and-)' +`(require 'multiarg/and-)' For the specification of these optional forms, *Note Numerical -operations: (r4rs)Numerical operations. The `two-arg:'* forms are only -defined if the implementation does not support the many-argument forms. - - - Function: two-arg:/ n1 n2 - The original two-argument version of `/'. - - - Function: / dividend divisor1 ... | +operations: (r4rs)Numerical operations. | - - Function: two-arg:- n1 n2 - The original two-argument version of `-'. - - - Function: - minuend subtrahend1 ... | + - Function: / dividend divisor1 ... + | + - Function: - minuend subtrahend1 ... File: slib.info, Node: Multi-argument Apply, Next: Rationalize, Prev: Multi-argument / and -, Up: Standards Support @@ -10264,16 +13436,12 @@ File: slib.info, Node: Multi-argument Apply, Next: Rationalize, Prev: Multi-a Multi-argument Apply -------------------- - `(require 'multiarg-apply)' +`(require 'multiarg-apply)' For the specification of this optional form, *Note Control features: (r4rs)Control features. - - - Function: two-arg:apply proc l - The implementation's native `apply'. Only defined for - implementations which don't support the many-argument version. - - - Function: apply proc arg1 ... | + | + - Function: apply proc arg1 ... File: slib.info, Node: Rationalize, Next: Promises, Prev: Multi-argument Apply, Up: Standards Support @@ -10281,13 +13449,9 @@ File: slib.info, Node: Rationalize, Next: Promises, Prev: Multi-argument Appl Rationalize ----------- - `(require 'rationalize)' - - The procedure "rationalize" is interesting because most programming -languages do not provide anything analogous to it. Thanks to Alan -Bawden for contributing this algorithm. +`(require 'rationalize)' - - Function: rationalize x y + - Function: rationalize x e | Computes the correct result for exact arguments (provided the implementation supports exact rational numbers of unlimited precision); and produces a reasonable answer for inexact arguments @@ -10297,9 +13461,9 @@ Bawden for contributing this algorithm. (non-integer) rational numbers. The following procedures return a list of the numerator and denominator. - - Function: find-ratio x y + - Function: find-ratio x e | `find-ratio' returns the list of the _simplest_ numerator and - denominator whose quotient differs from X by no more than Y. + denominator whose quotient differs from X by no more than E. | (find-ratio 3/97 .0001) => (3 97) (find-ratio 3/97 .001) => (1 32) @@ -10317,14 +13481,21 @@ File: slib.info, Node: Promises, Next: Dynamic-Wind, Prev: Rationalize, Up: Promises -------- - `(require 'promise)' +`(require 'promise)' - Function: make-promise proc - Change occurrences of `(delay EXPRESSION)' to `(make-promise (lambda -() EXPRESSION))' and `(define force promise:force)' to implement -promises if your implementation doesn't support them (*note Control -features: (r4rs)Control features.). + - Function: force promise | + | + `(require 'delay)' provides `force' and `delay': | + | + - Macro: delay obj | + Change occurrences of `(delay EXPRESSION)' to | + | + (make-promise (lambda () EXPRESSION)) | + | + | + (*note Control features: (r4rs)Control features.). | File: slib.info, Node: Dynamic-Wind, Next: Eval, Prev: Promises, Up: Standards Support @@ -10332,7 +13503,7 @@ File: slib.info, Node: Dynamic-Wind, Next: Eval, Prev: Promises, Up: Standar Dynamic-Wind ------------ - `(require 'dynamic-wind)' +`(require 'dynamic-wind)' This facility is a generalization of Common LISP `unwind-protect', designed to take into account the fact that continuations produced by @@ -10362,7 +13533,7 @@ File: slib.info, Node: Eval, Next: Values, Prev: Dynamic-Wind, Up: Standards Eval ---- - `(require 'eval)' +`(require 'eval)' - Function: eval expression environment-specifier Evaluates EXPRESSION in the specified environment and returns its @@ -10441,11 +13612,11 @@ Here are some more `eval' examples: File: slib.info, Node: Values, Next: SRFI, Prev: Eval, Up: Standards Support - | + Values ------ - `(require 'values)' +`(require 'values)' - Function: values obj ... `values' takes any number of arguments, and passes (returns) them @@ -10465,178 +13636,260 @@ Values File: slib.info, Node: SRFI, Prev: Values, Up: Standards Support - | -SRFI | ----- | - | - `(require 'srfi)' | - | -Implements "Scheme Request For Implementation" (SRFI) as described at | -<http://srfi.schemers.org/> | - | -The Copyright terms of each SRFI states: | - "However, this document itself may not be modified in any way, ..." | - | -Therefore, the specification of SRFI constructs must not be quoted | -without including the complete SRFI document containing discussion and | -a sample implementation program. | - | - - Macro: cond-expand <clause1> <clause2> ... | - _Syntax:_ Each <clause> should be of the form | - | - (<feature> <expression1> ...) | - | - where <feature> is a boolean expression composed of symbols and | - `and', `or', and `not' of boolean expressions. The last <clause> | - may be an "else clause," which has the form | - | - (else <expression1> <expression2> ...). | - | - The first clause whose feature expression is satisfied is expanded. | - If no feature expression is satisfied and there is no else clause, | - an error is signaled. | - | - SLIB `cond-expand' is an extension of SRFI-0, | - <http://srfi.schemers.org/srfi-0/srfi-0.html>. | - | -* Menu: | - | -* SRFI-1:: list-processing | - | + +SRFI +---- + +`(require 'srfi)' + +Implements "Scheme Request For Implementation" (SRFI) as described at +<http://srfi.schemers.org/> + +The Copyright terms of each SRFI states: + + "However, this document itself may not be modified in any way, ..." + +Therefore, the specification of SRFI constructs must not be quoted +without including the complete SRFI document containing discussion and +a sample implementation program. + + - Macro: cond-expand <clause1> <clause2> ... + _Syntax:_ Each <clause> should be of the form + + (<feature> <expression1> ...) + + where <feature> is a boolean expression composed of symbols and + `and', `or', and `not' of boolean expressions. The last <clause> + may be an "else clause," which has the form + + (else <expression1> <expression2> ...). + + The first clause whose feature expression is satisfied is expanded. + If no feature expression is satisfied and there is no else clause, + an error is signaled. + + SLIB `cond-expand' is an extension of SRFI-0, + <http://srfi.schemers.org/srfi-0/srfi-0.html>. + +* Menu: + +* SRFI-1:: list-processing +* SRFI-2:: guarded LET* special form | +* SRFI-8:: Binding to multiple values | +* SRFI-9:: Defining Record Types | + -File: slib.info, Node: SRFI-1, Prev: SRFI, Up: SRFI - | -SRFI-1 | -...... | - | - `(require 'srfi-1)' | - | -Implements the "SRFI-1" "list-processing library" as described at | -<http://srfi.schemers.org/srfi-1/srfi-1.html> | +File: slib.info, Node: SRFI-1, Next: SRFI-2, Prev: SRFI, Up: SRFI | -Constructors | ------------- | - | - - Function: xcons d a | - `(define (xcons d a) (cons a d))'. | - | - - Function: list-tabulate len proc | - Returns a list of length LEN. Element I is `(PROC I)' for 0 <= I | - < LEN. | - | - - Function: cons* obj1 obj2 | - | - - Function: iota count start step | - - Function: iota count start | - - Function: iota count | - Returns a list of COUNT numbers: (START, START+STEP, ..., | - START+(COUNT-1)*STEP). | +SRFI-1 +...... + +`(require 'srfi-1)' + +Implements the "SRFI-1" "list-processing library" as described at +<http://srfi.schemers.org/srfi-1/srfi-1.html> + +Constructors +------------ + + - Function: xcons d a + `(define (xcons d a) (cons a d))'. + + - Function: list-tabulate len proc + Returns a list of length LEN. Element I is `(PROC I)' for 0 <= I + < LEN. + + - Function: cons* obj1 obj2 + + - Function: list-copy flist | | - - Function: circular-list obj1 obj2 ... | - Returns a circular list of OBJ1, OBJ2, .... | + - Function: iota count start step + - Function: iota count start + - Function: iota count + Returns a list of COUNT numbers: (START, START+STEP, ..., + START+(COUNT-1)*STEP). + + - Function: circular-list obj1 obj2 ... + Returns a circular list of OBJ1, OBJ2, .... + +Predicates +---------- + + - Function: proper-list? obj + + - Function: circular-list? x + + - Function: dotted-list? obj + + - Function: null-list? obj + + - Function: not-pair? obj + + - Function: list= =pred list ... + +Selectors +--------- + + - Function: first pair | -Predicates | ----------- | + - Function: second pair | | - - Function: proper-list? obj | + - Function: third pair | | - - Function: circular-list? x | + - Function: fourth pair | | - - Function: dotted-list? obj | + - Function: fifth pair | + - Function: sixth obj + - Function: seventh obj + - Function: eighth obj + - Function: ninth obj + - Function: tenth obj + + - Function: car+cdr pair | - - Function: null-list? obj | + - Function: drop lst k + - Function: take lst k | | - - Function: not-pair? obj | + - Procedure: take! lst k | + + - Function: take-right lst k + + - Function: drop-right lst k | | - - Function: list= =pred list ... | + - Procedure: drop-right! lst k | | -Selectors | ---------- | + - Function: split-at lst k + + - Procedure: split-at! lst k | | - - Function: first pair | - - Function: fifth obj | - - Function: sixth obj | - - Function: seventh obj | - - Function: eighth obj | - - Function: ninth obj | - - Function: tenth obj | + - Function: last lst + (car (last-pair lst)) + +Miscellaneous +------------- + + - Function: length+ obj + + - Function: concatenate lists + - Function: concatenate! lists + + - Procedure: reverse! lst | + + - Function: append-reverse rev-head tail + - Function: append-reverse! rev-head tail + + - Function: zip list1 list2 ... + + - Function: unzip1 lst + - Function: unzip2 lst + - Function: unzip3 lst + - Function: unzip4 lst + - Function: unzip5 lst + + - Function: count pred list1 list2 ... + +Fold and Unfold +--------------- + + - Procedure: map! f list1 clist2 ... | | - - Function: car+cdr pair | + - Function: pair-for-each f clist1 clist2 ... | | - - Function: take lst k | - - Function: drop lst k | +Filtering and Partitioning +-------------------------- + + - Function: filter pred lis | | - - Function: take-right lst k | + - Procedure: filter! pred l | | - - Function: split-at lst k | + - Function: partition pred list | | - - Function: last lst | - (car (last-pair lst)) | +Searching +--------- + + - Function: find pred list + + - Function: find-tail pred list + + - Function: remove pred l | | -Miscellaneous | -------------- | + - Procedure: remove! pred l | | - - Function: length+ obj | + - Function: any pred clist1 clist2 ... | | - - Function: concatenate lists | - - Function: concatenate! lists | + - Function: list-index pred clist1 clist2 ... | | - - Function: reverse! lst | + - Function: span pred list | | - - Function: append-reverse rev-head tail | - - Function: append-reverse! rev-head tail | + - Function: member obj list pred + - Function: member obj list + `member' returns the first sublist of LIST whose car is OBJ, where + the sublists of LIST are the non-empty lists returned by + (list-tail LIST K) for K less than the length of LIST. If OBJ + does not occur in LIST, then #f (not the empty list) is returned. + The procedure PRED is used for testing equality. If PRED is not + provided, `equal?' is used. + +Deleting +-------- + +Association lists +----------------- + + - Function: assoc obj alist pred + - Function: assoc obj alist + ALIST (for "association list") must be a list of pairs. These + procedures find the first pair in ALIST whose car field is OBJ, and + returns that pair. If no pair in ALIST has OBJ as its car, then #f + (not the empty list) is returned. The procedure PRED is used for + testing equality. If PRED is not provided, `equal?' is used. + +Set operations +-------------- + + +File: slib.info, Node: SRFI-2, Next: SRFI-8, Prev: SRFI-1, Up: SRFI | - - Function: zip list1 list2 ... | +SRFI-2 | +...... | | - - Function: unzip1 lst | - - Function: unzip2 lst | - - Function: unzip3 lst | - - Function: unzip4 lst | - - Function: unzip5 lst | +`(require 'srfi-2)' | | - - Function: count pred list1 list2 ... | + - Macro: and-let* claws body ... | + <http://srfi.schemers.org/srfi-2/srfi-2.html> | | -Fold and Unfold | ---------------- | + +File: slib.info, Node: SRFI-8, Next: SRFI-9, Prev: SRFI-2, Up: SRFI | -Filtering and Partitioning | --------------------------- | +SRFI-8 | +...... | | -Searching | ---------- | +`(require 'srfi-8)' | | - - Function: find pred list | + - Special Form: receive formals expression body ... | + <http://srfi.schemers.org/srfi-8/srfi-8.html> | | - - Function: find-tail pred list | + +File: slib.info, Node: SRFI-9, Prev: SRFI-8, Up: SRFI | - - Function: member obj list pred | - - Function: member obj list | - `member' returns the first sublist of LIST whose car is OBJ, where | - the sublists of LIST are the non-empty lists returned by | - (list-tail LIST K) for K less than the length of LIST. If OBJ | - does not occur in LIST, then #f (not the empty list) is returned. | - The procedure PRED is used for testing equality. If PRED is not | - provided, `equal?' is used. | +SRFI-9 | +...... | | -Deleting | --------- | +`(require 'srfi-9)' | | -Association lists | ------------------ | + <http://srfi.schemers.org/srfi-9/srfi-9.html> | | - - Function: assoc obj alist pred | - - Function: assoc obj alist | - ALIST (for "association list") must be a list of pairs. These | - procedures find the first pair in ALIST whose car field is OBJ, and | - returns that pair. If no pair in ALIST has OBJ as its car, then #f | - (not the empty list) is returned. The procedure PRED is used for | - testing equality. If PRED is not provided, `equal?' is used. | + - Special Form: define-record-type <type-name> (<constructor-name> | + <field-tag> ...) <predicate-name> <field spec> ... | + Where | + <field-spec> == (<field-tag> <accessor-name>) | + == (<field-tag> <accessor-name> <modifier-name>) | | -Set operations | --------------- | + `define-record-type' is a syntax wrapper for the SLIB `record' | + module. | | -File: slib.info, Node: Session Support, Next: Extra-SLIB Packages, Prev: Standards Support, Up: Other Packages +File: slib.info, Node: Session Support, Next: System Interface, Prev: Standards Support, Up: Other Packages | Session Support =============== @@ -10648,7 +13901,6 @@ Session Support * Debug:: To err is human ... * Breakpoints:: Pause execution * Trace:: 'trace -* System Interface:: 'system, 'getenv, and 'net-clients File: slib.info, Node: Repl, Next: Quick Print, Prev: Session Support, Up: Session Support @@ -10656,7 +13908,7 @@ File: slib.info, Node: Repl, Next: Quick Print, Prev: Session Support, Up: S Repl ---- - `(require 'repl)' +`(require 'repl)' Here is a read-eval-print-loop which, given an eval, evaluates forms. @@ -10691,7 +13943,7 @@ File: slib.info, Node: Quick Print, Next: Debug, Prev: Repl, Up: Session Sup Quick Print ----------- - `(require 'qp)' +`(require 'qp)' When displaying error messages and warnings, it is paramount that the output generated for circular lists and large data structures be @@ -10713,8 +13965,10 @@ much improved. is like `qpn' except that it returns its last argument. - Variable: *qp-width* - `*qp-width*' is the largest number of characters that `qp' should - use. + *QP-WIDTH* is the largest number of characters that `qp' should + use. If *QP-WIDTH* is #f, then all items will be `write'n. If + *QP-WIDTH* is 0, then all items except procedures will be + `write'n; procedures will be indicated by `#[proc]'. File: slib.info, Node: Debug, Next: Breakpoints, Prev: Quick Print, Up: Session Support @@ -10722,7 +13976,7 @@ File: slib.info, Node: Debug, Next: Breakpoints, Prev: Quick Print, Up: Sess Debug ----- - `(require 'debug)' +`(require 'debug)' Requiring `debug' automatically requires `trace' and `break'. @@ -10755,7 +14009,7 @@ File: slib.info, Node: Breakpoints, Next: Trace, Prev: Debug, Up: Session Su Breakpoints ----------- - `(require 'break)' +`(require 'break)' - Function: init-debug If your Scheme implementation does not support `break' or `abort', @@ -10814,12 +14068,12 @@ supported by your implementation, these might be more convenient to use. (set! SYMBOL (unbreakf SYMBOL)) -File: slib.info, Node: Trace, Next: System Interface, Prev: Breakpoints, Up: Session Support +File: slib.info, Node: Trace, Prev: Breakpoints, Up: Session Support Tracing ------- - `(require 'trace)' +`(require 'trace)' This feature provides three ways to monitor procedure invocations: @@ -10895,6 +14149,10 @@ supported by your implementation, these might be more convenient to use. - Function: tracef proc - Function: tracef proc name + - Function: trackf proc | + - Function: trackf proc name | + - Function: stackf proc | + - Function: stackf proc name | To trace, type (set! SYMBOL (tracef SYMBOL)) @@ -10912,10 +14170,10 @@ supported by your implementation, these might be more convenient to use. (set! SYMBOL (untracef SYMBOL)) -File: slib.info, Node: System Interface, Prev: Trace, Up: Session Support +File: slib.info, Node: System Interface, Next: Extra-SLIB Packages, Prev: Session Support, Up: Other Packages System Interface ----------------- +================ If `(provided? 'getenv)': @@ -10930,100 +14188,233 @@ If `(provided? 'system)': Executes the COMMAND-STRING on the computer and returns the integer status code. -If `system' is provided by the Scheme implementation, the "net-clients" -package provides interfaces to common network client programs like FTP, -mail, and Netscape. +* Menu: + +* Directories:: +* Transactions:: +* CVS:: - `(require 'net-clients)' + +File: slib.info, Node: Directories, Next: Transactions, Prev: System Interface, Up: System Interface - - Function: call-with-tmpnam proc - - Function: call-with-tmpnam proc k - Calls PROC with K arguments, strings returned by successive calls - to `tmpnam'. If PROC returns, then any files named by the - arguments to PROC are deleted automatically and the value(s) - yielded by the PROC is(are) returned. K may be ommited, in which - case it defaults to `1'. +Directories +----------- - - Function: user-email-address - `user-email-address' returns a string of the form - `username@hostname'. If this e-mail address cannot be obtained, - #f is returned. +`(require 'directory)' - Function: current-directory `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 `current-directory' cannot be supported by the platform, the - value of `current-directory' is #f. + If `current-directory' cannot be supported by the platform, then + #f is returned. - Function: make-directory name Creates a sub-directory NAME of the current-directory. If successful, `make-directory' returns #t; otherwise #f. - - Function: null-directory? file-name - Returns #t if changing directory to FILE-NAME makes the current - working directory the same as it is before changing directory; - otherwise returns #f. + - Function: directory-for-each proc directory + PROC must be a procedure taking one argument. + `Directory-For-Each' applies PROC to the (string) name of each + file in DIRECTORY. The dynamic order in which PROC is applied to + the filenames is unspecified. The value returned by + `directory-for-each' is unspecified. - - Function: absolute-path? file-name - Returns #t if FILE-NAME is a fully specified pathname (does not - depend on the current working directory); otherwise returns #f. + - Function: directory-for-each proc directory pred + Applies PROC only to those filenames for which the procedure PRED + returns a non-false value. - - Function: glob-pattern? str - Returns #t if the string STR contains characters used for - specifying glob patterns, namely `*', `?', or `['. + - Function: directory-for-each proc directory match + Applies PROC only to those filenames for which `(filename:match?? + MATCH)' would return a non-false value (*note Filenames: + (slib)Filenames.). - - Function: parse-ftp-address uri - Returns a list of the decoded FTP URI; or #f if indecipherable. - FTP "Uniform Resource Locator", "ange-ftp", and "getit" formats - are handled. The returned list has four elements which are - strings or #f: + (require 'directory) + (directory-for-each print "." "[A-Z]*.scm") + -| + "Bev2slib.scm" + "Template.scm" - 0. username + +File: slib.info, Node: Transactions, Next: CVS, Prev: Directories, Up: System Interface - 1. password +Transactions +------------ - 2. remote-site +If `system' is provided by the Scheme implementation, the "transact" +package provides functions for file-locking and file-replacement +transactions. - 3. remote-directory + `(require 'transact)' + | +File Locking +............ + +Unix file-locking is focussed on write permissions for segments of a +existing file. While this might be employed for (binary) database +access, it is not used for everyday contention (between users) for text +files. + +Microsoft has several file-locking protocols. Their model denies write +access to a file if any reader has it open. This is too restrictive. +Write access is denied even when the reader has reached end-of-file. +And tracking read access (which is much more common than write access) +causes havoc when remote hosts crash or disconnect. + +It is bizarre that the concept of multi-user contention for modifying +files has not been adequately addressed by either of the large +operating system development efforts. There is further irony that both +camps support contention detection and resolution only through weak +conventions of some their document editing programs. + +The "file-lock" procedures implement a transaction method for file +replacement compatible with the methods used by the GNU "emacs" text +editor on Unix systems and the Microsoft "Word" editor. + +Both protocols employ what I term a "certificate" containing the user, +hostname, time, and (on Unix) process-id. Intent to replace FILE is +indicated by adding to FILE's directory a certificate object whose name +is derived from FILE. + +The Microsoft Word certificate is contained in a 162 byte file named +for the visited FILE with a `~$' prefix. Emacs/Unix creates a symbolic +link to a certificate named for the visited FILE prefixed with `.#'. +Because Unix systems can import Microsoft file systems, these routines +maintain and check both Emacs and Word certificates. + + - Function: file-lock-owner path + Returns the string `USER@HOSTNAME' associated with the lock owner + of file PATH if locked; and #f otherwise. + + - Procedure: file-lock! path email | + - Procedure: file-lock! path | + PATH must be a string naming the file to be locked. If supplied, + EMAIL must be a string formatted as `USER@HOSTNAME'. If absent, + EMAIL defaults to the value returned by `user-email-address'. + + If PATH is already locked, then `file-lock!' returns `#f'. If + PATH is unlocked, then `file-lock!' returns the certificate string + associated with the new lock for file PATH. + + - Procedure: file-unlock! path certificate | + PATH must be a string naming the file to be unlocked. CERTIFICATE + must be the string returned by `file-lock!' for PATH. + + If PATH is locked with CERTIFICATE, then `file-unlock!' removes + the locks and returns `#t'. Otherwise, `file-unlock!' leaves the + file system unaltered and returns `#f'. + +File Transactions +................. + + - Function: emacs:backup-name path backup-style + PATH must be a string. BACKUP-STYLE must be a symbol. Depending + on BACKUP-STYLE, `emacs:backup-name' returns: + none + #f + + simple + the string "PATH~" + + numbered + the string "PATH.~N~", where N is one greater than the + highest number appearing in a filename matching "PATH.~*~". N + defauls to 1 when no filename matches. + + existing + the string "PATH.~N~" if a numbered backup already exists in + this directory; otherwise. "PATH~" + + orig + the string "PATH.orig" + + bak + the string "PATH.bak" + + - Function: transact-file-replacement proc path backup-style + certificate + - Function: transact-file-replacement proc path backup-style + - Function: transact-file-replacement proc path + PATH must be a string naming an existing file. BACKUP-STYLE is + one of the symbols none, simple, numbered, existing, orig, bak or + #f; with meanings described above; or a string naming the location + of a backup file. BACKUP-STYLE defaults to #f. If supplied, + CERTIFICATE is the certificate with which PATH is locked. + + PROC must be a procedure taking two string arguments: + * PATH, the original filename (to be read); and + + * a temporary file-name. + + If PATH is locked by other than CERTIFICATE, or if CERTIFICATE is + supplied and PATH is not locked, then `transact-file-replacement' + returns #f. If CERTIFICATE is not supplied, then, + `transact-file-replacement' creates temporary (Emacs and Word) + locks for PATH during the transaction. The lock status of PATH + will be restored before `transact-file-replacement' returns. + + `transact-file-replacement' calls PROC with PATH (which should not + be modified) and a temporary file path to be written. If PROC + returns any value other than #t, then the file named by PATH is + not altered and `transact-file-replacement' returns #f. + Otherwise, `emacs:backup-name' is called with PATH and + BACKUP-STYLE. If it returns a string, then PATH is renamed to it. + + Finally, the temporary file is renamed PATH. + `transact-file-replacement' returns #t if PATH was successfully + replaced; and #f otherwise. + +Identification +.............. - - Function: ftp-upload paths user password remote-site remote-dir - PASSWORD must be a non-empty string or #f. PATHS must be a - non-empty list of pathnames or Glob patterns (*note Filenames::) - matching files to transfer. + - Function: user-email-address + `user-email-address' returns a string of the form + `username@hostname'. If this e-mail address cannot be obtained, + #f is returned. - `ftp-upload' puts the files specified by PATHS into the REMOTE-DIR - directory of FTP REMOTE-SITE using name USER with (optional) - PASSWORD. + +File: slib.info, Node: CVS, Prev: Transactions, Up: System Interface - If PASSWORD is #f and USER is not `ftp' or `anonymous', then USER - is ignored; FTP takes the username and password from the `.netrc' - or equivalent file. +CVS +--- - - Function: path->uri path - Returns a URI-string for PATH on the local host. +`(require 'cvs)' + + - Function: cvs-files directory/ + Returns a list of the local pathnames (with prefix DIRECTORY/) of + all CVS controlled files in DIRECTORY/ and in DIRECTORY/'s + subdirectories. - - Function: browse-url-netscape url - If a `netscape' browser is running, `browse-url-netscape' causes - the browser to display the page specified by string URL and - returns #t. + - Function: cvs-directories directory/ + Returns a list of all of DIRECTORY/ and all DIRECTORY/'s CVS + controlled subdirectories. - If the browser is not running, `browse-url-netscape' runs - `netscape' with the argument URL. If the browser starts as a - background job, `browse-url-netscape' returns #t immediately; if - the browser starts as a foreground job, then `browse-url-netscape' - returns #t when the browser exits; otherwise it returns #f. + - Function: cvs-root path/ + Returns the (string) contents of PATH/CVS/Root; or `(getenv + "CVSROOT")' if Root doesn't exist. + + - Function: cvs-repository directory/ + Returns the (string) contents of DIRECTORY/CVS/Root appended with + DIRECTORY/CVS/Repository; or #f if DIRECTORY/CVS/Repository + doesn't exist. + + - Procedure: cvs-set-root! new-root directory/ | + Writes NEW-ROOT to file CVS/Root of DIRECTORY/ and all its + subdirectories. + + - Function: cvs-vet directory/ + Signals an error if CVS/Repository or CVS/Root files in DIRECTORY/ + or any subdirectory do not match. -File: slib.info, Node: Extra-SLIB Packages, Prev: Session Support, Up: Other Packages +File: slib.info, Node: Extra-SLIB Packages, Prev: System Interface, Up: Other Packages Extra-SLIB Packages =================== - Several Scheme packages have been written using SLIB. There are -several reasons why a package might not be included in the SLIB -distribution: +Several Scheme packages have been written using SLIB. There are several +reasons why a package might not be included in the SLIB distribution: * Because it requires special hardware or software which is not universal. @@ -11052,7 +14443,6 @@ SLIB-PSD ftp.cs.indiana.edu:/pub/scheme-repository/utl/slib-psd1-3.tar.gz - With PSD, you can run a Scheme program in an Emacs buffer, set breakpoints, single step evaluation and access and modify the program's variables. It works by instrumenting the original source @@ -11065,11 +14455,9 @@ SLIB-PSD 1993) is available as http://www.cs.tut.fi/staff/pk/scheme/psd/article/article.html - SCHELOG is an embedding of Prolog in Scheme. - http://www.cs.rice.edu/CS/PLT/packages/schelog/ - + http://www.ccs.neu.edu/~dorai/schelog/schelog.html JFILTER is a Scheme program which converts text among the JIS, EUC, and @@ -11085,8 +14473,8 @@ About SLIB More people than I can name have contributed to SLIB. Thanks to all of you! - SLIB 2d2, released July 2001. | - Aubrey Jaffer <agj @ alum.mit.edu> | + SLIB 3a1, released November 2003. | + Aubrey Jaffer <agj @ alum.mit.edu> Hyperactive Software - The Maniac Inside! <http://swissnet.ai.mit.edu/~jaffer/SLIB.html> @@ -11096,6 +14484,7 @@ you! * Porting:: SLIB to new platforms. * Coding Guidelines:: How to write modules for SLIB. * Copyrights:: Intellectual propery issues. +* About this manual:: | File: slib.info, Node: Installation, Next: Porting, Prev: About SLIB, Up: About SLIB @@ -11103,80 +14492,87 @@ File: slib.info, Node: Installation, Next: Porting, Prev: About SLIB, Up: Ab Installation ============ - There are four parts to installation: | - | - * Unpack the SLIB distribution. | - | - * Configure the Scheme implementation(s) to locate the SLIB | - directory. | - | - * Arrange for Scheme implementation to load its SLIB initialization | - file. | - | - * Build the SLIB catalog for the Scheme implementation. | - | -Unpacking the SLIB Distribution | -------------------------------- | - | - If the SLIB distribution is a Linux RPM, it will create the SLIB | -directory `/usr/share/slib'. | - | - If the SLIB distribution is a ZIP file, unzip the distribution to | -create the SLIB directory. Locate this `slib' directory either in your | -home directory (if only you will use this SLIB installation); or put it | -in a location where libraries reside on your system. On unix systems | -this might be `/usr/share/slib', `/usr/local/lib/slib', or | -`/usr/lib/slib'. If you know where SLIB should go on other platforms, | -please inform agj @ alum.mit.edu. | - | -Configure Scheme Implementation to Locate SLIB | ----------------------------------------------- | +There are four parts to installation: + + * Unpack the SLIB distribution. + + * Configure the Scheme implementation(s) to locate the SLIB + directory. + + * Arrange for Scheme implementation to load its SLIB initialization + file. - If the Scheme implementation supports `getenv', then the value of the + * Build the SLIB catalog for the Scheme implementation. + +Unpacking the SLIB Distribution +------------------------------- + +If the SLIB distribution is a Linux RPM, it will create the SLIB +directory `/usr/share/slib'. + + If the SLIB distribution is a ZIP file, unzip the distribution to +create the SLIB directory. Locate this `slib' directory either in your +home directory (if only you will use this SLIB installation); or put it +in a location where libraries reside on your system. On unix systems +this might be `/usr/share/slib', `/usr/local/lib/slib', or +`/usr/lib/slib'. If you know where SLIB should go on other platforms, +please inform agj @ alum.mit.edu. + +Configure Scheme Implementation to Locate SLIB +---------------------------------------------- + +If the Scheme implementation supports `getenv', then the value of the shell environment variable SCHEME_LIBRARY_PATH will be used for `(library-vicinity)' if it is defined. Currently, Chez, Elk, MITScheme, scheme->c, VSCM, and SCM support `getenv'. Scheme48 supports `getenv' but does not use it for determining `library-vicinity'. (That is done from the Makefile.) - The `(library-vicinity)' can also be specified from the SLIB | -initialization file or by implementation-specific means. | - | -Loading SLIB Initialization File | --------------------------------- | - | - Check the manifest in `README' to find a configuration file for your | -Scheme implementation. Initialization files for most IEEE P1178 | -compliant Scheme Implementations are included with this distribution. | - | + The `(library-vicinity)' can also be specified from the SLIB +initialization file or by implementation-specific means. + +Loading SLIB Initialization File +-------------------------------- + +Check the manifest in `README' to find a configuration file for your +Scheme implementation. Initialization files for most IEEE P1178 +compliant Scheme Implementations are included with this distribution. + You should check the definitions of `software-type', `scheme-implementation-version', `implementation-vicinity', and `library-vicinity' in the initialization file. There are comments in the file for how to configure it. - Once this is done, modify the startup file for your Scheme | -implementation to `load' this initialization file. | - | -Build New SLIB Catalog for Implementation | ------------------------------------------ | - | - When SLIB is first used from an implementation, a file named | -`slibcat' is written to the `implementation-vicinity' for that | -implementation. Because users may lack permission to write in | -`implementation-vicinity', it is good practice to build the new catalog | -when installing SLIB. | - | - To build (or rebuild) the catalog, start the Scheme implementation | -(with SLIB), then: | - | - (require 'new-catalog) | - | -Implementation-specific Instructions | ------------------------------------- | + Once this is done, modify the startup file for your Scheme +implementation to `load' this initialization file. + +Build New SLIB Catalog for Implementation +----------------------------------------- + +When SLIB is first used from an implementation, a file named `slibcat' +is written to the `implementation-vicinity' for that implementation. +Because users may lack permission to write in +`implementation-vicinity', it is good practice to build the new catalog +when installing SLIB. + + To build (or rebuild) the catalog, start the Scheme implementation +(with SLIB), then: + + (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 +------------------------------------ - Multiple implementations of Scheme can all use the same SLIB -directory. Simply configure each implementation's initialization file -as outlined above. +Multiple implementations of Scheme can all use the same SLIB directory. +Simply configure each implementation's initialization file as outlined +above. - Implementation: SCM The SCM implementation does not require any initialization file as @@ -11221,19 +14617,19 @@ as outlined above. - Implementation: PLT Scheme - Implementation: DrScheme - Implementation: MzScheme - The `init.ss' file in the _slibinit_ collection is an SLIB | - initialization file. | - | - 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' | - | - - Implementation: MIT Scheme | - `scheme -load ${SCHEME_LIBRARY_PATH}mitscheme.init' | + The `init.ss' file in the _slibinit_ collection is an SLIB + initialization file. + + To use SLIB in MzScheme, set the SCHEME_LIBRARY_PATH environment + variable to the installed SLIB location; then invoke MzScheme thus: - - Implementation: Guile | - `guile -l ${SCHEME_LIBRARY_PATH}guile.init' | + `mzscheme -f ${SCHEME_LIBRARY_PATH}DrScheme.init' + + - Implementation: MIT Scheme + `scheme -load ${SCHEME_LIBRARY_PATH}mitscheme.init' + + - Implementation: Guile + `guile -l ${SCHEME_LIBRARY_PATH}guile.init' File: slib.info, Node: Porting, Next: Coding Guidelines, Prev: Installation, Up: About SLIB @@ -11241,11 +14637,14 @@ File: slib.info, Node: Porting, Next: Coding Guidelines, Prev: Installation, Porting ======= - If there is no initialization file for your Scheme implementation, you +If there is no initialization file for your Scheme implementation, you will have to create one. Your Scheme implementation must be largely -compliant with `IEEE Std 1178-1990', `Revised^4 Report on the -Algorithmic Language Scheme', or `Revised^5 Report on the Algorithmic -Language Scheme' in order to support SLIB. (1) +compliant with | + `IEEE Std 1178-1990', | + `Revised^4 Report on the Algorithmic Language Scheme', or | + `Revised^5 Report on the Algorithmic Language Scheme' | + | +in order to support SLIB. (1) | `Template.scm' is an example configuration file. The comments inside will direct you on how to customize it to reflect your system. Give @@ -11257,10 +14656,11 @@ initialization file might be called `foo.init'. implementation's initialization. It will load `require.scm' from the library; this will allow the use of `provide', `provided?', and `require' along with the "vicinity" functions (these functions are -documented in the section *Note Require::). The rest of the library -will then be accessible in a system independent fashion. +documented in the sections *Note Feature:: and *Note Require::). The | +rest of the library will then be accessible in a system independent | +fashion. | - Please mail new working configuration files to `agj @ alum.mit.edu' | + Please mail new working configuration files to `agj @ alum.mit.edu' so that they can be included in the SLIB distribution. ---------- Footnotes ---------- @@ -11275,24 +14675,33 @@ File: slib.info, Node: Coding Guidelines, Next: Copyrights, Prev: Porting, U Coding Guidelines ================= - 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)' (*note Require::). +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? 'r3rs)' or `(require 'r3rs)' (*note | +Require::). | - 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)'. + If a procedure defined in a module is called by other procedures in | +that module, then those procedures should instead call an alias defined | +in that module: | - Code submitted for inclusion in SLIB should not duplicate routines -already in SLIB files. Use `require' to force those library routines -to be used by your package. Care should be taken that there are no -circularities in the `require's and `load's between the library -packages. + (define module-name:foo foo) | + | + The module name and `:' should prefix that symbol for the internal | +name. Do not export internal aliases. | + | + A procedure is exported from a module by putting Schmooz-style | +comments (*note Schmooz::) or `;@' at the beginning of the line | +immediately preceding the definition (`define', `define-syntax', or | +`defmacro'). Modules, exports and other relevant issues are discussed | +in *Note Compiling Scheme::. | + | + Code submitted for inclusion in SLIB should not duplicate (more than | +one) routines already in SLIB files. Use `require' to force those | +library routines to be used by your package. | Documentation should be provided in Emacs Texinfo format if possible, -But documentation must be provided. +but documentation must be provided. | Your package will be released sooner with SLIB if you send me a file which tests your code. Please run this test _before_ you send me the @@ -11301,7 +14710,7 @@ code! Modifications ------------- - Please document your changes. A line or two for `ChangeLog' is +Please document your changes. A line or two for `ChangeLog' is sufficient for simple fixes or extensions. Look at the format of `ChangeLog' to see what information is desired. Please send me `diff' files from the latest SLIB distribution (remember to send `diff's of @@ -11320,12 +14729,12 @@ not have the time to fish through 10000 diffs to find your 10 real fixes. -File: slib.info, Node: Copyrights, Prev: Coding Guidelines, Up: About SLIB - +File: slib.info, Node: Copyrights, Next: About this manual, Prev: Coding Guidelines, Up: About SLIB + | Copyrights ========== - This section has instructions for SLIB authors regarding copyrights. +This section has instructions for SLIB authors regarding copyrights. Each package in SLIB must either be in the public domain, or come with a statement of terms permitting users to copy, redistribute and @@ -11338,40 +14747,39 @@ need to add your copyright or send a disclaimer. Putting code into the Public Domain ----------------------------------- - In order to put code in the public domain you should sign a copyright -disclaimer and send it to the SLIB maintainer. Contact agj @ | -alum.mit.edu for the address to mail the disclaimer to. | +In order to put code in the public domain you should sign a copyright +disclaimer and send it to the SLIB maintainer. Contact agj @ +alum.mit.edu for the address to mail the disclaimer to. - I, NAME, hereby affirm that I have placed the software package - NAME in the public domain. + I, <MY-NAME>, hereby affirm that I have placed the software + package <NAME> in the public domain. I affirm that I am the sole author and sole copyright holder for the software package, that I have the right to place this software package in the public domain, and that I will do nothing to undermine this status in the future. - SIGNATURE AND DATE This wording assumes that you are the sole author. If you are not the -sole author, the wording needs to be different. If you don't want to be -bothered with sending a letter every time you release or modify a +sole author, the wording needs to be different. If you don't want to +be bothered with sending a letter every time you release or modify a module, make your letter say that it also applies to your future revisions of that module. Make sure no employer has any claim to the copyright on the work you are submitting. If there is any doubt, create a copyright disclaimer and have your employer sign it. Mail the signed disclaimer to the SLIB -maintainer. Contact agj @ alum.mit.edu for the address to mail the | +maintainer. Contact agj @ alum.mit.edu for the address to mail the disclaimer to. An example disclaimer follows. Explicit copying terms ---------------------- -If you submit more than about 10 lines of code which you are not placing -into the Public Domain (by sending me a disclaimer) you need to: +If you submit more than about 10 lines of code which you are not +placing into the Public Domain (by sending me a disclaimer) you need to: * Arrange that your name appears in a copyright line for the - appropriate year. Multiple copyright lines are acceptable. + appropriate year. Multiple copyright lines are acceptable. * With your copyright line, specify any terms you require to be different from those already in the file. @@ -11379,34 +14787,50 @@ into the Public Domain (by sending me a disclaimer) you need to: * Make sure no employer has any claim to the copyright on the work you are submitting. If there is any doubt, create a copyright disclaimer and have your employer sign it. Mail the signed - disclaim to the SLIB maintainer. Contact agj @ alum.mit.edu for | + disclaim to the SLIB maintainer. Contact agj @ alum.mit.edu for the address to mail the disclaimer to. Example: Company Copyright Disclaimer ------------------------------------- - This disclaimer should be signed by a vice president or general -manager of the company. If you can't get at them, anyone else -authorized to license out software produced there will do. Here is a -sample wording: +This disclaimer should be signed by a vice president or general manager +of the company. If you can't get at them, anyone else authorized to +license out software produced there will do. Here is a sample wording: - EMPLOYER Corporation hereby disclaims all copyright interest in - the program PROGRAM written by NAME. + <EMPLOYER> Corporation hereby disclaims all copyright interest in + the program <PROGRAM> written by <NAME>. - EMPLOYER Corporation affirms that it has no other intellectual + <EMPLOYER> Corporation affirms that it has no other intellectual property interest that would undermine this release, and will do nothing to undermine it in the future. - SIGNATURE AND DATE, - NAME, TITLE, EMPLOYER Corporation + <SIGNATURE AND DATE>, + <NAME>, <TITLE>, <EMPLOYER> Corporation +File: slib.info, Node: About this manual, Prev: Copyrights, Up: About SLIB + | +About this manual | +================= | + | + * Entries that are labeled as Functions are called for their return | + values. Entries that are labeled as Procedures are called | + primarily for their side effects. | + | + * Examples in this text were produced using the `scm' Scheme | + implementation. | + | + * At the beginning of each section, there is a line that looks like | + `(require 'feature)'. Include this line in your code prior to | + using the package. | + | + File: slib.info, Node: Index, Prev: About SLIB, Up: Top - + | Procedure and Macro Index ************************* - This is an alphabetical list of all the procedures and macros in SLIB. +This is an alphabetical list of all the procedures and macros in SLIB. * Menu: @@ -11416,46 +14840,67 @@ Procedure and Macro Index * 1+: Rev2 Procedures. * <=?: Rev2 Procedures. * <?: Rev2 Procedures. +* =: Bit-Twiddling. * =?: Rev2 Procedures. * >=?: Rev2 Procedures. * >?: Rev2 Procedures. -* absolute-path?: System Interface. -* add-domain: Database Utilities. +* absolute-path?: URI. +* absolute-uri?: URI. +* ac32: Arrays. +* ac64: Arrays. +* add-command-tables: Database Extension. +* add-domain: Using Databases. | +* add-domain on relational-database: Command Intrinsics. | * add-process!: Multi-Processing. * add-setter: Setters. * adjoin: Lists as sets. -* adjoin-parameters!: Parameter lists. -* alarm: Multi-Processing. -* alarm-interrupt: Multi-Processing. +* adjoin-parameters!: Parameter lists. | * alist->wt-tree: Construction of Weight-Balanced Trees. * alist-associator: Association Lists. * alist-for-each: Association Lists. * alist-inquirer: Association Lists. * alist-map: Association Lists. * alist-remover: Association Lists. +* alist-table: The Base. | +* and-let*: SRFI-2. | * and?: Non-List functions. +* any: SRFI-1. | * any?: Collections. * append!: Rev2 Procedures. -* append-reverse: SRFI-1. | -* append-reverse!: SRFI-1. | -* apply: Multi-argument Apply. | +* append-reverse: SRFI-1. +* append-reverse!: SRFI-1. +* apply: Multi-argument Apply. +* ar32: Arrays. +* ar64: Arrays. +* array-align: Subarrays. * array-copy!: Array Mapping. * array-dimensions: Arrays. * array-for-each: Array Mapping. * array-in-bounds?: Arrays. * array-index-map!: Array Mapping. * array-indexes: Array Mapping. +* array-map: Array Mapping. | * array-map!: Array Mapping. * array-rank: Arrays. * array-ref: Arrays. * array-set!: Arrays. * array-shape: Arrays. -* array=?: Arrays. | +* array-trim: Subarrays. +* array=?: Arrays. * array?: Arrays. +* as16: Arrays. +* as32: Arrays. +* as64: Arrays. +* as8: Arrays. * asctime: Posix Time. * ash: Bit-Twiddling. -* assoc: SRFI-1. | +* assoc: SRFI-1. +* at1: Arrays. * atom?: Non-List functions. +* au16: Arrays. +* au32: Arrays. +* au64: Arrays. +* au8: Arrays. * batch:call-with-output-script: Batch. * batch:command: Batch. * batch:comment: Batch. @@ -11465,32 +14910,47 @@ Procedure and Macro Index * batch:rename-file: Batch. * batch:run-script: Batch. * batch:try-chopped-command: Batch. -* batch:try-command: Batch. -* bit-extract: Bit-Twiddling. +* batch:try-command: Batch. | * bit-field: Bit-Twiddling. +* bit-reverse: Bit-Twiddling. * bitwise-if: Bit-Twiddling. +* bitwise:delaminate: Bit-Twiddling. +* bitwise:laminate: Bit-Twiddling. +* blackbody-spectrum: Spectra. +* booleans->integer: Bit-Twiddling. * break: Breakpoints. * break-all: Debug. * breakf: Breakpoints. * breakpoint: Breakpoints. * browse: Database Browser. -* browse-url-netscape: System Interface. +* browse-url: System. * butlast: Lists as sequences. * butnthcdr: Lists as sequences. * byte-ref: Byte. * byte-set!: Byte. * bytes: Byte. +* bytes->ieee-double: Byte/Number Conversions. | +* bytes->ieee-float: Byte/Number Conversions. | +* bytes->integer: Byte/Number Conversions. | * bytes->list: Byte. +* bytes-copy: Byte. | * bytes-length: Byte. +* bytes-reverse: Byte. | +* bytes-reverse!: Byte. | * call-with-dynamic-binding: Dynamic Data Type. * call-with-input-string: String Ports. +* call-with-open-ports: Input/Output. * call-with-output-string: String Ports. -* call-with-tmpnam: System Interface. +* call-with-tmpnam: Filenames. | * call-with-values: Values. * capture-syntactic-environment: Syntactic Closures. -* car+cdr: SRFI-1. | -* cart-prod-tables: Relational Database Operations. +* car+cdr: SRFI-1. +* cart-prod-tables on relational-database: Database Operations. | * catalog->html: HTML Tables. +* catalog-id on base-table: Base Tables. | +* catalog:read: Catalog Vicinities. | +* cdna:base-count: NCBI-DNA. +* cdna:report-base-count: NCBI-DNA. * cgi:serve-query: HTTP and CGI. * chap:next-string: Chapter Ordering. * chap:string<=?: Chapter Ordering. @@ -11498,136 +14958,241 @@ Procedure and Macro Index * chap:string>=?: Chapter Ordering. * chap:string>?: Chapter Ordering. * check-parameters: Parameter lists. -* circular-list: SRFI-1. | -* circular-list?: SRFI-1. | -* close-base: Base Table. -* close-database: Relational Database Operations. -* close-table: Table Operations. +* chromaticity->CIEXYZ: Spectra. +* chromaticity->whitepoint: Spectra. +* CIE:DE*: Color Difference Metrics. +* CIE:DE*94: Color Difference Metrics. +* ciexyz->color: Color Spaces. +* CIEXYZ->e-sRGB: Color Conversions. +* CIEXYZ->L*a*b*: Color Conversions. +* CIEXYZ->L*u*v*: Color Conversions. +* CIEXYZ->RGB709: Color Conversions. +* CIEXYZ->sRGB: Color Conversions. +* CIEXYZ->xRGB: Color Conversions. | +* circular-list: SRFI-1. +* circular-list?: SRFI-1. +* cksum: Cyclic Checksum. | +* clear-sky-color-xyy: Daylight. +* clip-to-rect: Rectangles. | +* close-base on base-table: The Base. | +* close-database: Using Databases. +* close-database on relational-database: Database Operations. | +* close-port: Input/Output. +* close-table on relational-table: Table Administration. | +* CMC-DE: Color Difference Metrics. | +* CMC:DE*: Color Difference Metrics. +* codons<-cdna: NCBI-DNA. * coerce: Type Coercion. * collection?: Collections. +* color->ciexyz: Color Spaces. +* color->e-srgb: Color Spaces. +* color->l*a*b*: Color Spaces. +* color->l*c*h: Color Spaces. +* color->l*u*v*: Color Spaces. +* color->rgb709: Color Spaces. +* color->srgb: Color Spaces. +* color->string: Color Data-Type. +* color->xrgb: Color Spaces. +* color-dictionaries->lookup: Color Names. +* color-dictionary: Color Names. +* color-name->color: Color Names. +* color-name:canonicalize: Color Names. +* color-precision: Color Data-Type. +* color-space: Color Data-Type. +* color-white-point: Color Data-Type. +* color:ciexyz: Color Spaces. +* color:e-srgb: Color Spaces. +* color:l*a*b*: Color Spaces. +* color:l*c*h: Color Spaces. +* color:l*u*v*: Color Spaces. +* color:linear-transform: Color Conversions. | +* color:rgb709: Color Spaces. +* color:srgb: Color Spaces. +* color?: Color Data-Type. +* column-domains on relational-table: Table Administration. | +* column-foreigns on relational-table: Table Administration. | +* column-names on relational-table: Table Administration. | +* column-range: Column Ranges. | +* column-types on relational-table: Table Administration. | +* combine-ranges: Column Ranges. | * combined-rulesets: Commutative Rings. * command->p-specs: HTML. * command:make-editable-table: HTML Tables. * command:modify-table: HTML Tables. -* concatenate: SRFI-1. | -* concatenate!: SRFI-1. | -* cond-expand: SRFI. | -* cons*: SRFI-1. | +* concatenate: SRFI-1. +* concatenate!: SRFI-1. +* cond-expand: SRFI. +* cons*: SRFI-1. * continue: Breakpoints. +* convert-color: Color Data-Type. * copy-bit: Bit-Twiddling. * copy-bit-field: Bit-Twiddling. * copy-list: List construction. -* copy-random-state: Random Numbers. +* copy-random-state: Exact Random Numbers. | * copy-tree: Tree Operations. -* count: SRFI-1. | -* create-database <1>: Database Utilities. -* create-database: Creating and Opening Relational Databases. -* create-report: Database Reports. -* create-table: Relational Database Operations. -* create-view: Relational Database Operations. +* count: SRFI-1. +* count-newlines: String Search. | +* crc16: Cyclic Checksum. +* crc5: Cyclic Checksum. +* crc:make-table: Cyclic Checksum. +* create-array: Arrays. | +* create-database: Using Databases. +* create-database on relational-system: Relational Database Objects. | +* create-postscript-graph: PostScript Graphing. | +* create-table on relational-database: Database Operations. | +* create-view on relational-database: Database Operations. | * cring:define-rule: Commutative Rings. * ctime: Posix Time. -* current-directory: System Interface. +* current-directory: Directories. * current-error-port: Input/Output. * current-input-port <1>: Byte. * current-input-port: Ruleset Definition and Use. * current-output-port: Byte. * current-time: Time and Date. +* cvs-directories: CVS. +* cvs-files: CVS. +* cvs-repository: CVS. +* cvs-root: CVS. +* cvs-set-root!: CVS. +* cvs-vet: CVS. * db->html-directory: HTML Tables. * db->html-files: HTML Tables. * db->netscape: HTML Tables. * decode-universal-time: Common-Lisp Time. +* define-*commands*: Database Extension. * define-access-operation: Setters. +* define-command: Database Macros. +* define-domains: Using Databases. | * define-operation: Yasos interface. -* define-predicate: Yasos interface. | +* define-predicate: Yasos interface. +* define-record-type: SRFI-9. | +* define-structure: Syntax-Case Macros. | * define-syntax: Macro by Example. -* define-tables: Database Utilities. +* define-table: Database Macros. +* define-tables: Using Databases. * defmacro: Defmacro. * defmacro:eval: Defmacro. * defmacro:expand*: Defmacro. * defmacro:load: Defmacro. * defmacro?: Defmacro. -* delete <1>: Destructive list operations. -* delete: Base Table. -* delete*: Base Table. -* delete-domain: Database Utilities. +* delay: Promises. | +* delete: Destructive list operations. | +* delete on base-table: Base Record Operations. | +* delete* on base-table: Aggregate Base Operations. | +* delete-domain on relational-database: Command Intrinsics. | * delete-file: Input/Output. * delete-if: Destructive list operations. * delete-if-not: Destructive list operations. -* delete-table: Relational Database Operations. +* delete-table on relational-database: Database Operations. | * dequeue!: Queues. -* determinant: Determinant. -* diff:edit-length: Sequence Comparison. | -* diff:edits: Sequence Comparison. | -* diff:longest-common-subsequence: Sequence Comparison. | +* dequeue-all!: Queues. +* determinant: Matrix Algebra. +* diff:edit-length: Sequence Comparison. +* diff:edits: Sequence Comparison. +* diff:longest-common-subsequence: Sequence Comparison. * difftime: Time and Date. -* display-file: Line I/O. +* directory-for-each: Directories. | * do-elts: Collections. * do-keys: Collections. -* domain-checker: Database Utilities. -* dotted-list?: SRFI-1. | -* drop: SRFI-1. | +* domain-checker on relational-database: Command Intrinsics. | +* dotted-list?: SRFI-1. +* drop: SRFI-1. +* drop-right: SRFI-1. | +* drop-right!: SRFI-1. | * dynamic-ref: Dynamic Data Type. * dynamic-set!: Dynamic Data Type. * dynamic-wind: Dynamic-Wind. * dynamic?: Dynamic Data Type. -* eighth: SRFI-1. | +* e-sRGB->CIEXYZ: Color Conversions. +* e-srgb->color: Color Spaces. +* e-sRGB->e-sRGB: Color Conversions. +* e-sRGB->sRGB: Color Conversions. +* eighth: SRFI-1. +* emacs:backup-name: Transactions. * empty?: Collections. * encode-universal-time: Common-Lisp Time. -* enquque!: Queues. +* enqueue!: Queues. * equal?: Byte. * eval: Eval. * every: Lists as sets. * every?: Collections. +* exports<-info-index: Top-level Variable References. | * extended-euclid: Modular Arithmetic. * factor: Prime Numbers. +* feature->export-alist: Module Manifests. | +* feature->exports: Module Manifests. | +* feature->requires: Module Manifests. | +* feature-eval: Feature. | * fft: Fast Fourier Transform. * fft-1: Fast Fourier Transform. -* fifth: SRFI-1. | +* fifth: SRFI-1. +* file->color-dictionary: Color Names. +* file->definitions: Module Manifests. | +* file->exports: Module Manifests. | +* file->loads: Module Manifests. | +* file->requires: Module Manifests. | * file-exists?: Input/Output. +* file-lock!: Transactions. +* file-lock-owner: Transactions. +* file-unlock!: Transactions. | * filename:match-ci??: Filenames. * filename:match??: Filenames. * filename:substitute-ci??: Filenames. * filename:substitute??: Filenames. * fill-empty-parameters: Parameter lists. -* find: SRFI-1. | +* fill-rect: Rectangles. | +* filter: SRFI-1. | +* filter!: SRFI-1. | +* find: SRFI-1. * find-if: Lists as sets. * find-ratio: Rationalize. * find-ratio-between: Rationalize. * find-string-from-port?: String Search. -* find-tail: SRFI-1. | -* first: SRFI-1. | +* find-tail: SRFI-1. +* first: SRFI-1. * fluid-let: Fluid-Let. * for-each-elt: Collections. -* for-each-key <1>: Collections. -* for-each-key: Base Table. -* for-each-row: Table Operations. +* for-each-key: Collections. | +* for-each-key on base-table: Aggregate Base Operations. | +* for-each-row on relational-table: Multi-Row Operations. | +* for-each-row-in-order on relational-table: Sequential Index Operations. | +* force: Promises. | * force-output: Input/Output. * form:delimited: HTML. * form:element: HTML. * form:image: HTML. * form:reset: HTML. * form:submit: HTML. -* format: Format Interface. +* fourth: SRFI-1. | * fprintf: Standard Formatted Output. * fscanf: Standard Formatted Input. -* ftp-upload: System Interface. +* gen-elts: Collections. | +* gen-keys: Collections. | * generic-write: Generic-Write. * gentemp: Defmacro. -* get: Table Operations. -* get*: Table Operations. +* get on relational-table: Table Operations. | +* get* on relational-table: Match-Keys. | * get-decoded-time: Common-Lisp Time. +* get-foreign-choices: HTML. | * get-method: Object. * get-universal-time: Common-Lisp Time. * getenv: System Interface. * getopt: Getopt. -* getopt--: Getopt. +* getopt--: Getopt. | * getopt->arglist: Getopt Parameter lists. * getopt->parameter-list: Getopt Parameter lists. -* glob-pattern?: System Interface. +* glob-pattern?: URI. * gmktime: Posix Time. * gmtime: Posix Time. * golden-section-search: Minimizing. +* gray-code->integer: Bit-Twiddling. +* gray-code<=?: Bit-Twiddling. +* gray-code<?: Bit-Twiddling. +* gray-code>=?: Bit-Twiddling. +* gray-code>?: Bit-Twiddling. +* grey: Color Names. +* grid-horizontals: Legending. | +* grid-verticals: Legending. | * gtime: Posix Time. * has-duplicates?: Lists as sets. * hash: Hashing. @@ -11635,13 +15200,18 @@ Procedure and Macro Index * hash-for-each: Hash Tables. * hash-inquirer: Hash Tables. * hash-map: Hash Tables. +* hash-rehasher: Hash Tables. | * hash-remover: Hash Tables. * hashq: Hashing. * hashv: Hashing. * heap-extract-max!: Priority Queues. * heap-insert!: Priority Queues. * heap-length: Priority Queues. +* hilbert-coordinates->integer: Peano-Hilbert Space-Filling Curve. +* histograph: Character Plotting. | * home-vicinity: Vicinity. +* htm-fields: Parsing HTML. +* html-for-each: Parsing HTML. * html:anchor: URI. * html:atval: HTML. * html:base: URI. @@ -11650,6 +15220,7 @@ Procedure and Macro Index * html:caption: HTML Tables. * html:checkbox: HTML. * html:comment: HTML. +* html:delimited-list: HTML. | * html:editable-row-converter: HTML Tables. * html:form: HTML. * html:head: HTML. @@ -11664,6 +15235,7 @@ Procedure and Macro Index * html:meta-refresh: HTML. * html:plain: HTML. * html:pre: HTML. +* html:read-title: Parsing HTML. * html:select: HTML. * html:table: HTML Tables. * html:text: HTML. @@ -11675,40 +15247,77 @@ Procedure and Macro Index * http:serve-query: HTTP and CGI. * identifier=?: Syntactic Closures. * identifier?: Syntactic Closures. -* identity: Legacy. +* identity: Miscellany. +* ieee-byte-collate: Byte/Number Conversions. | +* ieee-byte-collate!: Byte/Number Conversions. | +* ieee-byte-decollate: Byte/Number Conversions. | +* ieee-byte-decollate!: Byte/Number Conversions. | +* ieee-double->bytes: Byte/Number Conversions. | +* ieee-float->bytes: Byte/Number Conversions. | * implementation-vicinity: Vicinity. +* in-graphic-context: Graphics Context. | * in-vicinity: Vicinity. * init-debug: Breakpoints. +* integer->bytes: Byte/Number Conversions. | +* integer->gray-code: Bit-Twiddling. +* integer->hilbert-coordinates: Peano-Hilbert Space-Filling Curve. +* integer->list: Bit-Twiddling. +* integer-byte-collate: Byte/Number Conversions. | +* integer-byte-collate!: Byte/Number Conversions. | * integer-expt: Bit-Twiddling. * integer-length: Bit-Twiddling. * integer-sqrt: Root Finding. * interaction-environment: Eval. +* interpolate-from-table: Database Interpolation. | * intersection: Lists as sets. -* iota: SRFI-1. | +* iota: SRFI-1. +* isam-next on relational-table: Sequential Index Operations. | +* isam-prev on relational-table: Sequential Index Operations. | * jacobi-symbol: Prime Numbers. * kill-process!: Multi-Processing. -* kill-table: Base Table. +* kill-table on base-table: Base Tables. | +* L*a*b*->CIEXYZ: Color Conversions. +* l*a*b*->color: Color Spaces. +* L*a*b*->L*C*h: Color Conversions. +* L*a*b*:DE*: Color Difference Metrics. | +* l*c*h->color: Color Spaces. +* L*C*h->L*a*b*: Color Conversions. +* L*C*h:DE*94: Color Difference Metrics. | +* L*u*v*->CIEXYZ: Color Conversions. +* l*u*v*->color: Color Spaces. * laguerre:find-polynomial-root: Root Finding. * laguerre:find-root: Root Finding. -* last <1>: SRFI-1. | +* last <1>: SRFI-1. * last: Lists as sequences. -* last-pair: Legacy. -* length+: SRFI-1. | +* last-pair: Miscellany. +* length+: SRFI-1. * library-vicinity: Vicinity. +* light:ambient: Solid Modeling. +* light:beam: Solid Modeling. +* light:directional: Solid Modeling. +* light:point: Solid Modeling. +* light:spot: Solid Modeling. * list*: List construction. * list->bytes: Byte. +* list->integer: Bit-Twiddling. * list->string: Rev4 Optional Procedures. * list->vector: Rev4 Optional Procedures. +* list-copy: SRFI-1. | +* list-index: SRFI-1. | * list-of??: Lists as sets. -* list-table-definition: Database Utilities. -* list-tabulate: SRFI-1. | +* list-table-definition: Using Databases. +* list-tabulate: SRFI-1. * list-tail: Rev4 Optional Procedures. -* list=: SRFI-1. | -* load-option: Weight-Balanced Trees. +* list=: SRFI-1. +* load->path: Module Manifests. | +* load-ciexyz: Spectra. | +* load-color-dictionary: Color Names. | * localtime: Posix Time. * logand: Bit-Twiddling. * logbit?: Bit-Twiddling. * logcount: Bit-Twiddling. +* logical:ones: Bit-Twiddling. | +* logical:rotate: Bit-Twiddling. * logior: Bit-Twiddling. * lognot: Bit-Twiddling. * logtest: Bit-Twiddling. @@ -11729,103 +15338,135 @@ Procedure and Macro Index * macroexpand-1: Defmacro. * macwork:eval: Macros That Work. * macwork:expand: Macros That Work. -* macwork:load: Macros That Work. | -* make-array: Arrays. -* make-base: Base Table. +* macwork:load: Macros That Work. +* make-base on base-table: The Base. | * make-bytes: Byte. -* make-command-server: Database Utilities. -* make-directory: System Interface. +* make-color: Color Data-Type. +* make-command-server: Command Service. +* make-directory: Directories. * make-dynamic: Dynamic Data Type. +* make-exchanger: Miscellany. * make-generic-method: Object. * make-generic-predicate: Object. -* make-getter: Base Table. +* make-getter on base-table: Base Record Operations. | +* make-getter-1 on base-table: Base Record Operations. | * make-hash-table: Hash Tables. * make-heap: Priority Queues. -* make-key->list: Base Table. -* make-key-extractor: Base Table. -* make-keyifier-1: Base Table. +* make-key->list on base-table: Composite Keys. | +* make-key-extractor on base-table: Composite Keys. | +* make-keyifier-1 on base-table: Composite Keys. | * make-list: List construction. -* make-list-keyifier: Base Table. +* make-list-keyifier on base-table: Composite Keys. | * make-method!: Object. +* make-nexter on base-table: Base ISAM Operations. | * make-object: Object. * make-parameter-list: Parameter lists. -* make-port-crc: Cyclic Checksum. * make-predicate!: Object. +* make-prever on base-table: Base ISAM Operations. | * make-promise: Promises. -* make-putter: Base Table. +* make-putter on base-table: Base Record Operations. | * make-query-alist-command-server: HTTP and CGI. * make-queue: Queues. -* make-random-state: Random Numbers. +* make-random-state: Exact Random Numbers. | * make-record-type: Records. -* make-relational-system: Creating and Opening Relational Databases. +* make-relational-system: Relational Database Objects. * make-ruleset: Commutative Rings. * make-shared-array: Arrays. -* make-sierpinski-indexer: Hashing. +* make-sierpinski-indexer: Sierpinski Curve. +* make-slib-color-name-db: Color Names. * make-syntactic-closure: Syntactic Closures. -* make-table: Base Table. +* make-table on base-table: Base Tables. | * make-uri: URI. * make-vicinity: Vicinity. * make-wt-tree: Construction of Weight-Balanced Trees. * make-wt-tree-type: Construction of Weight-Balanced Trees. +* map!: SRFI-1. | * map-elts: Collections. -* map-key: Base Table. +* map-key on base-table: Aggregate Base Operations. | * map-keys: Collections. -* member: SRFI-1. | +* matfile:load: MAT-File Format. +* matfile:read: MAT-File Format. +* matrix->array: Matrix Algebra. +* matrix->lists: Matrix Algebra. +* matrix:inverse: Matrix Algebra. +* matrix:product: Matrix Algebra. +* mdbm:report: Using Databases. +* member: SRFI-1. * member-if: Lists as sets. * merge: Sorting. * merge!: Sorting. * mktime: Posix Time. -* modular:: Modular Arithmetic. +* mod: Modular Arithmetic. | * modular:*: Modular Arithmetic. * modular:+: Modular Arithmetic. +* modular:-: Modular Arithmetic. | * modular:expt: Modular Arithmetic. * modular:invert: Modular Arithmetic. * modular:invertable?: Modular Arithmetic. * modular:negate: Modular Arithmetic. * modular:normalize: Modular Arithmetic. * modulus->integer: Modular Arithmetic. +* mrna<-cdna: NCBI-DNA. * must-be-first: Batch. * must-be-last: Batch. +* ncbi:read-dna-sequence: NCBI-DNA. +* ncbi:read-file: NCBI-DNA. * nconc: Destructive list operations. +* newton:find-integer-root: Root Finding. * newton:find-root: Root Finding. -* newtown:find-integer-root: Root Finding. -* ninth: SRFI-1. | -* not-pair?: SRFI-1. | +* ninth: SRFI-1. +* not-pair?: SRFI-1. * notany: Lists as sets. * notevery: Lists as sets. * nreverse: Destructive list operations. * nthcdr: Lists as sequences. -* null-directory?: System Interface. +* null-directory?: URI. * null-environment: Eval. -* null-list?: SRFI-1. | +* null-list?: SRFI-1. * object: Yasos interface. * object->limited-string: Object-To-String. * object->string: Object-To-String. * object-with-ancestors: Yasos interface. * object?: Object. * offset-time: Time and Date. -* open-base: Base Table. -* open-database <1>: Database Utilities. -* open-database: Creating and Opening Relational Databases. -* open-database!: Database Utilities. -* open-table <1>: Relational Database Operations. -* open-table: Base Table. +* open-base on base-table: The Base. | +* open-command-database: Database Extension. +* open-command-database!: Database Extension. | +* open-database: Using Databases. +* open-database on relational-system: Relational Database Objects. | +* open-database!: Using Databases. +* open-file <1>: Byte. | +* open-file: Input/Output. +* open-table: Using Databases. | +* open-table on base-table: Base Tables. | +* open-table on relational-database: Database Operations. | +* open-table!: Using Databases. | * operate-as: Yasos interface. * or?: Non-List functions. -* ordered-for-each-key: Base Table. +* ordered-for-each-key on base-table: Base ISAM Operations. | * os->batch-dialect: Batch. +* outline-rect: Rectangles. | * output-port-height: Input/Output. * output-port-width: Input/Output. +* overcast-sky-color-xyy: Daylight. +* p<-cdna: NCBI-DNA. +* pad-range: Column Ranges. | +* pair-for-each: SRFI-1. | * parameter-list->arglist: Parameter lists. * parameter-list-expand: Parameter lists. * parameter-list-ref: Parameter lists. -* parse-ftp-address: System Interface. -* path->uri: System Interface. -* plot!: Plotting. -* plot-function!: Plotting. +* parse-ftp-address: URI. +* partition: SRFI-1. | +* partition-page: Rectangles. | +* path->uri: URI. +* pathname->vicinity: Vicinity. +* plot <1>: Legacy Plotting. | +* plot: Character Plotting. | +* plot-column: Drawing the Graph. | * pnm:array-write: Portable Image Files. * pnm:image-file->array: Portable Image Files. * pnm:type-dimensions: Portable Image Files. +* port?: Input/Output. * position: Lists as sequences. * pprint-file: Pretty-Print. * pprint-filter-file: Pretty-Print. @@ -11846,9 +15487,10 @@ Procedure and Macro Index * predicate->asso: Association Lists. * predicate->hash: Hash Tables. * predicate->hash-asso: Hash Tables. -* present?: Base Table. +* present? on base-table: Base Record Operations. | * pretty-print: Pretty-Print. * pretty-print->string: Pretty-Print. +* primary-limit on relational-table: Table Administration. | * prime?: Prime Numbers. * primes<: Prime Numbers. * primes>: Prime Numbers. @@ -11857,11 +15499,10 @@ Procedure and Macro Index * printf: Standard Formatted Output. * process:schedule!: Multi-Processing. * program-vicinity: Vicinity. -* project-table: Relational Database Operations. -* proper-list?: SRFI-1. | -* provide <1>: Require. -* provide: Feature. -* provided? <1>: Require. +* project-table on relational-database: Database Operations. | +* proper-list?: SRFI-1. +* protein<-cdna: NCBI-DNA. | +* provide: Feature. | * provided?: Feature. * qp: Quick Print. * qpn: Quick Print. @@ -11872,19 +15513,21 @@ Procedure and Macro Index * queue-push!: Queues. * queue-rear: Queues. * queue?: Queues. -* random: Random Numbers. -* random:exp: Random Numbers. -* random:hollow-sphere!: Random Numbers. -* random:normal: Random Numbers. -* random:normal-vector!: Random Numbers. -* random:solid-sphere!: Random Numbers. -* random:uniform: Random Numbers. +* random: Exact Random Numbers. | +* random:exp: Inexact Random Numbers. | +* random:hollow-sphere!: Inexact Random Numbers. | +* random:normal: Inexact Random Numbers. | +* random:normal-vector!: Inexact Random Numbers. | +* random:solid-sphere!: Inexact Random Numbers. | +* random:uniform: Inexact Random Numbers. | * rationalize: Rationalize. * read-byte: Byte. +* read-bytes: Byte. | * read-command: Command Line. * read-line: Line I/O. * read-line!: Line I/O. * read-options-file: Command Line. +* receive: SRFI-8. | * record-accessor: Records. * record-constructor: Records. * record-modifier: Records. @@ -11892,7 +15535,10 @@ Procedure and Macro Index * reduce <1>: Lists as sequences. * reduce: Collections. * reduce-init: Lists as sequences. +* rem: Modular Arithmetic. +* remove <1>: SRFI-1. | * remove: Lists as sets. +* remove!: SRFI-1. | * remove-duplicates: Lists as sets. * remove-if: Lists as sets. * remove-if-not: Lists as sets. @@ -11901,64 +15547,119 @@ Procedure and Macro Index * repl:quit: Repl. * repl:top-level: Repl. * replace-suffix: Filenames. -* require <1>: Require. -* require <2>: Catalog Compilation. -* require: Requesting Features. -* require:feature->path <1>: Require. -* require:feature->path: Requesting Features. -* restrict-table: Relational Database Operations. -* reverse!: SRFI-1. | -* row:delete: Table Operations. -* row:delete*: Table Operations. -* row:insert: Table Operations. -* row:insert*: Table Operations. -* row:remove: Table Operations. -* row:remove*: Table Operations. -* row:retrieve: Table Operations. -* row:retrieve*: Table Operations. -* row:update: Table Operations. -* row:update*: Table Operations. +* require <1>: Catalog Creation. | +* require: Require. | +* require-if: Require. | +* resene: Color Names. +* restrict-table on relational-database: Database Operations. | +* reverse!: SRFI-1. +* RGB709->CIEXYZ: Color Conversions. +* rgb709->color: Color Spaces. +* row:delete on relational-table: Single Row Operations. | +* row:delete* on relational-table: Multi-Row Operations. | +* row:insert on relational-table: Single Row Operations. | +* row:insert* on relational-table: Multi-Row Operations. | +* row:remove on relational-table: Single Row Operations. | +* row:remove* on relational-table: Multi-Row Operations. | +* row:retrieve on relational-table: Single Row Operations. | +* row:retrieve* on relational-table: Multi-Row Operations. | +* row:update on relational-table: Single Row Operations. | +* row:update* on relational-table: Multi-Row Operations. | +* rule-horizontal: Legending. | +* rule-vertical: Legending. | +* saturate: Color Names. * scanf: Standard Formatted Input. * scanf-read-list: Standard Formatted Input. +* scene:overcast: Solid Modeling. +* scene:panorama: Solid Modeling. +* scene:sky-and-dirt: Solid Modeling. +* scene:sky-and-grass: Solid Modeling. +* scene:sphere: Solid Modeling. +* scene:sun: Solid Modeling. +* scene:viewpoint: Solid Modeling. +* scene:viewpoints: Solid Modeling. * scheme-report-environment: Eval. * schmooz: Schmooz. * secant:find-bracketed-root: Root Finding. * secant:find-root: Root Finding. -* seed->random-state: Random Numbers. -* set: Setters. | +* second: SRFI-1. | +* seed->random-state: Exact Random Numbers. | +* set: Setters. +* set-color: Graphics Context. | * set-difference: Lists as sets. +* set-font: Graphics Context. | +* set-glyphsize: Graphics Context. | +* set-linedash: Graphics Context. | +* set-linewidth: Graphics Context. | * Setter: Collections. * setter: Setters. -* seventh: SRFI-1. | +* setup-plot: Column Ranges. | +* seventh: SRFI-1. * si:conversion-factor: Metric Units. * singleton-wt-tree: Construction of Weight-Balanced Trees. -* sixth: SRFI-1. | +* sixth: SRFI-1. * size <1>: Collections. * size: Yasos interface. +* sky-color-xyy: Daylight. * slib:error: System. * slib:eval: System. * slib:eval-load: System. * slib:exit: System. +* slib:in-catalog?: Require. | * slib:load: System. * slib:load-compiled: System. * slib:load-source: System. * slib:report: Configuration. * slib:report-version: Configuration. * slib:warn: System. +* snap-range: Column Ranges. | * software-type: Configuration. +* solar-declination: Daylight. +* solar-hour: Daylight. +* solar-polar: Daylight. +* solid:arrow: Solid Modeling. +* solid:basrelief: Solid Modeling. +* solid:box: Solid Modeling. +* solid:center-array-of: Solid Modeling. +* solid:center-pile-of: Solid Modeling. +* solid:center-row-of: Solid Modeling. +* solid:color: Solid Modeling. +* solid:cone: Solid Modeling. +* solid:cylinder: Solid Modeling. +* solid:disk: Solid Modeling. +* solid:ellipsoid: Solid Modeling. +* solid:pyramid: Solid Modeling. +* solid:rotation: Solid Modeling. +* solid:scale: Solid Modeling. +* solid:sphere: Solid Modeling. +* solid:texture: Solid Modeling. +* solid:translation: Solid Modeling. | +* solidify-database: Using Databases. +* solidify-database on relational-database: Database Operations. | * some: Lists as sets. * sort: Sorting. * sort!: Sorting. * sorted?: Sorting. -* soundex: Hashing. -* split-at: SRFI-1. | +* soundex: Soundex. +* span: SRFI-1. | +* spectrum->chromaticity: Spectra. +* spectrum->CIEXYZ: Spectra. +* spectrum->XYZ: Spectra. +* split-at: SRFI-1. +* split-at!: SRFI-1. | * sprintf: Standard Formatted Output. +* sRGB->CIEXYZ: Color Conversions. +* srgb->color: Color Spaces. +* sRGB->e-sRGB: Color Conversions. +* sRGB->xRGB: Color Conversions. | * sscanf: Standard Formatted Input. * stack: Trace. * stack-all: Debug. +* stackf: Trace. | +* string->color: Color Data-Type. * string->list: Rev4 Optional Procedures. * string-capitalize: String-Case. -* string-captialize!: String-Case. +* string-capitalize!: String-Case. | * string-ci->symbol: String-Case. * string-copy: Rev4 Optional Procedures. * string-downcase: String-Case. @@ -11973,71 +15674,78 @@ Procedure and Macro Index * string-subst: String Search. * string-upcase: String-Case. * string-upcase!: String-Case. +* StudlyCapsExpand: String-Case. * sub-vicinity: Vicinity. +* subarray: Subarrays. +* subarray0: Subarrays. +* subset?: Lists as sets. * subst: Tree Operations. * substq: Tree Operations. * substring-ci?: String Search. * substring-fill!: Rev2 Procedures. * substring-move-left!: Rev2 Procedures. * substring-move-right!: Rev2 Procedures. +* substring-read!: Byte. | +* substring-write: Byte. | * substring?: String Search. * substv: Tree Operations. -* supported-key-type?: Base Table. -* supported-type?: Base Table. +* sunlight-ciexyz: Daylight. +* sunlight-spectrum: Daylight. +* sunlight-xyz: Daylight. +* supported-key-type? on base-table: Base Field Types. | +* supported-type? on base-table: Base Field Types. | * symbol-append: String-Case. * symmetric:modulus: Modular Arithmetic. -* sync-base: Base Table. -* sync-database: Relational Database Operations. +* sync-base on base-table: The Base. | +* sync-database: Using Databases. +* sync-database on relational-database: Database Operations. | * syncase:eval: Syntax-Case Macros. * syncase:expand: Syntax-Case Macros. * syncase:load: Syntax-Case Macros. +* syncase:sanity-check: Syntax-Case Macros. | * synclo:eval: Syntactic Closures. * synclo:expand: Syntactic Closures. * synclo:load: Syntactic Closures. * syntax-rules: Macro by Example. * system: System Interface. +* system->line: Line I/O. | * table->linked-html: HTML Tables. * table->linked-page: HTML Tables. -* table-exists?: Relational Database Operations. +* table-exists? on relational-database: Database Operations. | * table-name->filename: HTML Tables. -* take: SRFI-1. | -* take-right: SRFI-1. | -* tek40:draw: Tektronix Graphics Support. -* tek40:graphics: Tektronix Graphics Support. -* tek40:init: Tektronix Graphics Support. -* tek40:linetype: Tektronix Graphics Support. -* tek40:move: Tektronix Graphics Support. -* tek40:put-text: Tektronix Graphics Support. -* tek40:reset: Tektronix Graphics Support. -* tek40:text: Tektronix Graphics Support. -* tek41:draw: Tektronix Graphics Support. -* tek41:encode-int: Tektronix Graphics Support. -* tek41:encode-x-y: Tektronix Graphics Support. -* tek41:graphics: Tektronix Graphics Support. -* tek41:init: Tektronix Graphics Support. -* tek41:move: Tektronix Graphics Support. -* tek41:point: Tektronix Graphics Support. -* tek41:reset: Tektronix Graphics Support. -* tenth: SRFI-1. | +* take: SRFI-1. +* take!: SRFI-1. | +* take-right: SRFI-1. +* temperature->chromaticity: Spectra. | +* temperature->CIEXYZ: Spectra. +* temperature->XYZ: Spectra. +* tenth: SRFI-1. +* third: SRFI-1. | * time-zone: Time Zone. +* title-bottom: Legending. | +* title-top: Legending. | * tmpnam: Input/Output. +* tok:bump-column: Token definition. | * tok:char-group: Token definition. +* top-refs: Top-level Variable References. | +* top-refs<-file: Top-level Variable References. | * topological-sort: Topological Sort. * trace: Trace. * trace-all: Debug. * tracef: Trace. * track: Trace. * track-all: Debug. +* trackf: Trace. | +* transact-file-replacement: Transactions. * transcript-off: Transcripts. * transcript-on: Transcripts. * transformer: Syntactic Closures. +* transpose: Matrix Algebra. * truncate-up-to: Batch. -* tsort: Topological Sort. -* two-arg:-: Multi-argument / and -. -* two-arg:/: Multi-argument / and -. -* two-arg:apply: Multi-argument Apply. +* tsort: Topological Sort. | * type-of: Type Coercion. * tz:params: Time Zone. +* tz:std-offset: Time Zone. | * tzset: Time Zone. * unbreak: Breakpoints. * unbreakf: Breakpoints. @@ -12047,24 +15755,44 @@ Procedure and Macro Index * untrace: Trace. * untracef: Trace. * untrack: Trace. -* unzip1: SRFI-1. | -* unzip2: SRFI-1. | -* unzip3: SRFI-1. | -* unzip4: SRFI-1. | -* unzip5: SRFI-1. | +* unzip1: SRFI-1. +* unzip2: SRFI-1. +* unzip3: SRFI-1. +* unzip4: SRFI-1. +* unzip5: SRFI-1. * uri->tree: URI. +* uri:decode-query: URI. +* uri:make-path: URI. | +* uri:path->keys: URI. | +* uri:split-fields: URI. | * uric:decode: URI. * uric:encode: URI. -* user-email-address: System Interface. +* url->color-dictionary: Color Names. +* user-email-address: Transactions. * user-vicinity: Vicinity. -* values: Values. | +* values: Values. * vector->list: Rev4 Optional Procedures. * vector-fill!: Rev4 Optional Procedures. +* vet-slib: Module Analysis. | +* vicinity:suffix?: Vicinity. | +* vrml: Solid Modeling. +* vrml-append: Solid Modeling. +* vrml-to-file: Solid Modeling. +* wavelength->chromaticity: Spectra. +* wavelength->CIEXYZ: Spectra. +* wavelength->XYZ: Spectra. +* whole-page <1>: Rectangles. | +* whole-page: PostScript Graphing. | * with-input-from-file: With-File. * with-output-to-file: With-File. -* write-base: Base Table. +* within-database: Database Macros. +* world:info: Solid Modeling. +* wrap-command-interface: Database Extension. +* write-base on base-table: The Base. | * write-byte: Byte. -* write-database: Relational Database Operations. +* write-bytes: Byte. | +* write-database: Using Databases. +* write-database on relational-database: Database Operations. | * write-line: Line I/O. * wt-tree/add: Basic Operations on Weight-Balanced Trees. * wt-tree/add!: Basic Operations on Weight-Balanced Trees. @@ -12092,166 +15820,262 @@ Procedure and Macro Index * wt-tree/split>: Advanced Operations on Weight-Balanced Trees. * wt-tree/subset?: Advanced Operations on Weight-Balanced Trees. * wt-tree/union: Advanced Operations on Weight-Balanced Trees. -* wt-tree?: Basic Operations on Weight-Balanced Trees. -* xcons: SRFI-1. | -* zip: SRFI-1. | +* x-axis: Legending. | +* xcons: SRFI-1. +* xRGB->CIEXYZ: Color Conversions. | +* xrgb->color: Color Spaces. +* xRGB->sRGB: Color Conversions. | +* xyY->XYZ: Spectra. +* xyY:normalize-colors: Spectra. +* XYZ->chromaticity: Spectra. +* XYZ->xyY: Spectra. +* XYZ:normalize: Spectra. +* XYZ:normalize-colors: Spectra. +* y-axis: Legending. | +* zenith-xyy: Daylight. +* zip: SRFI-1. Variable Index ************** - This is an alphabetical list of all the global variables in SLIB. +This is an alphabetical list of all the global variables in SLIB. * Menu: -* *catalog*: Require. -* *features*: Require. -* *http:byline*: HTTP and CGI. -* *modules*: Require. +* *argv*: Getopt. +* *base-table-implementations*: Base Table. +* *catalog*: Require. | +* *http:byline*: HTTP and CGI. | +* *operating-system*: Batch. * *optarg*: Getopt. * *optind*: Getopt. * *qp-width*: Quick Print. -* *random-state*: Random Numbers. +* *random-state*: Exact Random Numbers. | * *ruleset*: Commutative Rings. * *syn-defs*: Ruleset Definition and Use. * *syn-ignore-whitespace*: Ruleset Definition and Use. * *timezone*: Time Zone. -* batch:platform: Batch. -* catalog-id: Base Table. +* atm-hec-polynomial: Cyclic Checksum. +* bottomedge: Legending. | * char-code-limit: Configuration. -* charplot:height: Plotting. -* charplot:width: Plotting. -* column-domains: Table Operations. -* column-foreigns: Table Operations. -* column-names: Table Operations. -* column-types: Table Operations. +* charplot:dimensions: Character Plotting. | +* CIEXYZ:A: Color Conversions. +* CIEXYZ:B: Color Conversions. +* CIEXYZ:C: Color Conversions. +* CIEXYZ:D50: Color Conversions. +* CIEXYZ:D65: Color Conversions. +* CIEXYZ:E: Color Conversions. | +* crc-08-polynomial: Cyclic Checksum. +* crc-10-polynomial: Cyclic Checksum. +* crc-12-polynomial: Cyclic Checksum. +* crc-16-polynomial: Cyclic Checksum. +* crc-32-polynomial: Cyclic Checksum. +* crc-ccitt-polynomial: Cyclic Checksum. +* D50: Color Data-Type. +* D65: Color Data-Type. * daylight?: Time Zone. * debug:max-count: Trace. * distribute*: Commutative Rings. * distribute/: Commutative Rings. +* dowcrc-polynomial: Cyclic Checksum. +* graph:dimensions: Legacy Plotting. | +* graphrect: Rectangles. | +* leftedge: Legending. | * most-positive-fixnum: Configuration. -* nil: Legacy. +* nil: Miscellany. * number-wt-type: Construction of Weight-Balanced Trees. -* primary-limit: Table Operations. +* plotrect: Rectangles. | * prime:prngs: Prime Numbers. * prime:trials: Prime Numbers. +* rightedge: Legending. | * slib:form-feed: Configuration. * slib:tab: Configuration. * stderr: Standard Formatted I/O. * stdin: Standard Formatted I/O. * stdout: Standard Formatted I/O. * string-wt-type: Construction of Weight-Balanced Trees. -* t: Legacy. +* t: Miscellany. * tok:decimal-digits: Token definition. * tok:lower-case: Token definition. * tok:upper-case: Token definition. * tok:whitespaces: Token definition. +* topedge: Legending. | * tzname: Time Zone. +* usb-token-polynomial: Cyclic Checksum. Concept and Feature Index ************************* * Menu: +* aggregate <1>: Module Semantics. | +* aggregate: Library Catalogs. | +* alarm: Multi-Processing. | +* alarm-interrupt: Multi-Processing. | * alist: Association Lists. -* alist-table <1>: Creating and Opening Relational Databases. +* alist-table <1>: Relational Database Objects. +* alist-table <2>: The Base. | * alist-table: Base Table. -* ange-ftp: System Interface. +* ange-ftp: URI. +* appearance: Solid Modeling. * array: Arrays. * array-for-each: Array Mapping. +* association function: Association Lists. | * attribute-value: HTML. +* Auto-sharing: Using Databases. * balanced binary trees: Weight-Balanced Trees. * base: URI. +* base-table: Base Table. * batch: Batch. +* binary: Byte. * binary trees: Weight-Balanced Trees. * binary trees, as discrete maps: Weight-Balanced Trees. * binary trees, as sets: Weight-Balanced Trees. +* binding power: Precedence Parsing Overview. * break: Breakpoints. * byte: Byte. +* byte-number: Byte/Number Conversions. | * calendar time <1>: Posix Time. * calendar time: Time and Date. * Calendar-Time: Posix Time. * caltime: Posix Time. +* canonical: Color Names. * careful: Commutative Rings. -* catalog: Requesting Features. +* catalog: Require. | * Catalog File: Library Catalogs. -* cgi: HTTP and CGI. | +* certificate: Transactions. +* cgi: HTTP and CGI. * chapter-order: Chapter Ordering. -* charplot: Plotting. +* charplot: Character Plotting. | +* Chroma: Color Spaces. +* cie1931: Spectra. +* cie1964: Spectra. +* ciexyz: Spectra. +* CIEXYZ: Color Spaces. +* cksum-string: Cyclic Checksum. | * coerce: Type Coercion. * collect: Collections. +* color-database: Color Names. | +* color-names: Color Names. | * command line: Command Line. -* commentfix: Precedence Parsing Overview. +* commentfix: Rule Types. * common-list-functions <1>: Common List Functions. * common-list-functions: Collections. * commutative-ring: Commutative Rings. +* compiled: Library Catalogs. | +* compiling: Module Conventions. | * Coordinated Universal Time: Posix Time. -* database-utilities <1>: Database Utilities. -* database-utilities: Batch. +* copyright: Copyrights. +* crc: Cyclic Checksum. +* cvs: CVS. +* database-commands: Command Example. +* databases <1>: Command Example. +* databases <2>: Define-tables Example. +* databases <3>: Using Databases. +* databases: Batch. +* daylight: Daylight. +* db->html: HTML Tables. | * debug <1>: Breakpoints. * debug: Debug. +* defmacro: Library Catalogs. | * defmacroexpand <1>: Pretty-Print. * defmacroexpand: Defmacro. -* delim: Precedence Parsing Overview. -* diff: Sequence Comparison. | +* delim: Rule Types. +* dequeues: Queues. | +* determinant: Matrix Algebra. | +* diff: Sequence Comparison. +* directory: Directories. | +* Discrete Fourier Transform: Fast Fourier Transform. | * discrete maps, using binary trees: Weight-Balanced Trees. * DrScheme: Installation. * dynamic: Dynamic Data Type. * dynamic-wind: Dynamic-Wind. +* e-sRGB: Color Spaces. +* emacs: Transactions. +* Encapsulated-PostScript: PostScript Graphing. | * escaped: URI. * Euclidean Domain: Commutative Rings. +* eval: Eval. +* exchanger: Miscellany. * factor: Prime Numbers. * feature <1>: About this manual. -* feature <2>: Requesting Features. +* feature <2>: Require. | * feature: Feature. * fft: Fast Fourier Transform. -* fluid-let <1>: Database Utilities. +* File Transfer Protocol: URI. +* file-lock: Transactions. +* filename: Filenames. * fluid-let: Fluid-Let. * form: HTML. * format: Format. +* gamut: Color Spaces. * generic-write: Generic-Write. -* getit: System Interface. -* getopt <1>: Database Utilities. +* getit: URI. +* getopt <1>: Command Example. * getopt: Getopt. +* getopt-parameters <1>: Command Example. +* getopt-parameters: Getopt Parameter lists. * glob <1>: Batch. * glob: Filenames. -* Guile: Installation. | +* Gray code: Bit-Twiddling. +* Guile: Installation. * hash: Hashing. * hash-table: Hash Tables. +* Hilbert: Peano-Hilbert Space-Filling Curve. +* hilbert-fill: Peano-Hilbert Space-Filling Curve. * HOME <1>: Vicinity. -* HOME: Library Catalogs. -* homecat: Catalog Compilation. -* html-form: HTML. | -* http: HTTP and CGI. | -* implcat: Catalog Compilation. -* infix: Precedence Parsing Overview. -* inmatchfix: Precedence Parsing Overview. +* HOME: Catalog Creation. | +* homecat: Catalog Vicinities. | +* html-for-each: Parsing HTML. +* html-form: HTML. +* http: HTTP and CGI. +* Hue: Color Spaces. +* ICC Profile: Color Spaces. +* implcat: Catalog Vicinities. | +* indexed-sequential-access-method: Byte/Number Conversions. | +* infix: Rule Types. +* Info: Top-level Variable References. | +* inmatchfix: Rule Types. +* install: Installation. | +* installation: Installation. | +* intrinsic feature: Feature. | +* ISAM: Indexed Sequential Access Methods. | +* L*a*b*: Color Spaces. +* L*C*h: Color Spaces. +* L*u*v*: Color Spaces. * Left Denotation, led: Nud and Led Definition. +* Lightness: Color Spaces. * line-i: Line I/O. -* list-processing library: SRFI-1. | +* list-processing library: SRFI-1. +* load-option: Weight-Balanced Trees. | * logical: Bit-Twiddling. * macro <1>: Repl. -* macro: R4RS Macros. -* macro-by-example: Macro by Example. -* macros-that-work: Macros That Work. -* make-crc: Cyclic Checksum. -* match: Base Table. -* match-keys <1>: Table Operations. -* match-keys: Base Table. -* matchfix: Precedence Parsing Overview. +* macro <2>: R4RS Macros. | +* macro: Library Catalogs. | +* macro-by-example <1>: Macro by Example. | +* macro-by-example: Library Catalogs. | +* macros-that-work <1>: Macros That Work. | +* macros-that-work: Library Catalogs. | +* manifest: Module Manifests. | +* match: Match Keys. | +* match-keys <1>: Match Keys. | +* match-keys: Match-Keys. | +* matchfix: Rule Types. +* matfile: MAT-File Format. +* matlab: MAT-File Format. * metric-units: Metric Units. * minimize: Minimizing. * minimum field width (printf): Standard Formatted Output. -* MIT Scheme: Installation. | -* mkimpcat.scm: Catalog Compilation. -* mklibcat.scm: Catalog Compilation. +* MIT Scheme: Installation. +* mkimpcat.scm: Catalog Vicinities. | +* mklibcat.scm: Catalog Vicinities. | * modular: Modular Arithmetic. +* multiarg: Multi-argument / and -. * multiarg-apply: Multi-argument Apply. -* mutliarg: Multi-argument / and -. * MzScheme: Installation. -* nary: Precedence Parsing Overview. -* net-clients: System Interface. -* new-catalog: Catalog Compilation. -* nofix: Precedence Parsing Overview. +* nary: Rule Types. +* new-catalog: Catalog Creation. | +* nofix: Rule Types. * null: HTML Tables. * Null Denotation, nud: Nud and Led Definition. * object: Object. @@ -12259,20 +16083,30 @@ Concept and Feature Index * oop: Yasos. * option, run-time-loadable: Weight-Balanced Trees. * options file: Command Line. -* parameters <1>: Database Utilities. +* parameters <1>: Command Example. * parameters <2>: Batch. * parameters: Parameter lists. * parse: Precedence Parsing. +* pbm: Portable Image Files. +* pbm-raw: Portable Image Files. +* Peano: Peano-Hilbert Space-Filling Curve. +* Peano-Hilbert Space-Filling Curve: Peano-Hilbert Space-Filling Curve. +* pgm: Portable Image Files. +* pgm-raw: Portable Image Files. * plain-text: HTML. * PLT Scheme: Installation. +* pnm: Portable Image Files. | +* portable bitmap graphics: Portable Image Files. | * posix-time: Posix Time. -* postfix: Precedence Parsing Overview. +* postfix: Rule Types. +* ppm: Portable Image Files. +* ppm-raw: Portable Image Files. * pprint-file: Pretty-Print. * PRE: HTML. * precedence: Precedence Parsing. * precision (printf): Standard Formatted Output. -* prefix: Precedence Parsing Overview. -* prestfix: Precedence Parsing Overview. +* prefix: Rule Types. +* prestfix: Rule Types. * pretty-print: Pretty-Print. * primes: Prime Numbers. * printf: Standard Formatted Output. @@ -12284,230 +16118,344 @@ Concept and Feature Index * qp: Getopt. * query-string: HTTP and CGI. * queue: Queues. -* random: Random Numbers. +* r2rs: RnRS. +* r3rs <1>: Coding Guidelines. | +* r3rs: RnRS. +* r4rs: RnRS. +* r5rs: RnRS. +* random: Exact Random Numbers. | +* random-inexact: Inexact Random Numbers. | +* range: Column Ranges. | * rationalize: Rationalize. * read-command: Command Line. * record: Records. +* rectangle: Rectangles. | * relational-database: Relational Database. +* relational-system: Using Databases. | * repl <1>: Repl. * repl: Syntax-Case Macros. +* resene: Color Names. +* Resene: Color Names. * reset: HTML. -* rev2-procedures: Rev2 Procedures. -* rev3-report: Coding Guidelines. +* rev2-procedures: Rev2 Procedures. | * rev4-optional-procedures: Rev4 Optional Procedures. +* RGB709: Color Spaces. * ring, commutative: Commutative Rings. * RNG: Random Numbers. * root: Root Finding. * run-time-loadable option: Weight-Balanced Trees. +* rwb-isam: Base Table. | +* saturate: Color Names. * scanf: Standard Formatted Input. -* Scheme Request For Implementation: SRFI. | +* scheme: URI. +* Scheme Request For Implementation: SRFI. * Scheme48: Installation. * schmooz: Schmooz. * SCM: Installation. -* self-set: Commutative Rings. | -* Sequence Comparison: Sequence Comparison. | +* self-set: Commutative Rings. +* Sequence Comparison: Sequence Comparison. * Server-based Naming Authority: URI. * session: Feature. * sets, using binary trees: Weight-Balanced Trees. -* sierpinski: Hashing. -* sitecat: Catalog Compilation. -* slibcat: Catalog Compilation. +* shell: Command Line. | +* sierpinski: Sierpinski Curve. +* sitecat: Catalog Vicinities. | +* sky: Daylight. +* slibcat: Catalog Vicinities. | +* solid: Solid Modeling. +* solid-modeling: Solid Modeling. +* solids: Solid Modeling. * sort: Sorting. -* soundex: Hashing. -* spiff: Sequence Comparison. | -* srfi: SRFI. | -* SRFI-1: SRFI-1. | -* srfi-1: SRFI-1. | +* soundex: Soundex. +* source: Library Catalogs. | +* Space-Filling: Peano-Hilbert Space-Filling Curve. +* sparse: MAT-File Format. +* Spectral Tristimulus Values: Spectra. +* spiff: Sequence Comparison. +* srfi: SRFI. +* SRFI-1: SRFI-1. +* srfi-1: SRFI-1. +* srfi-2: SRFI-2. | +* srfi-8: SRFI-8. | +* srfi-9: SRFI-9. | +* sRGB: Color Spaces. * stdio: Standard Formatted I/O. * string-case: String-Case. * string-port: String Ports. -* string-search: String Search. | -* syntactic-closures: Syntactic Closures. -* syntax-case: Syntax-Case Macros. +* string-search: String Search. +* subarray: Subarrays. +* sun: Daylight. +* sunlight: Daylight. +* symmetric: Modular Arithmetic. | +* syntactic-closures <1>: Syntactic Closures. | +* syntactic-closures: Library Catalogs. | +* syntax tree: Precedence Parsing Overview. +* syntax-case <1>: Syntax-Case Macros. | +* syntax-case: Library Catalogs. | * time: Time and Date. * time-zone: Time Zone. +* top-level variable references: Top-level Variable References. | +* top-refs: Top-level Variable References. | * topological-sort: Topological Sort. * trace: Trace. +* transact: Transactions. * transcript: Transcripts. * tree: Tree Operations. * trees, balanced binary: Weight-Balanced Trees. +* tristimulus: Color Spaces. * tsort: Topological Sort. +* turbidity: Daylight. * TZ-string: Time Zone. * Uniform Resource Identifiers: URI. -* Uniform Resource Locator: System Interface. +* Uniform Resource Locator: URI. * Unique Factorization: Commutative Rings. * unsafe: URI. -* uri: URI. | +* URI: URI. +* uri: URI. * URI: HTTP and CGI. -* usercat: Catalog Compilation. +* usercat: Catalog Vicinities. | * UTC: Posix Time. * values: Values. +* variable references: Top-level Variable References. | +* vet: Module Analysis. | * VSCM: Installation. +* WB: Base Table. +* wb-table: Base Table. * weight-balanced binary trees: Weight-Balanced Trees. -* wild-card: Base Table. +* wget: Color Names. +* white point: Color Data-Type. +* wild-card: Match Keys. | * with-file: With-File. +* Word: Transactions. * wt-tree: Weight-Balanced Trees. +* xRGB: Color Spaces. +* xyY: Spectra. * yasos: Yasos. Tag Table: -Node: Top1026 -Node: The Library System1740 -Node: Feature2054 -Node: Requesting Features3004 -Node: Library Catalogs4363 -Node: Catalog Compilation6815 -Node: Built-in Support9624 -Node: Require10255 -Node: Vicinity12747 -Node: Configuration15714 -Node: Input/Output18655 -Node: Legacy20254 -Node: System21096 -Node: About this manual23588 -Node: Scheme Syntax Extension Packages24145 -Node: Defmacro24837 -Node: R4RS Macros26788 -Node: Macro by Example28043 -Node: Macros That Work30922 -Node: Syntactic Closures36980 -Node: Syntax-Case Macros54414 -Node: Fluid-Let58605 -Node: Yasos59546 -Node: Yasos terms60339 -Node: Yasos interface61363 -Node: Setters63438 -Node: Yasos examples66079 -Node: Textual Conversion Packages69073 -Node: Precedence Parsing69751 -Node: Precedence Parsing Overview70414 -Ref: Precedence Parsing Overview-Footnote-172337 -Node: Ruleset Definition and Use72615 -Node: Token definition74996 -Node: Nud and Led Definition77265 -Node: Grammar Rule Definition79714 -Node: Format87288 -Node: Format Interface87536 -Node: Format Specification89273 -Node: Standard Formatted I/O99328 -Node: Standard Formatted Output99894 -Node: Standard Formatted Input109617 -Node: Programs and Arguments116277 -Node: Getopt116777 -Node: Command Line122619 -Node: Parameter lists125808 -Node: Getopt Parameter lists129695 -Node: Filenames132950 -Node: Batch136180 -Node: HTML143973 -Node: HTML Tables150074 -Node: HTTP and CGI156483 -Node: URI161013 -Node: Printing Scheme163686 -Node: Generic-Write163995 -Node: Object-To-String165398 -Node: Pretty-Print165802 -Node: Time and Date168765 -Node: Time Zone169792 -Node: Posix Time174353 -Node: Common-Lisp Time176489 -Node: Vector Graphics178068 -Node: Tektronix Graphics Support178257 -Node: Schmooz179631 -Node: Mathematical Packages183857 -Node: Bit-Twiddling184491 -Node: Modular Arithmetic189082 -Node: Prime Numbers191216 -Node: Random Numbers192899 -Node: Fast Fourier Transform197535 -Node: Cyclic Checksum198453 -Node: Plotting200417 -Node: Root Finding203276 -Node: Minimizing207263 -Ref: Minimizing-Footnote-1208700 -Node: Commutative Rings209303 -Node: Determinant220687 -Node: Database Packages221092 -Node: Base Table221356 -Node: Relational Database231770 -Node: Motivations232554 -Node: Creating and Opening Relational Databases237601 -Node: Relational Database Operations240033 -Node: Table Operations243029 -Node: Catalog Representation250907 -Node: Unresolved Issues253805 -Node: Database Utilities256756 -Node: Database Reports272873 -Node: Database Browser275627 -Node: Weight-Balanced Trees276688 -Node: Construction of Weight-Balanced Trees280559 -Node: Basic Operations on Weight-Balanced Trees284009 -Node: Advanced Operations on Weight-Balanced Trees286974 -Node: Indexing Operations on Weight-Balanced Trees292996 -Node: Other Packages296910 -Node: Data Structures297389 -Node: Arrays298223 -Node: Array Mapping302100 -Node: Association Lists304017 -Node: Byte306268 -Node: Portable Image Files308508 -Node: Collections310055 -Node: Dynamic Data Type316447 -Node: Hash Tables317708 -Node: Hashing319889 -Node: Object324660 -Node: Priority Queues332896 -Node: Queues333739 -Node: Records334865 -Node: Sorting and Searching338436 -Node: Common List Functions339236 -Node: List construction339761 -Node: Lists as sets341607 -Node: Lists as sequences348573 -Node: Destructive list operations353827 -Node: Non-List functions356490 -Node: Tree Operations357667 -Node: Chapter Ordering359507 -Node: Sorting361217 -Node: Topological Sort367084 -Node: String Search368863 -Node: Sequence Comparison371335 -Node: Procedures377271 -Node: Type Coercion378665 -Node: String-Case379881 -Node: String Ports382059 -Node: Line I/O383592 -Node: Multi-Processing385320 -Node: Metric Units386424 -Node: Standards Support394650 -Node: With-File395385 -Node: Transcripts395661 -Node: Rev2 Procedures395982 -Node: Rev4 Optional Procedures397739 -Node: Multi-argument / and -398309 -Node: Multi-argument Apply399048 -Node: Rationalize399583 -Node: Promises400908 -Node: Dynamic-Wind401325 -Node: Eval402579 -Node: Values405916 -Node: SRFI406795 -Node: SRFI-1409905 -Node: Session Support420362 -Node: Repl420909 -Node: Quick Print422192 -Node: Debug423305 -Node: Breakpoints424191 -Node: Trace426214 -Node: System Interface429325 -Node: Extra-SLIB Packages433079 -Node: About SLIB435381 -Node: Installation436084 -Node: Porting443977 -Ref: Porting-Footnote-1421798 -Node: Coding Guidelines445504 -Node: Copyrights447585 -Node: Index450931 +Node: Top1038 +Node: The Library System1832 +Node: Feature2447 +Node: Require5817 +Node: Library Catalogs9665 +Node: Catalog Creation11330 +Node: Catalog Vicinities14797 +Node: Compiling Scheme19397 +Node: Module Conventions20721 +Ref: Module Conventions-Footnote-115614 +Node: Module Manifests23491 +Node: Module Semantics32652 +Node: Top-level Variable References35341 +Ref: Top-level Variable References-Footnote-124139 +Node: Module Analysis39789 +Node: Universal SLIB Procedures42532 +Node: Vicinity43862 +Node: Configuration47550 +Node: Input/Output50710 +Node: System54238 +Node: Miscellany57523 +Node: Scheme Syntax Extension Packages59694 +Node: Defmacro60439 +Node: R4RS Macros62386 +Node: Macro by Example63639 +Node: Macros That Work66514 +Node: Syntactic Closures72567 +Node: Syntax-Case Macros89995 +Node: Fluid-Let94454 +Node: Yasos95393 +Node: Yasos terms96184 +Node: Yasos interface97208 +Node: Setters99283 +Node: Yasos examples101923 +Node: Textual Conversion Packages104922 +Node: Precedence Parsing105719 +Node: Precedence Parsing Overview106395 +Ref: Precedence Parsing Overview-Footnote-188500 +Node: Rule Types108019 +Node: Ruleset Definition and Use109452 +Node: Token definition111816 +Node: Nud and Led Definition114725 +Node: Grammar Rule Definition117172 +Node: Format124746 +Node: Standard Formatted I/O125156 +Node: Standard Formatted Output125720 +Node: Standard Formatted Input135110 +Node: Programs and Arguments141768 +Node: Getopt142268 +Node: Command Line148891 +Node: Parameter lists152078 +Node: Getopt Parameter lists155963 +Node: Filenames159199 +Node: Batch163646 +Node: HTML171449 +Node: HTML Tables178112 +Node: HTTP and CGI184553 +Node: Parsing HTML189090 +Node: URI191584 +Node: Printing Scheme196704 +Node: Generic-Write197013 +Node: Object-To-String198414 +Node: Pretty-Print198816 +Node: Time and Date201777 +Node: Time Zone202797 +Node: Posix Time207756 +Node: Common-Lisp Time209892 +Node: NCBI-DNA211471 +Node: Schmooz212801 +Node: Mathematical Packages217028 +Node: Bit-Twiddling217744 +Node: Modular Arithmetic225665 +Node: Prime Numbers228534 +Node: Random Numbers230215 +Node: Exact Random Numbers231435 +Node: Inexact Random Numbers234181 +Node: Fast Fourier Transform236532 +Node: Cyclic Checksum237446 +Node: Graphing244571 +Node: Character Plotting245251 +Node: PostScript Graphing251089 +Node: Column Ranges255097 +Node: Drawing the Graph258417 +Node: Graphics Context263014 +Node: Rectangles267208 +Node: Legending270354 +Node: Legacy Plotting274779 +Node: Example Graph276487 +Node: Solid Modeling284587 +Node: Color300794 +Node: Color Data-Type301620 +Ref: Color Data-Type-Footnote-1261941 +Node: Color Spaces305581 +Ref: Color Spaces-Footnote-1271875 +Node: Spectra315434 +Node: Color Difference Metrics323004 +Node: Color Conversions326666 +Node: Color Names329317 +Node: Daylight336339 +Node: Root Finding341138 +Node: Minimizing345119 +Ref: Minimizing-Footnote-1301934 +Node: Commutative Rings347157 +Node: Matrix Algebra358549 +Node: Database Packages359679 +Node: Relational Database360087 +Node: Using Databases361118 +Node: Table Operations369657 +Node: Single Row Operations371774 +Node: Match-Keys375050 +Node: Multi-Row Operations378335 +Node: Indexed Sequential Access Methods381431 +Node: Sequential Index Operations383339 +Node: Table Administration387317 +Node: Database Interpolation388727 +Node: Embedded Commands390241 +Node: Database Extension391882 +Node: Command Intrinsics393982 +Node: Define-tables Example395584 +Node: The *commands* Table397396 +Node: Command Service399709 +Node: Command Example401654 +Node: Database Macros406303 +Node: Within-database Example408933 +Node: Database Browser410852 +Node: Relational Infrastructure412730 +Node: Base Table413507 +Node: The Base418368 +Node: Base Tables422788 +Node: Base Field Types425445 +Node: Composite Keys426988 +Node: Base Record Operations430382 +Node: Match Keys433530 +Node: Aggregate Base Operations435329 +Node: Base ISAM Operations437366 +Node: Catalog Representation439784 +Node: Relational Database Objects445280 +Node: Database Operations449505 +Node: Weight-Balanced Trees455859 +Node: Construction of Weight-Balanced Trees459813 +Node: Basic Operations on Weight-Balanced Trees463261 +Node: Advanced Operations on Weight-Balanced Trees466187 +Node: Indexing Operations on Weight-Balanced Trees472207 +Node: Other Packages476032 +Node: Data Structures476583 +Node: Arrays477400 +Node: Subarrays482891 +Node: Array Mapping486245 +Node: Association Lists488990 +Node: Byte491241 +Node: Byte/Number Conversions499604 +Node: MAT-File Format511631 +Node: Portable Image Files512974 +Node: Collections514601 +Node: Dynamic Data Type520757 +Node: Hash Tables522016 +Node: Object524916 +Node: Priority Queues533150 +Node: Queues534217 +Node: Records535855 +Node: Sorting and Searching539345 +Node: Common List Functions540030 +Node: List construction540474 +Node: Lists as sets542169 +Node: Lists as sequences548782 +Node: Destructive list operations554036 +Node: Non-List functions556705 +Node: Tree Operations557775 +Node: Chapter Ordering559541 +Node: Sorting561170 +Node: Topological Sort567171 +Node: Hashing568864 +Node: Space-Filling Curves569865 +Node: Peano-Hilbert Space-Filling Curve570085 +Node: Sierpinski Curve571277 +Node: Soundex573731 +Node: String Search575345 +Node: Sequence Comparison578018 +Node: Procedures581424 +Node: Type Coercion581944 +Node: String-Case582361 +Node: String Ports584209 +Node: Line I/O584966 +Node: Multi-Processing587018 +Node: Metric Units588120 +Node: Standards Support596342 +Node: RnRS597171 +Node: With-File598378 +Node: Transcripts598639 +Node: Rev2 Procedures598958 +Node: Rev4 Optional Procedures600666 +Node: Multi-argument / and -601234 +Node: Multi-argument Apply601748 +Node: Rationalize602150 +Node: Promises603412 +Node: Dynamic-Wind604467 +Node: Eval605719 +Node: Values609054 +Node: SRFI609852 +Node: SRFI-1611285 +Node: SRFI-2617429 +Node: SRFI-8618223 +Node: SRFI-9619017 +Node: Session Support620436 +Node: Repl620913 +Node: Quick Print622194 +Node: Debug623483 +Node: Breakpoints624367 +Node: Trace626388 +Node: System Interface629792 +Node: Directories630353 +Node: Transactions631828 +Node: CVS637524 +Node: Extra-SLIB Packages638596 +Node: About SLIB640897 +Node: Installation641640 +Node: Porting646734 +Ref: Porting-Footnote-1555316 +Node: Coding Guidelines648663 +Node: Copyrights651753 +Node: About this manual655155 +Node: Index656435 End Tag Table @@ -0,0 +1,119 @@ + +##"slib" script; Find a Scheme implementation and initialize SLIB in it. +#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. + +usage="Usage: slib [--version | -v] + + Display version information and exit successfully. + +Usage: slib SCHEME + + Initialize SLIB in Scheme implementation SCHEME. + +Usage: slib + + Initialize SLIB session using executable 'scheme', 'scm', + 'mzscheme', 'guile', 'gsi' or 'slib48'." + +case "$1" in + -v | --ver*) echo slib "$VERSION"; exit 0;; + "") + if type scheme>/dev/null 2>&1; then + command=scheme + fi;; + -*) echo "$usage"; exit 1;; + *) + command="$1" + shift +esac +# If more arguments are supplied, then err out. +if [ ! -z "$1" ]; then + echo "$usage"; exit 1 +fi + +if type $command>/dev/null 2>&1; then + SPEW="`$command --version < /dev/null 2>&1`" + if echo ${SPEW} | grep -q 'Initialize load-path (colon-list of directories)' \ + ; then implementation=elk + elif echo ${SPEW} | grep -q 'MIT Scheme' ; then implementation=mit + elif echo ${SPEW} | grep -q 'UMB Scheme' ; then implementation=umb + elif echo ${SPEW} | grep -q 'scheme48' ; then implementation=s48 + elif echo ${SPEW} | grep -q 'MzScheme' ; then implementation=plt + elif echo ${SPEW} | grep -q 'Guile' ; then implementation=gui + elif echo ${SPEW} | grep -q 'gambc' ; then implementation=gam + elif echo ${SPEW} | grep -q 'SCM' ; then implementation=scm + else implementation= + fi +elif [ ! -z "$command" ]; then + echo "Program '$command' not found." + exit 1 +fi + +if [ -z "$command" ]; +then + if type scm>/dev/null 2>&1; then + command=scm; implementation=scm + elif type gsi>/dev/null 2>&1; then + command=gsi; implementation=gam + elif type mzscheme>/dev/null 2>&1; then + command=mzscheme; implementation=plt + elif type guile>/dev/null 2>&1; then + command=guile; implementation=gui + elif type slib48>/dev/null 2>&1; then + command=slib48; implementation=s48 + else + echo No Scheme implementation found. + exit 1 + fi +fi + +case $implementation in + scm);; + s48);; + *) if [ -z "${SCHEME_LIBRARY_PATH}" ]; then + export SCHEME_LIBRARY_PATH=`rpm -ql slib 2>/dev/null \ + | grep require.scm | sed 's%require.scm%%'` + fi + if [ -z "${SCHEME_LIBRARY_PATH}" ]; then + if [ -d /usr/local/lib/slib/ ]; then + export SCHEME_LIBRARY_PATH=/usr/local/lib/slib/ + elif [ -d /usr/share/slib/ ]; then + export SCHEME_LIBRARY_PATH=/usr/share/slib/ + fi + fi;; +esac + +# for gambit +case $implementation in + gam) if [ -z "${LD_LIBRARY_PATH}" ]; then + export LD_LIBRARY_PATH=/usr/local/lib + fi;; +esac + +case $implementation in + scm) exec $command -ip1 -l ${SCHEME_LIBRARY_PATH}scm.init $*;; + elk) exec $command -i -l ${SCHEME_LIBRARY_PATH}elk.init;; + gam) exec $command -:s ${SCHEME_LIBRARY_PATH}gambit.init - $*;; + plt) exec $command -f ${SCHEME_LIBRARY_PATH}DrScheme.init $*;; + gui) exec $command -l ${SCHEME_LIBRARY_PATH}guile.init $*;; + mit) exec $command -load ${SCHEME_LIBRARY_PATH}mitscheme.init $*;; + s48) exec $command $*;; + umb) echo "umb-scheme vicinities are too wedged to run slib"; exit 1;; + *) exit 1;; +esac @@ -1,5 +1,5 @@ %define name slib -%define version 2d2 +%define version 3a1 %define release 1 Name: %{name} @@ -55,32 +55,27 @@ if [ -L /usr/share/guile/slib ]; then ln -s %{prefix}/slib /usr/share/guile/slib fi -# This section should be extended to rebuild catalogs for as many -# implementations as possible. -if type guile; then - guile -c "(use-modules (ice-9 slib)) (require 'new-catalog)" -fi -if type scm; then - scm -c "(require 'new-catalog)" -fi -if type umb-scheme; then - SCHEME_INIT=${SCHEME_LIBRARY_PATH}umbscheme.init - echo "(require 'new-catalog)" | umb-scheme -fi -if type mzscheme; then - SCHEME_LIBRARY_PATH=`pwd`/ - rm /usr/local/lib/plt-103/slibcat - mzscheme -L init.ss slibinit -e "(require 'new-catalog)" -fi -if type scheme48; then - make install48 -fi +# Rebuild catalogs for as many implementations as possible. +export PATH=$PATH:/usr/local/bin +echo PATH=${PATH} +cd %{prefix}/slib/ +make catalogs +# Make color-name databases. +make clrnamdb + +%preun +cd %{prefix}/slib/ +rm -f clrnamdb.scm srcdir.mk slib.image %files %defattr(-, root, root) %dir %{prefix}/slib %{prefix}/slib/*.scm %{prefix}/slib/*.init +%{prefix}/slib/cie1931.xyz +%{prefix}/slib/cie1964.xyz +%{prefix}/slib/saturate.txt +%{prefix}/slib/resenecolours.txt /usr/info/slib.info.gz # The Makefile is included as it is useful for building documentation. %{prefix}/slib/Makefile @@ -27,7 +27,7 @@ This file documents SLIB, the portable Scheme library. Copyright (C) 1993 Todd R. Eigenschink@* -Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000 Aubrey Jaffer +Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002 Aubrey Jaffer Permission is granted to make and distribute verbatim copies of this manual provided the copyright notice and this permission notice @@ -117,6 +117,7 @@ implementation, user, or directory. @menu * The Library System:: How to use and customize. +* Universal SLIB Procedures:: Provided for all implementations. * Scheme Syntax Extension Packages:: * Textual Conversion Packages:: * Mathematical Packages:: @@ -126,31 +127,32 @@ implementation, user, or directory. * Index:: @end menu -@node The Library System, Scheme Syntax Extension Packages, Top, Top +@node The Library System, Universal SLIB Procedures, Top, Top @chapter The Library System @menu * Feature:: SLIB names. -* Requesting Features:: +* Require:: * Library Catalogs:: -* Catalog Compilation:: -* Built-in Support:: -* About this manual:: +* Catalog Creation:: +* Catalog Vicinities:: +* Compiling Scheme:: @end menu -@node Feature, Requesting Features, The Library System, The Library System +@node Feature, Require, The Library System, The Library System @section Feature @noindent @cindex feature SLIB denotes @dfn{features} by symbols. SLIB maintains a list of -features supported by the Scheme @dfn{session}. The set of features +features supported by a Scheme @dfn{session}. The set of features @cindex session -provided by a session may change over time. Some features are -properties of the Scheme implementation being used. The following -features detail what sort of numbers are available from an -implementation. +provided by a session may change during that session. Some features +are properties of the Scheme implementation being used. The following +@cindex intrinsic feature +@dfn{intrinsic feature}s detail what sort of numbers are available +from an implementation: @itemize @bullet @item @@ -166,17 +168,46 @@ implementation. @end itemize @noindent -Other features correspond to the presence of sets of Scheme procedures -or syntax (macros). +SLIB initialization (in @file{require.scm}) tests and @dfn{provide}s +any of these numeric features which are appropriate. + +@noindent +Other features correspond to the presence of packages of Scheme +procedures or syntax (macros). @defun provided? feature -Returns @code{#t} if @var{feature} is supported by the current Scheme -session. +Returns @code{#t} if @var{feature} is present in the current Scheme +session; otherwise @code{#f}. More specifically, @code{provided?} +returns @code{#t} if the symbol @var{feature} is the +@code{software-type} or if @var{feature} has been provided by a module +already loaded; and @code{#f} otherwise. + +In some implementations @code{provided?} tests whether a module has +been @code{require}d by any module or in any thread; other +implementations will have @code{provided?} reflect only the modules +@code{require}d by that particular session or thread. + +To work portably in both scenarios, use @code{provided?} only to test +whether intrinsic properties (like those above) are present. + +The @var{feature} argument can also be an expression calling +@code{and}, @code{or}, and @code{not} of features. The boolean result +of the logical question asked by @var{feature} is returned. +@end defun + +@noindent +The generalization of @code{provided?} for arbitrary features and catalog +is @code{feature-eval}: + +@defun feature-eval expression provided? +Evaluates @code{and}, @code{or}, and @code{not} forms in +@var{expression}, using the values returned by calling @var{provided?} +on the leaf symbols. @code{feature-eval} returns the boolean result +of the logical combinations. @end defun -@deffn Procedure provide feature -Informs SLIB that @var{feature} is supported. Henceforth -@code{(provided? @var{feature})} will return @code{#t}. +@deffn {Procedure} provide feature +Informs SLIB that @var{feature} is supported in this session. @end deffn @example @@ -185,15 +216,35 @@ Informs SLIB that @var{feature} is supported. Henceforth (provided? 'foo) @result{} #t @end example +@c @defvar *features* +@c Is a list of symbols denoting features present in this implementation. +@c @var{*features*} can grow as modules are @code{require}d. +@c @footnote{The variables @var{*modules*} and @var{*features*} were +@c originally modeled on variables of the same names in common-lisp. But +@c the distinction between features native to an implementation versus +@c those provided by loading files was not useful. The symbols in +@c @var{*features*} now indicate the presence of a capability regardless +@c of how it was provided.} +@c @end defvar -@node Requesting Features, Library Catalogs, Feature, The Library System -@section Requesting Features + +@node Require, Library Catalogs, Feature, The Library System +@section Require @noindent @cindex catalog SLIB creates and maintains a @dfn{catalog} mapping features to locations of files introducing procedures and syntax denoted by those features. +@defvar *catalog* +Is an association list of features (symbols) and pathnames which will +supply those features. The pathname can be either a string or a pair. +If pathname is a pair then the first element should be a macro feature +symbol, @code{source}, @code{compiled}, or one of the other cases +described in @ref{Library Catalogs}. The cdr of the pathname should +be either a string or a list. +@end defvar + @noindent At the beginning of each section of this manual, there is a line like @code{(require '@var{feature})}. @@ -205,16 +256,16 @@ names map to the corresponding files. SLIB provides a form, @code{require}, which loads the files providing the requested feature. -@deffn Procedure require feature +@deffn {Procedure} require feature @itemize @bullet @item If @code{(provided? @var{feature})} is true, -then @code{require} just returns an unspecified value. +then @code{require} just returns. @item Otherwise, if @var{feature} is found in the catalog, then the -corresponding files will be loaded and an unspecified value returned. - -Subsequently @code{(provided? @var{feature})} will return @code{#t}. +corresponding files will be loaded and @code{(provided? +@var{feature})} will henceforth return @code{#t}. That @var{feature} +is thereafter @code{provided}. @item Otherwise (@var{feature} not found in the catalog), an error is signaled. @@ -222,47 +273,58 @@ signaled. @end deffn @noindent -The catalog can also be queried using @code{require:feature->path}. +There is a related form @code{require-if}, used primarily for enabling +compilers to statically include modules which would be dynamically +loaded by interpreters. -@defun require:feature->path feature -@itemize @bullet -@item -If @var{feature} is already provided, then returns @code{#t}. -@item -Otherwise, if @var{feature} is in the catalog, the path or list of paths -associated with @var{feature} is returned. -@item -Otherwise, returns @code{#f}. -@end itemize -@end defun +@deffn {Procedure} require-if condition feature +Requires @var{feature} if @var{condition} is true. +@end deffn -@node Library Catalogs, Catalog Compilation, Requesting Features, The Library System -@section Library Catalogs +@noindent +The @code{random} module uses @code{require-if} to flag +@code{object->string} as a (dynamic) required module. + +@example +(require 'byte) +(require 'logical) +(require-if 'compiling 'object->string) +@end example @noindent -At the start of a session no catalog is present, but is created with the -first catalog inquiry (such as @code{(require 'random)}). Several -sources of catalog information are combined to produce the catalog: +The @code{batch} module uses @code{require-if} to flag +@code{posix-time} as a module to load if the implementation supports +large precision exact integers. -@itemize @bullet -@item -standard SLIB packages. -@item -additional packages of interest to this site. -@item -packages specifically for the variety of Scheme which this -session is running. -@item -packages this user wants to always have available. This catalog is the -file @file{homecat} in the user's @dfn{HOME} directory. -@cindex HOME -@item -packages germane to working in this (current working) directory. This -catalog is the file @file{usercat} in the directory to which it applies. -One would typically @code{cd} to this directory before starting the -Scheme session. -@end itemize +@example +(require-if '(and bignum compiling) 'posix-time) +@end example + +@noindent +The @code{commutative-ring} module uses @code{require-if} to ensure +that it has an exponentiation routine, regardless of whether the +implementation supports inexact numbers: + +@example +(require-if '(not inexact) 'logical) ;for integer-expt +(define number^ (if (provided? 'inexact) expt integer-expt)) +@end example + +@noindent +The catalog can also be queried using @code{slib:in-catalog?}. + +@defun slib:in-catalog? feature +Returns a @code{CDR} of the catalog entry if one was found for the +symbol @var{feature} in the alist @code{*catalog*} (and transitively +through any symbol aliases encountered). Otherwise, returns +@code{#f}. The format of catalog entries is explained in @ref{Library +Catalogs}. +@end defun + + +@node Library Catalogs, Catalog Creation, Require, The Library System +@section Library Catalogs @noindent Catalog files consist of one or more @dfn{association list}s. @@ -277,9 +339,14 @@ Redirects to the feature named @i{<symbol>}. @item (@var{feature} . "@i{<path>}") Loads file @i{<path>}. @item (@var{feature} source "@i{<path>"}) +@cindex source @code{slib:load}s the Scheme source file @i{<path>}. @item (@var{feature} compiled "@i{<path>"} @dots{}) +@cindex compiled @code{slib:load-compiled}s the files @i{<path>} @dots{}. +@item (@var{feature} aggregate @i{<symbol>} @dots{}) +@cindex aggregate +@code{slib:require}s the features @i{<symbol>} @dots{}. @end table @noindent @@ -289,40 +356,58 @@ appropriate for the implementation. @table @code @item (@var{feature} defmacro "@i{<path>"}) +@cindex defmacro @code{defmacro:load}s the Scheme source file @i{<path>}. @item (@var{feature} macro-by-example "@i{<path>"}) +@cindex macro-by-example @code{defmacro:load}s the Scheme source file @i{<path>}. @end table @table @code @item (@var{feature} macro "@i{<path>"}) +@cindex macro @code{macro:load}s the Scheme source file @i{<path>}. @item (@var{feature} macros-that-work "@i{<path>"}) +@cindex macros-that-work @code{macro:load}s the Scheme source file @i{<path>}. @item (@var{feature} syntax-case "@i{<path>"}) +@cindex syntax-case @code{macro:load}s the Scheme source file @i{<path>}. @item (@var{feature} syntactic-closures "@i{<path>"}) +@cindex syntactic-closures @code{macro:load}s the Scheme source file @i{<path>}. @end table -@noindent -Here is an example of a @file{usercat} catalog. A Program in this -directory can invoke the @samp{run} feature with @code{(require 'run)}. - -@example -;;; "usercat": SLIB catalog additions for SIMSYNCH. -*-scheme-*- -( - (simsynch . "../synch/simsynch.scm") - (run . "../synch/run.scm") - (schlep . "schlep.scm") -) -@end example +@node Catalog Creation, Catalog Vicinities, Library Catalogs, The Library System +@section Catalog Creation +@noindent +At the start of an interactive session no catalog is present, but is +created with the first catalog inquiry (such as @code{(require +'random)}). Several sources of catalog information are combined to +produce the catalog: -@node Catalog Compilation, Built-in Support, Library Catalogs, The Library System -@section Catalog Compilation - +@itemize @bullet +@item +standard SLIB packages. +@item +additional packages of interest to this site. +@item +packages specifically for the variety of Scheme which this +session is running. +@item +packages this user wants to always have available. This catalog is the +file @file{homecat} in the user's @dfn{HOME} directory. +@cindex HOME +@item +packages germane to working in this (current working) directory. This +catalog is the file @file{usercat} in the directory to which it applies. +One would typically @code{cd} to this directory before starting the +Scheme session. +@item +packages which are part of an application program. +@end itemize @noindent SLIB combines the catalog information which doesn't vary per user into @@ -333,34 +418,39 @@ installation to installation, SLIB builds a separate catalog for each implementation it is used with. @noindent -The definition of @code{*SLIB-VERSION*} in SLIB file @file{require.scm} -is checked against the catalog association of @code{*SLIB-VERSION*} to -ascertain when versions have changed. I recommend that the definition -of @code{*SLIB-VERSION*} be changed whenever the library is changed. If -multiple implementations of Scheme use SLIB, remember that recompiling -one @file{slibcat} will fix only that implementation's catalog. +The definition of @code{*SLIB-VERSION*} in SLIB file +@file{require.scm} is checked against the catalog association of +@code{*SLIB-VERSION*} to ascertain when versions have changed. It is +a reasonable practice to change the definition of +@code{*SLIB-VERSION*} whenever the library is changed. If multiple +implementations of Scheme use SLIB, remember that recompiling one +@file{slibcat} will update only that implementation's catalog. @noindent The compilation scripts of Scheme implementations which work with SLIB can automatically trigger catalog compilation by deleting -@file{slibcat} or by invoking a special form of @code{require}: +@file{slibcat} or by invoking @code{require} of a special feature: -@deffn Procedure require @r{'new-catalog} +@deffn {Procedure} require @r{'new-catalog} @cindex new-catalog This will load @file{mklibcat}, which compiles and writes a new @file{slibcat}. @end deffn @noindent -Another special form of @code{require} erases SLIB's catalog, forcing it -to be reloaded the next time the catalog is queried. +Another special feature of @code{require} erases SLIB's catalog, +forcing it to be reloaded the next time the catalog is queried. -@deffn Procedure require @r{#f} +@deffn {Procedure} require @r{#f} Removes SLIB's catalog information. This should be done before saving an executable image so that, when restored, its catalog will be loaded afresh. @end deffn + +@node Catalog Vicinities, Compiling Scheme, Catalog Creation, The Library System +@section Catalog Vicinities + @noindent Each file in the table below is descibed in terms of its file-system independent @dfn{vicinity} (@pxref{Vicinity}). The entries @@ -404,113 +494,213 @@ This file contains the associations specific to an SLIB user. @item @code{user-vicinity} @file{usercat} @cindex usercat -This file contains associations effecting only those sessions whose +This file contains associations affecting only those sessions whose @dfn{working directory} is @code{user-vicinity}. @end table -@node Built-in Support, About this manual, Catalog Compilation, The Library System -@section Built-in Support +@noindent +Here is an example of a @file{usercat} catalog. A program in this +directory can invoke the @samp{run} feature with @code{(require 'run)}. + +@example +;;; "usercat": SLIB catalog additions for SIMSYNCH. -*-scheme-*- +( + (simsynch . "../synch/simsynch.scm") + (run . "../synch/run.scm") + (schlep . "schlep.scm") +) +@end example @noindent -The procedures described in these sections are supported by all -implementations as part of the @samp{*.init} files or by -@file{require.scm}. +Copying @file{usercat} to many directories is inconvenient. +Application programs which aren't always run in specially prepared +directories can nonetheless register their features during +initialization. -@menu -* Require:: Module Management -* Vicinity:: Pathname Management -* Configuration:: Characteristics of Scheme Implementation -* Input/Output:: Things not provided by the Scheme specs. -* Legacy:: -* System:: LOADing, EVALing, ERRORing, and EXITing -@end menu +@deffn {Procedure} catalog:read vicinity catalog +Reads file named by string @var{catalog} in @var{vicinity}, resolving +all paths relative to @var{vicinity}, and adds those feature +associations to @var{*catalog*}. +@code{catalog:read} would typically be used by an application program +having dynamically loadable modules. For instance, to register +factoring and other modules in @var{*catalog*}, JACAL does: -@node Require, Vicinity, Built-in Support, Built-in Support -@subsection Require +@example +(catalog:read (program-vicinity) "jacalcat") +@end example -@defvar *features* -Is a list of symbols denoting features supported in this implementation. -@var{*features*} can grow as modules are @code{require}d. -@var{*features*} must be defined by all implementations -(@pxref{Porting}). +@end deffn -Here are features which SLIB (@file{require.scm}) adds to -@var{*features*} when appropriate. +@noindent +For an application program there are three appropriate venues for +registering its catalog associations: @itemize @bullet @item -'inexact +in a @file{usercat} file in the directory where the program runs; or @item -'rational +in an @file{implcat} file in the @code{implementation-vicinity}; or @item -'real +in an application program directory; loaded by calling +@code{catalog:read}. +@end itemize + + +@node Compiling Scheme, , Catalog Vicinities, The Library System +@section Compiling Scheme + +To use Scheme compilers effectively with SLIB the compiler needs to +know which SLIB modules are to be compiled and which symbols are +exported from those modules. + +The procedures in this section automate the extraction of this +information from SLIB modules. They are guaranteed to work on SLIB +modules; to use them on other sources, those sources should follow +SLIB conventions. + +@menu +* Module Conventions:: +* Module Manifests:: +* Module Semantics:: +* Top-level Variable References:: +* Module Analysis:: +@end menu + +@node Module Conventions, Module Manifests, Compiling Scheme, Compiling Scheme +@subsection Module Conventions + +@itemize @bullet @item -'complex +All the top-level @code{require} commands have one quoted argument and +are positioned before other Scheme definitions and expressions in the +file. @item -'bignum +Any conditionally @code{require}d SLIB modules +@footnote{There are some functions with internal @code{require} calls +to delay loading modules until they are needed. While this reduces +startup latency for interpreters, it can produce headaches for +compilers.} +also appear at the beginning of their files conditioned on the feature +@cindex compiling +@code{compiling} using @code{require-if} +(@pxref{Require, require-if}). + +@example +(require 'logical) +(require 'multiarg/and-) +(require-if 'compiling 'sort) +(require-if 'compiling 'ciexyz) +@end example + +@item +Schmooz-style comments preceding a definition, identify that +definition as an exported identifier (@pxref{Schmooz}). For +non-schmooz files, putting @samp{;@@} at the beginning of the line +immediately preceding the definition (@code{define}, +@code{define-syntax}, or @code{defmacro}) suffices. + +@example +;@@ +(define (make-vicinity <pathname>) <pathname>) +@end example + +@item +Syntax (macro) definitions are grouped at the end of a module file. + +@item +Modules defining macros do not invoke those macros. SLIB macro +implementations are exempt from this rule. + +An example of how to expand macro invocations is: + +@example +(require 'macros-that-work) +(require 'yasos) +(require 'pprint-file) +(pprint-filter-file "collect.scm" macwork:expand) +@end example + @end itemize -For each item, @code{(provided? '@var{feature})} will return @code{#t} -if that feature is available, and @code{#f} if not. -@end defvar -@defvar *modules* -Is a list of pathnames denoting files which have been loaded. -@end defvar +@node Module Manifests, Module Semantics, Module Conventions, Compiling Scheme +@subsection Module Manifests -@defvar *catalog* -Is an association list of features (symbols) and pathnames which will -supply those features. The pathname can be either a string or a pair. -If pathname is a pair then the first element should be a macro feature -symbol, @code{source}, or @code{compiled}. The cdr of the pathname -should be either a string or a list. -@end defvar +@include manifest.txi -@noindent -In the following functions if the argument @var{feature} is not a symbol -it is assumed to be a pathname. -@defun provided? feature -Returns @code{#t} if @var{feature} is a member of @code{*features*} or -@code{*modules*} or if @var{feature} is supported by a file already -loaded and @code{#f} otherwise. -@end defun - -@deffn Procedure require feature -@var{feature} is a symbol. If @code{(provided? @var{feature})} is true -@code{require} returns. Otherwise, if @code{(assq @var{feature} -*catalog*)} is not @code{#f}, the associated files will be loaded and -@code{(provided? @var{feature})} will henceforth return @code{#t}. An -unspecified value is returned. If @var{feature} is not found in -@code{*catalog*}, then an error is signaled. - -@deffnx Procedure require pathname -@var{pathname} is a string. If @var{pathname} has not already been -given as an argument to @code{require}, @var{pathname} is loaded. An -unspecified value is returned. -@end deffn +@node Module Semantics, Top-level Variable References, Module Manifests, Compiling Scheme +@subsection Module Semantics -@deffn Procedure provide feature -Assures that @var{feature} is contained in @code{*features*} if -@var{feature} is a symbol and @code{*modules*} otherwise. -@end deffn +For the purpose of compiling Scheme code, each top-level +@code{require} makes the identifiers exported by its feature's module +@code{defined} (or defmacroed or defined-syntaxed) within the file +(being compiled) headed with those requires. -@defun require:feature->path feature -Returns @code{#t} if @var{feature} is a member of @code{*features*} or -@code{*modules*} or if @var{feature} is supported by a file already -loaded. Returns a path if one was found in @code{*catalog*} under the -feature name, and @code{#f} otherwise. The path can either be a string -suitable as an argument to load or a pair as described above for -*catalog*. -@end defun +Top-level occurrences of @code{require-if} make defined the exports +from the module named by the second argument @emph{if} the +@var{feature-expression} first argument is true in the target +environment. The target feature @code{compiling} should be provided +during this phase of compilation. +Non-top-level SLIB occurences of @code{require} and @code{require-if} +of quoted features can be ignored by compilers. The SLIB modules will +all have top-level constructs for those features. +@cindex aggregate +Note that aggregate catalog entries import more than one module. +Implementations of @code{require} may or may @emph{not} be transitive; +code which uses module exports without requiring the providing module +is in error. +In the SLIB modules @code{modular}, @code{batch}, @code{hash}, +@code{common-lisp-time}, @code{commutative-ring}, @code{charplot}, +@code{logical}, @code{common-list-functions}, @code{coerce} and +@code{break} there is code conditional on features being +@code{provided?}. Most are testing for the presence of features which +are intrinsic to implementations (inexacts, bignums, ...). -@node Vicinity, Configuration, Require, Built-in Support -@subsection Vicinity +In all cases these @code{provided?} tests can be evaluated at +compile-time using @code{feature-eval} +(@pxref{Feature, feature-eval}). The simplest way to compile these +constructs may be to treat @code{provided?} as a macro. + + +@node Top-level Variable References, Module Analysis, Module Semantics, Compiling Scheme +@subsection Top-level Variable References + +@include top-refs.txi + + + +@node Module Analysis, , Top-level Variable References, Compiling Scheme +@subsection Module Analysis + +@include vet.txi + + + +@node Universal SLIB Procedures, Scheme Syntax Extension Packages, The Library System, Top +@chapter Universal SLIB Procedures + +@noindent +The procedures described in these sections are supported by all +implementations as part of the @samp{*.init} files or by +@file{require.scm}. + +@menu +* Vicinity:: Pathname Management +* Configuration:: Characteristics of Scheme Implementation +* Input/Output:: Things not provided by the Scheme specs. +* System:: LOADing, EVALing, ERRORing, and EXITing +* Miscellany:: +@end menu + + +@node Vicinity, Configuration, Universal SLIB Procedures, Universal SLIB Procedures +@section Vicinity @noindent A vicinity is a descriptor for a place in the file system. Vicinities @@ -525,8 +715,17 @@ these procedures are file system dependent. @noindent These procedures are provided by all implementations. -@defun make-vicinity path -Returns the vicinity of @var{path} for use by @code{in-vicinity}. +@defun make-vicinity dirpath +Returns @var{dirpath} as a vicinity for use as first argument to +@code{in-vicinity}. +@end defun + +@defun pathname->vicinity path +Returns the vicinity containing @var{path}. +@example +(pathname->vicinity "/usr/local/lib/scm/Link.scm") + @result{} "/usr/local/lib/scm/" +@end example @end defun @defun program-vicinity @@ -567,6 +766,12 @@ returns @code{#f}. @c systems this is @samp{.scm}. @c @end defun +@defun vicinity:suffix? chr +Returns the @samp{#t} if @var{chr} is a vicinity suffix character; and +@code{#f} otherwise. Typical vicinity suffixes are @samp{/}, +@samp{:}, and @samp{\}, +@end defun + @defun in-vicinity vicinity filename Returns a filename suitable for use by @code{slib:load}, @code{slib:load-source}, @code{slib:load-compiled}, @@ -590,8 +795,8 @@ return a pathname of the subdirectory @var{name} of -@node Configuration, Input/Output, Vicinity, Built-in Support -@subsection Configuration +@node Configuration, Input/Output, Vicinity, Universal SLIB Procedures +@section Configuration @noindent These constants and procedures describe characteristics of the Scheme @@ -652,8 +857,8 @@ Writes the report to file @file{filename}. (slib:report) @result{} slib "@value{SLIBVERSION}" on scm "5b1" on unix -(implementation-vicinity) is "/home/jaffer/scm/" -(library-vicinity) is "/home/jaffer/slib/" +(implementation-vicinity) is "/usr/local/lib/scm/" +(library-vicinity) is "/usr/local/lib/slib/" (scheme-file-suffix) is ".scm" loaded *features* : trace alist qp sort @@ -663,7 +868,7 @@ implementation *features* : bignum complex real rational inexact vicinity ed getenv tmpnam abort transcript with-file - ieee-p1178 rev4-report rev4-optional-procedures hash + ieee-p1178 r4rs rev4-optional-procedures hash object-hash delay eval dynamic-wind multiarg-apply multiarg/and- logical defmacro string-port source current-time record @@ -671,127 +876,134 @@ implementation *features* : array dump char-ready? full-continuation system implementation *catalog* : - (i/o-extensions compiled "/home/jaffer/scm/ioext.so") + (i/o-extensions compiled "/usr/local/lib/scm/ioext.so") ... @end example @end defun -@node Input/Output, Legacy, Configuration, Built-in Support -@subsection Input/Output +@node Input/Output, System, Configuration, Universal SLIB Procedures +@section Input/Output @noindent These procedures are provided by all implementations. -@deffn Procedure file-exists? filename +@defun file-exists? filename Returns @code{#t} if the specified file exists. Otherwise, returns @code{#f}. If the underlying implementation does not support this feature then @code{#f} is always returned. -@end deffn +@end defun -@deffn Procedure delete-file filename +@defun delete-file filename Deletes the file specified by @var{filename}. If @var{filename} can not be deleted, @code{#f} is returned. Otherwise, @code{#t} is returned. +@end defun + +@defun open-file filename modes +@var{filename} should be a string naming a file. @code{open-file} +returns a port depending on the symbol @var{modes}: + +@table @r +@item r +an input port capable of delivering characters from the file. +@item rb +a @emph{binary} input port capable of delivering characters from the file. +@item w +an output port capable of writing characters to a new file by that name. +@item wb +a @emph{binary} output port capable of writing characters to a new file +by that name. +@end table + +If an implementation does not distinguish between binary and non-binary +files, then it must treat @r{rb} as @r{r} and @r{wb} as @r{w}. + +If the file cannot be opened, either #f is returned or an error is +signalled. For output, if a file with the given name already exists, +the effect is unspecified. +@end defun + +@defun port? obj +Returns @t{#t} if @var{obj} is an input or output port, otherwise +returns @t{#f}. +@end defun + +@deffn {Procedure} close-port port +Closes the file associated with @var{port}, rendering the @var{port} +incapable of delivering or accepting characters. + +@code{close-file} has no effect if the file has already been closed. +The value returned is unspecified. @end deffn -@deffn Procedure tmpnam +@defun call-with-open-ports proc ports @dots{} +@defunx call-with-open-ports ports @dots{} proc +@var{Proc} should be a procedure that accepts as many arguments as there +are @var{ports} passed to @code{call-with-open-ports}. +@code{call-with-open-ports} calls @var{proc} with @var{ports} @dots{}. +If @var{proc} returns, then the ports are closed automatically and the +value yielded by the @var{proc} is returned. If @var{proc} does not +return, then the ports will not be closed automatically unless it is +possible to prove that the ports will never again be used for a read or +write operation. +@end defun + +@defun tmpnam Returns a pathname for a file which will likely not be used by any other process. Successive calls to @code{(tmpnam)} will return different pathnames. -@end deffn +@end defun -@deffn Procedure current-error-port +@defun current-error-port Returns the current port to which diagnostic and error output is directed. -@end deffn +@end defun -@deffn Procedure force-output -@deffnx Procedure force-output port +@deffn {Procedure} force-output +@deffnx {Procedure} force-output port Forces any pending output on @var{port} to be delivered to the output device 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)}. @end deffn -@deffn Procedure output-port-width -@deffnx Procedure output-port-width port +@defun output-port-width +@defunx output-port-width port Returns the width of @var{port}, which defaults to @code{(current-output-port)} if absent. If the width cannot be determined 79 is returned. -@end deffn +@end defun -@deffn Procedure output-port-height -@deffnx Procedure output-port-height port +@defun output-port-height +@defunx output-port-height port Returns the height of @var{port}, which defaults to @code{(current-output-port)} if absent. If the height cannot be determined 24 is returned. -@end deffn - -@node Legacy, System, Input/Output, Built-in Support -@subsection Legacy - -These procedures are provided by all implementations. - -@defun identity x -@var{identity} returns its argument. - -Example: -@lisp -(identity 3) - @result{} 3 -(identity '(foo bar)) - @result{} (foo bar) -(map identity @var{lst}) - @equiv{} (copy-list @var{lst}) -@end lisp @end defun -@noindent -The following procedures were present in Scheme until R4RS -(@pxref{Notes, , Language changes ,r4rs, Revised(4) Scheme}). -They are provided by all SLIB implementations. - -@defvr Constant t -Derfined as @code{#t}. -@end defvr - -@defvr Constant nil -Defined as @code{#f}. -@end defvr - -@defun last-pair l -Returns the last pair in the list @var{l}. Example: -@lisp -(last-pair (cons 1 2)) - @result{} (1 . 2) -(last-pair '(1 2)) - @result{} (2) - @equiv{} (cons 2 '()) -@end lisp -@end defun -@node System, , Legacy, Built-in Support -@subsection System +@node System, Miscellany, Input/Output, Universal SLIB Procedures +@section System @noindent These procedures are provided by all implementations. -@deffn Procedure slib:load-source name +@deffn {Procedure} slib:load-source name Loads a file of Scheme source code from @var{name} with the default filename extension used in SLIB. For instance if the filename extension used in SLIB is @file{.scm} then @code{(slib:load-source "foo")} will load from file @file{foo.scm}. @end deffn -@deffn Procedure slib:load-compiled name +@deffn {Procedure} slib:load-compiled name On implementations which support separtely loadable compiled modules, loads a file of compiled code from @var{name} with the implementation's filename extension for compiled code appended. @end deffn -@deffn Procedure slib:load name +@deffn {Procedure} slib:load name Loads a file of Scheme source or compiled code from @var{name} with the appropriate suffixes appended. If both source and compiled code are present with the appropriate names then the implementation will load @@ -802,13 +1014,13 @@ If an implementation does not support compiled code then @code{slib:load} will be identical to @code{slib:load-source}. @end deffn -@deffn Procedure slib:eval obj +@deffn {Procedure} slib:eval obj @code{eval} returns the value of @var{obj} evaluated in the current top level environment. @ref{Eval} provides a more general evaluation facility. @end deffn -@deffn Procedure slib:eval-load filename eval +@deffn {Procedure} slib:eval-load filename eval @var{filename} should be a string. If filename names an existing file, the Scheme source code expressions and definitions are read from the file and @var{eval} called with them sequentially. The @@ -816,19 +1028,19 @@ file and @var{eval} called with them sequentially. The @code{current-input-port} and @code{current-output-port}. @end deffn -@deffn Procedure slib:warn arg1 arg2 @dots{} +@deffn {Procedure} slib:warn arg1 arg2 @dots{} Outputs a warning message containing the arguments. @end deffn -@deffn Procedure slib:error arg1 arg2 @dots{} +@deffn {Procedure} slib:error arg1 arg2 @dots{} Outputs an error message containing the arguments, aborts evaluation of the current form and responds in a system dependent way to the error. Typical responses are to abort the program or to enter a read-eval-print loop. @end deffn -@deffn Procedure slib:exit n -@deffnx Procedure slib:exit +@deffn {Procedure} slib:exit n +@deffnx {Procedure} slib:exit Exits from the Scheme session returning status @var{n} to the system. If @var{n} is omitted or @code{#t}, a success status is returned to the system (if possible). If @var{n} is @code{#f} a failure is returned to @@ -837,29 +1049,108 @@ returned to the system (if possible). If the Scheme session cannot exit an unspecified value is returned from @code{slib:exit}. @end deffn +@defun browse-url url +Web browsers have become so ubiquitous that programming languagues +should support a uniform interface to them. -@node About this manual, , Built-in Support, The Library System -@section About this manual +If a @samp{netscape} browser is running, @code{browse-url} causes the +browser to display the page specified by string @var{url} and returns +#t. -@itemize @bullet -@item -Entries that are labeled as Functions are called for their return -values. Entries that are labeled as Procedures are called primarily for -their side effects. +If the browser is not running, @code{browse-url} starts a browser +displaying the argument @var{url}. If the browser starts as a +background job, @code{browse-url} returns #t immediately; if the +browser starts as a foreground job, then @code{browse-url} returns #t +when the browser exits; otherwise it returns #f. +@end defun -@item -Examples in this text were produced using the @code{scm} Scheme -implementation. -@item -At the beginning of each section, there is a line that looks like -@ftindex feature -@code{(require 'feature)}. Include this line in your code prior to -using the package. -@end itemize +@node Miscellany, , System, Universal SLIB Procedures +@section Miscellany + +These procedures are provided by all implementations. + +@defun identity x +@var{identity} returns its argument. + +Example: +@lisp +(identity 3) + @result{} 3 +(identity '(foo bar)) + @result{} (foo bar) +(map identity @var{lst}) + @equiv{} (copy-list @var{lst}) +@end lisp +@end defun + +@subsection Mutual Exclusion + +@noindent +An @dfn{exchanger} is a procedure of one argument regulating mutually +@cindex exchanger +exclusive access to a resource. When a exchanger is called, its current +content is returned, while being replaced by its argument in an atomic +operation. +@defun make-exchanger obj -@node Scheme Syntax Extension Packages, Textual Conversion Packages, The Library System, Top +Returns a new exchanger with the argument @var{obj} as its initial +content. + +@example +(define queue (make-exchanger (list a))) +@end example + +A queue implemented as an exchanger holding a list can be protected from +reentrant execution thus: + +@example +(define (pop queue) + (let ((lst #f)) + (dynamic-wind + (lambda () (set! lst (queue #f))) + (lambda () (and lst (not (null? lst)) + (let ((ret (car lst))) + (set! lst (cdr lst)) + ret))) + (lambda () (and lst (queue lst)))))) + +(pop queue) @result{} a + +(pop queue) @result{} #f +@end example +@end defun + + +@subsection Legacy + +@noindent +The following procedures were present in Scheme until R4RS +(@pxref{Notes, , Language changes ,r4rs, Revised(4) Scheme}). +They are provided by all SLIB implementations. + +@defvr Constant t +Derfined as @code{#t}. +@end defvr + +@defvr Constant nil +Defined as @code{#f}. +@end defvr + +@defun last-pair l +Returns the last pair in the list @var{l}. Example: +@lisp +(last-pair (cons 1 2)) + @result{} (1 . 2) +(last-pair '(1 2)) + @result{} (2) + @equiv{} (cons 2 '()) +@end lisp +@end defun + + +@node Scheme Syntax Extension Packages, Textual Conversion Packages, Universal SLIB Procedures, Top @chapter Scheme Syntax Extension Packages @menu @@ -962,7 +1253,7 @@ Takes an R4RS expression, macro-expands it, evals the result of the macro expansion, and returns the result of the evaluation. @end defun -@deffn Procedure macro:load filename +@deffn {Procedure} macro:load filename @var{filename} should be a string. If filename names an existing file, the @code{macro:load} procedure reads Scheme source code expressions and definitions from the file and evaluates them sequentially. These source @@ -1076,8 +1367,8 @@ Side effects of @var{expression} will affect the top level environment. @end defun -@deffn Procedure macro:load filename -@deffnx Procedure macwork:load filename +@deffn {Procedure} macro:load filename +@deffnx {Procedure} macwork:load filename @var{filename} should be a string. If filename names an existing file, the @code{macro:load} procedure reads Scheme source code expressions and definitions from the file and evaluates them sequentially. These source @@ -1266,8 +1557,8 @@ Side effects of @var{expression} will affect the top level environment. @end defun -@deffn Procedure macro:load filename -@deffnx Procedure synclo:load filename +@deffn {Procedure} macro:load filename +@deffnx {Procedure} synclo:load filename @var{filename} should be a string. If filename names an existing file, the @code{macro:load} procedure reads Scheme source code expressions and definitions from the file and evaluates them sequentially. These @@ -1290,7 +1581,8 @@ report. The syntactic closures facility extends the BNF rule for @var{transformer spec} to allow a new keyword that introduces a -low-level macro transformer:@refill +low-level macro transformer: + @example @var{transformer spec} := (transformer @var{expression}) @end example @@ -1320,7 +1612,8 @@ closures facility. recursively constructed. A form is any expression, any definition, any syntactic keyword, or any syntactic closure. The variable name that appears in a @code{set!} special form is also a form. Examples of -forms:@refill +forms: + @lisp 17 #t @@ -1387,7 +1680,8 @@ the transformer, the @dfn{output form}, is automatically closed in the which the @code{transformer} expression occurred. For example, here is a definition of a push macro using -@code{syntax-rules}:@refill +@code{syntax-rules}: + @lisp (define-syntax push (syntax-rules () @@ -1416,7 +1710,8 @@ Some macros may be non-hygienic by design. For example, the following defines a loop macro that implicitly binds @code{exit} to an escape procedure. The binding of @code{exit} is intended to capture free references to @code{exit} in the body of the loop, so @code{exit} must -be left free when the body is closed:@refill +be left free when the body is closed: + @lisp (define-syntax loop (transformer @@ -1483,7 +1778,8 @@ transformed, call @var{procedure} on the current syntactic environment. in that same syntactic environment, in place of the form. An example will make this clear. Suppose we wanted to define a simple -@code{loop-until} keyword equivalent to@refill +@code{loop-until} keyword equivalent to + @lisp (define-syntax loop-until (syntax-rules () @@ -1530,7 +1826,8 @@ exposed to is the one just outside the @code{lambda} expression: before the user's identifier is added to the syntactic environment, but after the identifier loop has been added. @code{capture-syntactic-environment} captures exactly that environment -as follows:@refill +as follows: + @lisp (define-syntax loop-until (transformer @@ -1562,7 +1859,8 @@ and the @code{loop} and use them in the body of the @code{lambda}. A common use of @code{capture-syntactic-environment} is to get the -transformer environment of a macro transformer:@refill +transformer environment of a macro transformer: + @lisp (transformer (lambda (exp env) @@ -1582,7 +1880,8 @@ high-level @code{syntax-rules} facility. As discussed earlier, an identifier is either a symbol or an @dfn{alias}. An alias is implemented as a syntactic closure whose -@dfn{form} is an identifier:@refill +@dfn{form} is an identifier: + @lisp (make-syntactic-closure env '() 'a) @result{} an @dfn{alias} @@ -1607,7 +1906,8 @@ know the syntactic roles of the substituted input subforms. @defun identifier? object Returns @code{#t} if @var{object} is an identifier, otherwise returns -@code{#f}. Examples:@refill +@code{#f}. Examples: + @lisp (identifier? 'a) @result{} #t @@ -1647,7 +1947,7 @@ environments, and @var{identifier1} and @var{identifier2} must be identifiers. @code{identifier=?} returns @code{#t} if the meaning of @var{identifier1} in @var{environment1} is the same as that of @var{identifier2} in @var{environment2}, otherwise it returns @code{#f}. -Examples:@refill +Examples: @lisp (let-syntax @@ -1711,8 +2011,8 @@ Side effects of @var{expression} will affect the top level environment. @end defun -@deffn Procedure macro:load filename -@deffnx Procedure syncase:load filename +@deffn {Procedure} macro:load filename +@deffnx {Procedure} syncase:load filename @var{filename} should be a string. If filename names an existing file, the @code{macro:load} procedure reads Scheme source code expressions and definitions from the file and evaluates them sequentially. These @@ -1773,6 +2073,7 @@ To check operation of syntax-case get @lisp (require 'syntax-case) @ftindex syntax-case +@findex syncase:sanity-check (syncase:sanity-check) @end lisp @@ -1810,11 +2111,16 @@ know if there is some incompatibility that is not flagged as such. Send bug reports, comments, suggestions, and questions to Kent Dybvig (dyb @@ iuvax.cs.indiana.edu). -@subsection Note from maintainer +@subsection Note from SLIB maintainer + +@code{(require 'structure)} +@findex define-structure Included with the @code{syntax-case} files was @file{structure.scm} -which defines a macro @code{define-structure}. There is no -documentation for this macro and it is not used by any code in SLIB. +which defines a macro @code{define-structure}. I have no +documentation for this macro; it is not used by any other code in +SLIB. + @node Fluid-Let, Yasos, Syntax-Case Macros, Scheme Syntax Extension Packages @section Fluid-Let @@ -1952,7 +2258,7 @@ Used in an operation definition (of @var{self}) to invoke the identity. Also known as ``send-to-super''. @end deffn -@deffn Procedure print obj port +@deffn {Procedure} print obj port A default @code{print} operation is provided which is just @code{(format @var{port} @var{obj})} (@pxref{Format}) for non-instances and prints @var{obj} preceded by @samp{#<INSTANCE>} for instances. @@ -2014,14 +2320,14 @@ foo @result{} "foo" @end example @end deffn -@deffn Procedure add-setter getter setter +@deffn {Procedure} add-setter getter setter Add procedures @var{getter} and @var{setter} to the (inaccessible) list of valid setter/getter pairs. @var{setter} implements the store operation corresponding to the @var{getter} access operation for the relevant state. The return value is unspecified. @end deffn -@deffn Procedure remove-setter-for getter +@deffn {Procedure} remove-setter-for getter Removes the setter corresponding to the specified @var{getter} from the list of valid setters. The return value is unspecified. @end deffn @@ -2058,7 +2364,7 @@ value is unspecified. ((string? obj) (string-length obj)) ((char? obj) 1) (else - (error "Operation not supported: size" obj)))) + (slib:error "Operation not supported: size" obj)))) (define-predicate cell?) (define-operation (fetch obj)) @@ -2144,13 +2450,14 @@ value is unspecified. * Format:: Common-Lisp Format * Standard Formatted I/O:: Posix printf and scanf * Programs and Arguments:: -* HTML:: +* HTML:: Generating * HTML Tables:: Databases meet HTML * HTTP and CGI:: Serve WWW sites +* Parsing HTML:: 'html-for-each * URI:: Uniform Resource Identifier * Printing Scheme:: Nicely * Time and Date:: -* Vector Graphics:: +* NCBI-DNA:: DNA and protein sequences * Schmooz:: Documentation markup for Scheme programs @end menu @@ -2179,13 +2486,14 @@ procedures for higher level specification of rulesets. @menu * Precedence Parsing Overview:: +* Rule Types:: * Ruleset Definition and Use:: * Token definition:: * Nud and Led Definition:: * Grammar Rule Definition:: @end menu -@node Precedence Parsing Overview, Ruleset Definition and Use, Precedence Parsing, Precedence Parsing +@node Precedence Parsing Overview, Rule Types, Precedence Parsing, Precedence Parsing @subsection Precedence Parsing Overview @noindent @@ -2210,6 +2518,35 @@ missing input. @end itemize @noindent +@cindex binding power +The notion of @dfn{binding power} may be unfamiliar to those +accustomed to BNF grammars. + +@noindent +When two consecutive objects are parsed, the first might be the prefix +to the second, or the second might be a suffix of the first. +Comparing the left and right binding powers of the two objects decides +which way to interpret them. + +@noindent +Objects at each level of syntactic grouping have binding powers. + +@noindent +@cindex syntax tree +A syntax tree is not built unless the rules explicitly do so. The +call graph of grammar rules effectively instantiate the sytnax tree. + +@noindent +The JACAL symbolic math system +(@url{http://swissnet.ai.mit.edu/~jaffer/JACAL.html}) uses +@t{precedence-parse}. Its grammar definitions in the file +@file{jacal/English.scm} can serve as examples of use. + + +@node Rule Types, Ruleset Definition and Use, Precedence Parsing Overview, Precedence Parsing +@subsection Rule Types + +@noindent Here are the higher-level syntax types and an example of each. Precedence considerations are omitted for clarity. See @ref{Grammar Rule Definition} for full details. @@ -2279,7 +2616,7 @@ delimits the extent of the restfix operator @code{set}. @end deftp -@node Ruleset Definition and Use, Token definition, Precedence Parsing Overview, Precedence Parsing +@node Ruleset Definition and Use, Token definition, Rule Types, Precedence Parsing @subsection Ruleset Definition and Use @defvar *syn-defs* @@ -2405,6 +2742,16 @@ Is the string consisting of all characters between 0 and 255 for which @code{char-whitespace?} returns true. @end defvr +@noindent +For the purpose of reporting problems in error messages, this package +keeps track of the @dfn{current column}. When the column does not +simply track input characters, @code{tok:bump-column} can be used to +adjust the current-column. + +@defun tok:bump-column pos port +Adds @var{pos} to the current-column for input-port @var{port}. +@end defun + @node Nud and Led Definition, Grammar Rule Definition, Token definition, Precedence Parsing @subsection Nud and Led Definition @@ -2689,10 +3036,17 @@ The ruleset in effect before @var{tk} was parsed is restored; @node Format, Standard Formatted I/O, Precedence Parsing, Textual Conversion Packages @section Format (version 3.0) -@code{(require 'format)} +@ifset html +<A NAME="format"></A> +@end ifset +@c @code{(require 'format)} @ftindex format -@include fmtdoc.txi +@c @include fmtdoc.txi +The @file{format.scm} package was removed because it was not +reentrant. @url{http://swissnet.ai.mit.edu/~jaffer/SLIB.FAQ} explains +more about FORMAT's woes. + @node Standard Formatted I/O, Programs and Arguments, Format, Textual Conversion Packages @section Standard Formatted I/O @@ -2724,14 +3078,17 @@ Defined to be @code{(current-error-port)}. @node Standard Formatted Output, Standard Formatted Input, Standard Formatted I/O, Standard Formatted I/O @subsection Standard Formatted Output +@ifset html +<A NAME="printf"></A> +@end ifset @code{(require 'printf)} @ftindex printf -@deffn Procedure printf format arg1 @dots{} -@deffnx Procedure fprintf port format arg1 @dots{} -@deffnx Procedure sprintf str format arg1 @dots{} -@deffnx Procedure sprintf #f format arg1 @dots{} -@deffnx Procedure sprintf k format arg1 @dots{} +@deffn {Procedure} printf format arg1 @dots{} +@deffnx {Procedure} fprintf port format arg1 @dots{} +@deffnx {Procedure} sprintf str format arg1 @dots{} +@deffnx {Procedure} sprintf #f format arg1 @dots{} +@deffnx {Procedure} sprintf k format arg1 @dots{} Each function converts, formats, and outputs its @var{arg1} @dots{} arguments according to the control string @var{format} argument and @@ -3148,32 +3505,51 @@ This routine implements Posix command line argument parsing. Notice that returning values through global variables means that @code{getopt} is @emph{not} reentrant. +Obedience to Posix format for the @code{getopt} calls sows confusion. +Passing @var{argc} and @var{argv} as arguments while referencing +@var{optind} as a global variable leads to strange behavior, +especially when the calls to @code{getopt} are buried in other +procedures. + +Even in C, @var{argc} can be derived from @var{argv}; what purpose +does it serve beyond providing an opportunity for +@var{argv}/@var{argc} mismatch? Just such a mismatch existed for +years in a SLIB @code{getopt--} example. + +I have removed the @var{argc} and @var{argv} arguments to getopt +procedures; and replaced them with a global variable: + +@defvar *argv* +Define @var{*argv*} with a list of arguments before calling getopt +procedures. If you don't want the first (0th) element to be ignored, +set @var{*optind*} to 0 (after requiring getopt). +@end defvar + @defvar *optind* Is the index of the current element of the command line. It is initially one. In order to parse a new command line or reparse an old -one, @var{*opting*} must be reset. +one, @var{*optind*} must be reset. @end defvar @defvar *optarg* Is set by getopt to the (string) option-argument of the current option. @end defvar -@deffn Procedure getopt argc argv optstring -Returns the next option letter in @var{argv} (starting from +@defun getopt optstring +Returns the next option letter in @var{*argv*} (starting from @code{(vector-ref argv *optind*)}) that matches a letter in -@var{optstring}. @var{argv} is a vector or list of strings, the 0th of -which getopt usually ignores. @var{argc} is the argument count, usually -the length of @var{argv}. @var{optstring} is a string of recognized -option characters; if a character is followed by a colon, the option -takes an argument which may be immediately following it in the string or -in the next element of @var{argv}. - -@var{*optind*} is the index of the next element of the @var{argv} vector +@var{optstring}. @var{*argv*} is a vector or list of strings, the 0th +of which getopt usually ignores. @var{optstring} is a string of +recognized option characters; if a character is followed by a colon, +the option takes an argument which may be immediately following it in +the string or in the next element of @var{*argv*}. + +@var{*optind*} is the index of the next element of the @var{*argv*} vector to be processed. It is initialized to 1 by @file{getopt.scm}, and @code{getopt} updates it when it finishes with each element of -@var{argv}. +@var{*argv*}. -@code{getopt} returns the next option character from @var{argv} that +@code{getopt} returns the next option character from @var{*argv*} that matches a character in @var{optstring}, if there is one that matches. If the option takes an argument, @code{getopt} sets the variable @var{*optarg*} to the option-argument as follows: @@ -3181,15 +3557,15 @@ If the option takes an argument, @code{getopt} sets the variable @itemize @bullet @item If the option was the last character in the string pointed to by an -element of @var{argv}, then @var{*optarg*} contains the next element of -@var{argv}, and @var{*optind*} is incremented by 2. If the resulting -value of @var{*optind*} is greater than or equal to @var{argc}, this -indicates a missing option argument, and @code{getopt} returns an error -indication. +element of @var{*argv*}, then @var{*optarg*} contains the next element +of @var{*argv*}, and @var{*optind*} is incremented by 2. If the +resulting value of @var{*optind*} is greater than or equal to +@code{(length @var{*argv*})}, this indicates a missing option +argument, and @code{getopt} returns an error indication. @item Otherwise, @var{*optarg*} is set to the string following the option -character in that element of @var{argv}, and @var{*optind*} is +character in that element of @var{*argv*}, and @var{*optind*} is incremented by 1. @end itemize @@ -3251,11 +3627,11 @@ Example: (slib:exit) @end lisp -@end deffn +@end defun -@subsection Getopt-- +@subsection Getopt--- -@defun getopt-- argc argv optstring +@defun @code{getopt--} optstring The procedure @code{getopt--} is an extended version of @code{getopt} which parses @dfn{long option names} of the form @samp{--hold-the-onions} and @samp{--verbosity-level=extreme}. @@ -3269,22 +3645,21 @@ not returned as part of the option string. No information is passed to @code{getopt--} concerning which long options should be accepted or whether such options can take arguments. -If a long option did not have an argument, @code{*optarg} will be set to -@code{#f}. The caller is responsible for detecting and reporting +If a long option did not have an argument, @code{*optarg*} will be set +to @code{#f}. The caller is responsible for detecting and reporting errors. @example (define opts ":-:b:") -(define argc 5) -(define argv '("foo" "-b9" "--f1" "--2=" "--g3=35234.342" "--")) +(define *argv* '("foo" "-b9" "--f1" "--2=" "--g3=35234.342" "--")) (define *optind* 1) (define *optarg* #f) (require 'qp) @ftindex qp (do ((i 5 (+ -1 i))) ((zero? i)) - (define opt (getopt-- argc argv opts)) - (print *optind* opt *optarg*))) + (let ((opt (getopt-- opts))) + (print *optind* opt *optarg*))) @print{} 2 #\b "9" 3 "f1" #f @@ -3297,81 +3672,7 @@ errors. @node Command Line, Parameter lists, Getopt, Programs and Arguments @subsection Command Line -@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 -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 -@end defun - -@defun read-options-file filename -@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. -@end defun - +@include comparse.txi @node Parameter lists, Getopt Parameter lists, Command Line, Programs and Arguments @@ -3418,11 +3719,11 @@ If there are more than one @var{parameter-name} parameters, an error is signaled. @end deffn -@deffn Procedure adjoin-parameters! parameter-list parameter1 @dots{} +@deffn {Procedure} adjoin-parameters! parameter-list parameter1 @dots{} Returns @var{parameter-list} with @var{parameter1} @dots{} merged in. @end deffn -@deffn Procedure parameter-list-expand expanders parameter-list +@deffn {Procedure} parameter-list-expand expanders parameter-list @var{expanders} is a list of procedures whose order matches the order of the @var{parameter-name}s in the call to @code{make-parameter-list} which created @var{parameter-list}. For each non-false element of @@ -3487,171 +3788,13 @@ should appear. @node Getopt Parameter lists, Filenames, Parameter lists, Programs and Arguments @subsection Getopt Parameter lists -@code{(require 'getopt-parameters)} - -@deffn Function getopt->parameter-list argc argv 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 deffn - -@deffn Function getopt->arglist argc argv 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 deffn - -@noindent -These @code{getopt} functions can be used with SLIB relational -databases. For an example, @xref{Database Utilities, -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) - (getopt->parameter-list - 2 - '("cmd" "-?") - '(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=<number> - -n, --nary=<symbols> ... - -N, --nary1=<symbols> ... - -s, --single=<string> - --Flag - -B - -a <num2> ... - --Abs=<num3> ... - -ERROR: getopt->parameter-list "unrecognized option" "-?" -@end example +@include getparam.txi @node Filenames, Batch, Getopt Parameter lists, Programs and Arguments @subsection Filenames -@code{(require 'filename)} or @code{(require '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 -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 - -@example -@end example -@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. - -@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 -@end defun - -@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. - -@example -(replace-suffix "/usr/local/lib/slib/batch.scm" ".scm" ".c") -@result{} "/usr/local/lib/slib/batch.c" -@end example -@end defun +@include glob.txi @node Batch, , Filenames, Programs and Arguments @@ -3680,7 +3823,7 @@ dos @item vms @item -amigados +amigaos @item system @item @@ -3689,8 +3832,8 @@ system @end table @noindent -@file{batch.scm} uses 2 enhanced relational tables (@pxref{Database -Utilities}) to store information linking the names of +@file{batch.scm} uses 2 enhanced relational tables +(@pxref{Using Databases}) to store information linking the names of @code{operating-system}s to @code{batch-dialect}es. @defun batch:initialize! database @@ -3699,9 +3842,9 @@ the domain @code{operating-system} to the enhanced relational database @var{database}. @end defun -@defvar batch:platform +@defvar *operating-system* Is batch's best guess as to which operating-system it is running under. -@code{batch:platform} is set to @code{(software-type)} +@code{*operating-system*} is set to @code{(software-type)} (@pxref{Configuration}) unless @code{(software-type)} is @code{unix}, in which case finer distinctions are made. @end defvar @@ -3835,8 +3978,8 @@ tables added to @var{database} by @code{batch:initialize!}. Here is an example of the use of most of batch's procedures: @example -(require 'database-utilities) -@ftindex database-utilities +(require 'databases) +@ftindex databases (require 'parameters) @ftindex parameters (require 'batch) @@ -3848,8 +3991,8 @@ Here is an example of the use of most of batch's procedures: (batch:initialize! batch) (define my-parameters - (list (list 'batch-dialect (os->batch-dialect batch:platform)) - (list 'platform batch:platform) + (list (list 'batch-dialect (os->batch-dialect *operating-system*)) + (list 'operating-system *operating-system*) (list 'batch-port (current-output-port)))) ;gets filled in later (batch:call-with-output-script @@ -3883,7 +4026,7 @@ Here is an example of the use of most of batch's procedures: Produces the file @file{my-batch}: @example -#!/bin/sh +#! /bin/sh # "my-batch" script created by SLIB/batch Sun Oct 31 18:24:10 1999 # ================ Write file with C program. mv -f hello.c hello.c~ @@ -3925,13 +4068,19 @@ hello world @include db2html.txi -@node HTTP and CGI, URI, HTML Tables, Textual Conversion Packages +@node HTTP and CGI, Parsing HTML, HTML Tables, Textual Conversion Packages @section HTTP and CGI @include http-cgi.txi -@node URI, Printing Scheme, HTTP and CGI, Textual Conversion Packages +@node Parsing HTML, URI, HTTP and CGI, Textual Conversion Packages +@section Parsing HTML + +@include html4each.txi + + +@node URI, Printing Scheme, Parsing HTML, Textual Conversion Packages @section URI @include uri.txi @@ -3960,7 +4109,7 @@ prints it. The interface to the procedure is sufficiently general to easily implement other useful formatting procedures such as pretty printing, output to a string and truncated output. -@deffn Procedure generic-write obj display? width output +@deffn {Procedure} generic-write obj display? width output @table @var @item obj Scheme data value to transform. @@ -4012,8 +4161,8 @@ where @code{(require 'pretty-print)} @ftindex pretty-print -@deffn Procedure pretty-print obj -@deffnx Procedure pretty-print obj port +@deffn {Procedure} pretty-print obj +@deffnx {Procedure} pretty-print obj port @code{pretty-print}s @var{obj} on @var{port}. If @var{port} is not specified, @code{current-output-port} is used. @@ -4032,8 +4181,8 @@ Example: @end example @end deffn -@deffn Procedure pretty-print->string obj -@deffnx Procedure pretty-print->string obj width +@deffn {Procedure} pretty-print->string obj +@deffnx {Procedure} pretty-print->string obj width Returns the string of @var{obj} @code{pretty-print}ed in @var{width} columns. If @var{width} is not specified, @code{(output-port-width)} is @@ -4083,8 +4232,8 @@ Example: @code{(require 'pprint-file)} @ftindex pprint-file -@deffn Procedure pprint-file infile -@deffnx Procedure pprint-file infile outfile +@deffn {Procedure} pprint-file infile +@deffnx {Procedure} pprint-file infile outfile Pretty-prints all the code in @var{infile}. If @var{outfile} is specified, the output goes to @var{outfile}, otherwise it goes to @code{(current-output-port)}. @@ -4119,7 +4268,7 @@ thus can reduce loading time. The following will write into (pprint-filter-file "code.scm" defmacro:expand* "exp-code.scm") @end lisp -@node Time and Date, Vector Graphics, Printing Scheme, Textual Conversion Packages +@node Time and Date, NCBI-DNA, Printing Scheme, Textual Conversion Packages @section Time and Date @menu @@ -4244,6 +4393,12 @@ made of any timezone at any calendar time. @end defun +@defun tz:std-offset tz +@var{tz} is a time-zone object. @code{tz:std-offset} returns the +number of seconds west of the Prime Meridian timezone @var{tz} is. + +@end defun + @noindent The rest of these procedures and variables are provided for POSIX compatability. Because of shared state they are not thread-safe. @@ -4422,87 +4577,19 @@ match the arguments to @code{encode-universal-time}. @end defun -@node Vector Graphics, Schmooz, Time and Date, Textual Conversion Packages -@section Vector Graphics - -@menu -* Tektronix Graphics Support:: -@end menu - -@node Tektronix Graphics Support, , Vector Graphics, Vector Graphics -@subsection Tektronix Graphics Support - -@emph{Note:} The Tektronix graphics support files need more work, and -are not complete. - -@subsubsection Tektronix 4000 Series Graphics - -The Tektronix 4000 series graphics protocol gives the user a 1024 by -1024 square drawing area. The origin is in the lower left corner of the -screen. Increasing y is up and increasing x is to the right. - -The graphics control codes are sent over the current-output-port and can -be mixed with regular text and ANSI or other terminal control sequences. - -@deffn Procedure tek40:init -@end deffn - -@deffn Procedure tek40:graphics -@end deffn - -@deffn Procedure tek40:text -@end deffn - -@deffn Procedure tek40:linetype linetype -@end deffn - -@deffn Procedure tek40:move x y -@end deffn - -@deffn Procedure tek40:draw x y -@end deffn - -@deffn Procedure tek40:put-text x y str -@end deffn - -@deffn Procedure tek40:reset -@end deffn - - -@subsubsection Tektronix 4100 Series Graphics - -The graphics control codes are sent over the current-output-port and can -be mixed with regular text and ANSI or other terminal control sequences. - -@deffn Procedure tek41:init -@end deffn - -@deffn Procedure tek41:reset -@end deffn +@node NCBI-DNA, Schmooz, Time and Date, Textual Conversion Packages +@section NCBI-DNA -@deffn Procedure tek41:graphics -@end deffn - -@deffn Procedure tek41:move x y -@end deffn +@include ncbi-dna.txi -@deffn Procedure tek41:draw x y -@end deffn - -@deffn Procedure tek41:point x y number -@end deffn - -@deffn Procedure tek41:encode-x-y x y -@end deffn -@deffn Procedure tek41:encode-int number -@end deffn - -@node Schmooz, , Vector Graphics, Textual Conversion Packages +@node Schmooz, , NCBI-DNA, Textual Conversion Packages @section Schmooz @include schmooz.texi + + @node Mathematical Packages, Database Packages, Textual Conversion Packages, Top @chapter Mathematical Packages @@ -4512,12 +4599,14 @@ be mixed with regular text and ANSI or other terminal control sequences. * Prime Numbers:: 'factor * Random Numbers:: 'random * Fast Fourier Transform:: 'fft -* Cyclic Checksum:: 'make-crc -* Plotting:: 'charplot +* Cyclic Checksum:: 'crc +* Graphing:: +* Solid Modeling:: VRML97 +* Color:: * Root Finding:: 'root * Minimizing:: 'minimize * Commutative Rings:: 'commutative-ring -* Determinant:: 'determinant +* Matrix Algebra:: 'determinant @end menu @@ -4527,6 +4616,7 @@ be mixed with regular text and ANSI or other terminal control sequences. @code{(require 'logical)} @ftindex logical +@noindent The bit-twiddling functions are made available through the use of the @code{logical} package. @code{logical} is loaded by inserting @code{(require 'logical)} before the code that uses these @@ -4534,7 +4624,7 @@ The bit-twiddling functions are made available through the use of the functions. These functions behave as though operating on integers in two's-complement representation. -@subheading Bitwise Operations +@subsection Bitwise Operations @defun logand n1 n1 Returns the integer which is the bit-wise AND of the two integer @@ -4615,7 +4705,7 @@ Example: @end defun -@subheading Bit Within Word +@subsection Bit Within Word @defun logbit? index j @example @@ -4641,17 +4731,17 @@ Example: @end example @end defun -@subheading Fields of Bits +@subsection Fields of Bits + +@defun logical:ones n +Returns the smallest non-negative integer having @var{n} binary ones. +@end defun @defun bit-field n start end -@findex bit-extract Returns the integer composed of the @var{start} (inclusive) through @var{end} (exclusive) bits of @var{n}. The @var{start}th bit becomes the 0-th bit in the result. -This function was called @code{bit-extract} in previous versions of SLIB. -@refill - Example: @lisp (number->string (bit-field #b1101101010 0 4) 2) @@ -4676,9 +4766,9 @@ Example: @end example @end defun -@defun ash int count +@defun ash n count Returns an integer equivalent to -@code{(inexact->exact (floor (* @var{int} (expt 2 @var{count}))))}. +@code{(inexact->exact (floor (* @var{n} (expt 2 @var{count}))))}. Example: @lisp @@ -4715,89 +4805,121 @@ Example: @end lisp @end defun -@node Modular Arithmetic, Prime Numbers, Bit-Twiddling, Mathematical Packages -@section Modular Arithmetic +@subsection Bit order and Lamination -@code{(require 'modular)} -@ftindex modular +@defun logical:rotate k count len +Returns the low-order @var{len} bits of @var{k} cyclically permuted +@var{count} bits towards high-order. -@defun extended-euclid n1 n2 -Returns a list of 3 integers @code{(d x y)} such that d = gcd(@var{n1}, -@var{n2}) = @var{n1} * x + @var{n2} * y. +Example: +@lisp +(number->string (logical:rotate #b0100 3 4) 2) +@result{} "10" +(number->string (logical:rotate #b0100 -1 4) 2) +@result{} "10" +@end lisp @end defun -@defun symmetric:modulus n -Returns @code{(quotient (+ -1 n) -2)} for positive odd integer @var{n}. +@defun bit-reverse k n +Returns the low-order @var{k} bits of @var{n} with the bit order +reversed. The low-order bit of @var{n} is the high order bit of the +returned value. + +@example +(number->string (bit-reverse 8 #xa7) 16) + @result{} "e5" +@end example @end defun -@defun modulus->integer modulus -Returns the non-negative integer characteristic of the ring formed when -@var{modulus} is used with @code{modular:} procedures. +@defun integer->list k len +@defunx integer->list k +@code{integer->list} returns a list of @var{len} booleans corresponding +to each bit of the given integer. #t is coded for each 1; #f for 0. +The @var{len} argument defaults to @code{(integer-length @var{k})}. + +@defunx list->integer list +@code{list->integer} returns an integer formed from the booleans in the +list @var{list}, which must be a list of booleans. A 1 bit is coded for +each #t; a 0 bit for #f. + +@code{integer->list} and @code{list->integer} are inverses so far as +@code{equal?} is concerned. @end defun -@defun modular:normalize modulus n -Returns the integer @code{(modulo @var{n} (modulus->integer -@var{modulus}))} in the representation specified by @var{modulus}. +@defun booleans->integer bool1 @dots{} +Returns the integer coded by the @var{bool1} @dots{} arguments. @end defun -@noindent -The rest of these functions assume normalized arguments; That is, the -arguments are constrained by the following table: +@defun bitwise:laminate k1 @dots{} +Returns an integer composed of the bits of @var{k1} @dots{} interlaced +in argument order. Given @var{k1}, @dots{} @var{kn}, the n low-order +bits of the returned value will be the lowest-order bit of each +argument. -@noindent -For all of these functions, if the first argument (@var{modulus}) is: -@table @code -@item positive? -Work as before. The result is between 0 and @var{modulus}. +@defunx bitwise:delaminate count k +Returns a list of @var{count} integers comprised of every @var{count}h +bit of the integer @var{k}. -@item zero? -The arguments are treated as integers. An integer is returned. +For any non-negative integers @var{k} and @var{count}: +@example +(eqv? k (bitwise:laminate (bitwise:delaminate count k))) +@end example +@end defun -@item negative? -The arguments and result are treated as members of the integers modulo -@code{(+ 1 (* -2 @var{modulus}))}, but with @dfn{symmetric} -representation; i.e. @code{(<= (- @var{modulus}) @var{n} -@var{modulus})}. -@end table +@subsection Gray code + +@cindex Gray code @noindent -If all the arguments are fixnums the computation will use only fixnums. +A @dfn{Gray code} is an ordering of non-negative integers in which +exactly one bit differs between each pair of successive elements. There +are multiple Gray codings. An n-bit Gray code corresponds to a +Hamiltonian cycle on an n-dimensional hypercube. -@defun modular:invertable? modulus k -Returns @code{#t} if there exists an integer n such that @var{k} * n -@equiv{} 1 mod @var{modulus}, and @code{#f} otherwise. -@end defun +@noindent +Gray codes find use communicating incrementally changing values between +asynchronous agents. De-laminated Gray codes comprise the coordinates +of Peano-Hilbert space-filling curves. -@defun modular:invert modulus k2 -Returns an integer n such that 1 = (n * @var{k2}) mod @var{modulus}. If -@var{k2} has no inverse mod @var{modulus} an error is signaled. -@end defun -@defun modular:negate modulus k2 -Returns (@minus{}@var{k2}) mod @var{modulus}. -@end defun +@defun integer->gray-code k +Converts @var{k} to a Gray code of the same @code{integer-length} as +@var{k}. -@defun modular:+ modulus k2 k3 -Returns (@var{k2} + @var{k3}) mod @var{modulus}. -@end defun +@defunx gray-code->integer k +Converts the Gray code @var{k} to an integer of the same +@code{integer-length} as @var{k}. -@defun modular:@minus{} modulus k2 k3 -Returns (@var{k2} @minus{} @var{k3}) mod @var{modulus}. +For any non-negative integer @var{k}, +@example +(eqv? k (gray-code->integer (integer->gray-code k))) +@end example @end defun -@defun modular:* modulus k2 k3 -Returns (@var{k2} * @var{k3}) mod @var{modulus}. +@defun = k1 k2 +@defunx gray-code<? k1 k2 +@defunx gray-code>? k1 k2 +@defunx gray-code<=? k1 k2 +@defunx gray-code>=? k1 k2 +These procedures return #t if their Gray code arguments are +(respectively): equal, monotonically increasing, monotonically +decreasing, monotonically nondecreasing, or monotonically nonincreasing. -The Scheme code for @code{modular:*} with negative @var{modulus} is not -completed for fixnum-only implementations. +For any non-negative integers @var{k1} and @var{k2}, the Gray code +predicate of @code{(integer->gray-code k1)} and +@code{(integer->gray-code k2)} will return the same value as the +corresponding predicate of @var{k1} and @var{k2}. @end defun -@defun modular:expt modulus k2 k3 -Returns (@var{k2} ^ @var{k3}) mod @var{modulus}. -@end defun +@node Modular Arithmetic, Prime Numbers, Bit-Twiddling, Mathematical Packages +@section Modular Arithmetic + +@include modular.txi + + @node Prime Numbers, Random Numbers, Modular Arithmetic, Mathematical Packages @section Prime Numbers @@ -4811,9 +4933,6 @@ Returns (@var{k2} ^ @var{k3}) mod @var{modulus}. @node Random Numbers, Fast Fourier Transform, Prime Numbers, Mathematical Packages @section Random Numbers -@code{(require 'random)} -@ftindex random - @cindex RNG @cindex PRNG A pseudo-random number generator is only as good as the tests it passes. @@ -4822,18 +4941,25 @@ tests named @dfn{DIEHARD} (@url{http://stat.fsu.edu/~geo/diehard.html}). @file{diehard.c} has a bug which the patch @url{http://swissnet.ai.mit.edu/ftpdir/users/jaffer/diehard.c.pat} corrects. -SLIB's new PRNG generates 8 bits at a time. With the degenerate seed -@samp{0}, the numbers generated pass DIEHARD; but when bits are combined -from sequential bytes, tests fail. With the seed -@samp{http://swissnet.ai.mit.edu/~jaffer/SLIB.html}, all of those tests -pass. +SLIB's PRNG generates 8 bits at a time. With the degenerate seed +@samp{0}, the numbers generated pass DIEHARD; but when bits are +combined from sequential bytes, tests fail. With the seed +@samp{http://swissnet.ai.mit.edu/~jaffer/SLIB.html}, all of those +tests pass. + +@menu +* Exact Random Numbers:: 'random +* Inexact Random Numbers:: 'random-inexact +@end menu + +@node Exact Random Numbers, Inexact Random Numbers, Random Numbers, Random Numbers +@subsection Exact Random Numbers @include random.txi -If inexact numbers are supported by the Scheme implementation, -@file{randinex.scm} will be loaded as well. @file{randinex.scm} -contains procedures for generating inexact distributions. +@node Inexact Random Numbers, , Exact Random Numbers, Random Numbers +@subsection Inexact Random Numbers @include randinex.txi @@ -4841,172 +4967,1076 @@ contains procedures for generating inexact distributions. @node Fast Fourier Transform, Cyclic Checksum, Random Numbers, Mathematical Packages @section Fast Fourier Transform -@code{(require 'fft)} -@ftindex fft +@include fft.txi -@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}. -@defunx fft-1 array -@code{fft-1} returns an array of complex numbers comprising the inverse -Discrete Fourier Transform of @var{array}. -@end defun +@node Cyclic Checksum, Graphing, Fast Fourier Transform, Mathematical Packages +@section Cyclic Checksum -@code{(fft-1 (fft @var{array}))} will return an array of values close to -@var{array}. +@code{(require 'crc)} +@ftindex crc +@noindent +Cyclic Redundancy Checks using Galois field GF(2) polynomial +arithmetic are used for error detection in many data transmission +and storage applications. -@example -(fft '#(1 0+i -1 0-i 1 0+i -1 0-i)) @result{} +@noindent +The generator polynomials for various CRC protocols are availble +from many sources. But the polynomial is just one of many +parameters which must match in order for a CRC implementation to +interoperate with existing systems: + +@itemize @bullet -#(0.0 0.0 0.0+628.0783185208527e-18i 0.0 - 0.0 0.0 8.0-628.0783185208527e-18i 0.0) +@item +the byte-order and bit-order of the data stream; -(fft-1 '#(0 0 0 0 0 0 8 0)) @result{} +@item +whether the CRC or its inverse is being calculated; -#(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 +@item +the initial CRC value; and +@item +whether and where the CRC value is appended (inverted +or non-inverted) to the data stream. -@node Cyclic Checksum, Plotting, Fast Fourier Transform, Mathematical Packages -@section Cyclic Checksum +@end itemize + +@noindent +There is even some controversy over the polynomials themselves. + +@defvr Constant crc-32-polynomial +For CRC-32, http://www2.sis.pitt.edu/~jkabara/tele-2100/lect08.html +gives x^32+x^26+x^23+x^16+x^12+x^11+x^10+x^8+x^7+x^5+x^4+x^2+x^1+1. + +But +http://www.cs.ncl.ac.uk/people/harry.whitfield/home.formal/CRCs.html, +http://duchon.umuc.edu/Web_Pages/duchon/99_f_cm435/ShiftRegister.htm, +http://spinroot.com/spin/Doc/Book91_PDF/ch3.pdf, +http://www.erg.abdn.ac.uk/users/gorry/course/dl-pages/crc.html, +http://www.rad.com/networks/1994/err_con/crc_most.htm, and +http://www.gpfn.sk.ca/~rhg/csc8550s02/crc.html, +http://www.nobugconsulting.ro/crc.php give +x^32+x^26+x^23+x^22+x^16+x^12+x^11+x^10+x^8+x^7+x^5+x^4+x^2+x+1. + +SLIB @code{crc-32-polynomial} uses the latter definition. +@end defvr + +@defvr Constant crc-ccitt-polynomial + +http://www.math.grin.edu/~rebelsky/Courses/CS364/2000S/Outlines/outline.12.html, +http://duchon.umuc.edu/Web_Pages/duchon/99_f_cm435/ShiftRegister.htm, +http://www.cs.ncl.ac.uk/people/harry.whitfield/home.formal/CRCs.html, +http://www2.sis.pitt.edu/~jkabara/tele-2100/lect08.html, and +http://www.gpfn.sk.ca/~rhg/csc8550s02/crc.html give +CRC-CCITT: x^16+x^12+x^5+1. +@end defvr + +@defvr Constant crc-16-polynomial + +http://www.math.grin.edu/~rebelsky/Courses/CS364/2000S/Outlines/outline.12.html, +http://duchon.umuc.edu/Web_Pages/duchon/99_f_cm435/ShiftRegister.htm, +http://www.cs.ncl.ac.uk/people/harry.whitfield/home.formal/CRCs.html, +http://www.gpfn.sk.ca/~rhg/csc8550s02/crc.html, and +http://www.usb.org/developers/data/crcdes.pdf give +CRC-16: x^16+x^15+x^2+1. +@end defvr + +@defvr Constant crc-12-polynomial + +http://www.math.grin.edu/~rebelsky/Courses/CS364/2000S/Outlines/outline.12.html, +http://www.cs.ncl.ac.uk/people/harry.whitfield/home.formal/CRCs.html, +http://www.it.iitb.ac.in/it605/lectures/link/node4.html, and +http://spinroot.com/spin/Doc/Book91_PDF/ch3.pdf give +CRC-12: x^12+x^11+x^3+x^2+1. + +But +http://www.ffldusoe.edu/Faculty/Denenberg/Topics/Networks/Error_Detection_Correction/crc.html, +http://duchon.umuc.edu/Web_Pages/duchon/99_f_cm435/ShiftRegister.htm, +http://www.eng.uwi.tt/depts/elec/staff/kimal/errorcc.html, +http://www.ee.uwa.edu.au/~roberto/teach/itc314/java/CRC/, +http://www.gpfn.sk.ca/~rhg/csc8550s02/crc.html, and +http://www.efg2.com/Lab/Mathematics/CRC.htm give +CRC-12: x^12+x^11+x^3+x^2+x+1. + +These differ in bit 1 and calculations using them return different +values. With citations near evenly split, it is hard to know which is +correct. +@end defvr -@code{(require 'make-crc)} -@ftindex make-crc +@defvr Constant crc-10-polynomial + +http://www.math.grin.edu/~rebelsky/Courses/CS364/2000S/Outlines/outline.12.html gives +CRC-10: x^10+x^9+x^5+x^4+1; +but +http://cell-relay.indiana.edu/cell-relay/publications/software/CRC/crc10.html, +http://www.it.iitb.ac.in/it605/lectures/link/node4.html, +http://www.gpfn.sk.ca/~rhg/csc8550s02/crc.html, +http://www.techfest.com/networking/atm/atm.htm, +http://www.protocols.com/pbook/atmcell2.htm, and +http://www.nobugconsulting.ro/crc.php give +CRC-10: x^10+x^9+x^5+x^4+x+1. +@end defvr + +@defvr Constant crc-08-polynomial + +http://www.math.grin.edu/~rebelsky/Courses/CS364/2000S/Outlines/outline.12.html, +http://www.cs.ncl.ac.uk/people/harry.whitfield/home.formal/CRCs.html, +http://www.it.iitb.ac.in/it605/lectures/link/node4.html, and +http://www.nobugconsulting.ro/crc.php give +CRC-8: x^8+x^2+x^1+1 +@end defvr -@defun make-port-crc -@defunx make-port-crc degree -Returns an expression for a procedure of one argument, a port. This -procedure reads characters from the port until the end of file and -returns the integer checksum of the bytes read. +@defvr Constant atm-hec-polynomial -The integer @var{degree}, if given, specifies the degree of the -polynomial being computed -- which is also the number of bits computed -in the checksums. The default value is 32. +http://cell-relay.indiana.edu/cell-relay/publications/software/CRC/32bitCRC.tutorial.html and +http://www.gpfn.sk.ca/~rhg/csc8550s02/crc.html give +ATM HEC: x^8+x^2+x+1. +@end defvr -@defunx make-port-crc generator +@defvr Constant dowcrc-polynomial -The integer @var{generator} specifies the polynomial being computed. -The power of 2 generating each 1 bit is the exponent of a term of the -polynomial. The value of @var{generator} must be larger than 127. +http://www.cs.ncl.ac.uk/people/harry.whitfield/home.formal/CRCs.html gives +DOWCRC: x^8+x^5+x^4+1. +@end defvr + +@defvr Constant usb-token-polynomial + +http://www.usb.org/developers/data/crcdes.pdf and +http://www.nobugconsulting.ro/crc.php give +USB-token: x^5+x^2+1. +@end defvr + +@noindent +Each of these polynomial constants is a string of @samp{1}s and +@samp{0}s, the exponent of each power of @var{x} in descending order. -@defunx make-port-crc degree generator +@defun crc:make-table poly -The integer @var{generator} specifies the polynomial being computed. -The power of 2 generating each 1 bit is the exponent of a term of the -polynomial. The bit at position @var{degree} is implicit and should not -be part of @var{generator}. This allows systems with numbers limited to -32 bits to calculate 32 bit checksums. The default value of -@var{generator} when @var{degree} is 32 (its default) is: +@var{poly} must be string of @samp{1}s and @samp{0}s beginning with +@samp{1} and having length greater than 8. @code{crc:make-table} +returns a vector of 256 integers, such that: @example -(make-port-crc 32 #b00000100110000010001110110110111) +(set! @var{crc} + (logxor (ash (logand (+ -1 (ash 1 (- @var{deg} 8))) @var{crc}) 8) + (vector-ref @var{crc-table} + (logxor (ash @var{crc} (- 8 @var{deg})) @var{byte})))) @end example -Creates a procedure to calculate the P1003.2/D11.2 (POSIX.2) 32-bit -checksum from the polynomial: +will compute the @var{crc} with the 8 additional bits in @var{byte}; +where @var{crc} is the previous accumulated CRC value, @var{deg} is +the degree of @var{poly}, and @var{crc-table} is the vector returned +by @code{crc:make-table}. -@example - 32 26 23 22 16 12 11 - ( x + x + x + x + x + x + x + +If the implementation does not support @var{deg}-bit integers, then +@code{crc:make-table} returns #f. - 10 8 7 5 4 2 1 - x + x + x + x + x + x + x + 1 ) mod 2 -@end example @end defun -@example -(require 'make-crc) -@ftindex make-crc -(define crc32 (slib:eval (make-port-crc))) -(define (file-check-sum file) (call-with-input-file file crc32)) -(file-check-sum (in-vicinity (library-vicinity) "ratize.scm")) +@defun cksum file + +Computes the P1003.2/D11.2 (POSIX.2) 32-bit checksum of @var{file}. + +@example +(require 'crc) +@ftindex crc +(cksum (in-vicinity (library-vicinity) "ratize.scm")) @result{} 157103930 @end example -@node Plotting, Root Finding, Cyclic Checksum, Mathematical Packages -@section Plotting on Character Devices +@defunx cksum port +Computes the checksum of the bytes read from @var{port} until the +end-of-file. -@code{(require 'charplot)} -@ftindex charplot +@end defun + +@noindent +@cindex cksum-string +@code{cksum-string}, which returns the P1003.2/D11.2 (POSIX.2) 32-bit +checksum of the bytes in @var{str}, can be defined as follows: + +@example +(require 'string-port) +(define (cksum-string str) (call-with-input-string str cksum)) +@end example + +@defun crc16 file + +Computes the USB data-packet (16-bit) CRC of @var{file}. + +@defunx crc16 port +Computes the USB data-packet (16-bit) CRC of the bytes read from +@var{port} until the end-of-file. + +@code{crc16} calculates the same values as the crc16.pl program given +in http://www.usb.org/developers/data/crcdes.pdf. + +@end defun + +@defun crc5 file + +Computes the USB token (5-bit) CRC of @var{file}. + +@defunx crc5 port +Computes the USB token (5-bit) CRC of the bytes read from +@var{port} until the end-of-file. + +@code{crc5} calculates the same values as the crc5.pl program given +in http://www.usb.org/developers/data/crcdes.pdf. + +@end defun + +@node Graphing, Solid Modeling, Cyclic Checksum, Mathematical Packages +@section Graphing + +@menu +* Character Plotting:: +* PostScript Graphing:: +@end menu + +@node Character Plotting, PostScript Graphing, Graphing, Graphing +@subsection Character Plotting -The plotting procedure is made available through the use of the -@code{charplot} package. @code{charplot} is loaded by inserting -@code{(require 'charplot)} before the code that uses this procedure. +@code{(require 'charplot)} @ftindex charplot -@defvar charplot:height -The number of rows to make the plot vertically. -@end defvar +@defvar charplot:dimensions +A list of the maximum height (number of lines) and maximum width (number +of columns) for the graph, its scales, and labels. -@defvar charplot:width -The number of columns to make the plot horizontally. +The default value for @var{charplot:dimensions} is the +@code{output-port-height} and @code{output-port-width} of +@code{current-output-port}. @end defvar -@deffn Procedure plot! coords x-label y-label -@var{coords} is a list of pairs of x and y coordinates. @var{x-label} -and @var{y-label} are strings with which to label the x and y -axes. +@deffn {Procedure} 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. Example: @example (require 'charplot) @ftindex charplot -(set! charplot:height 19) -(set! charplot:width 45) +(set! charplot:dimensions '(20 55)) (define (make-points n) (if (zero? n) '() - (cons (cons (/ n 6) (sin (/ n 6))) (make-points (1- n))))) + (cons (list (/ n 6) (sin (/ n 6))) (make-points (1- n))))) -(plot! (make-points 37) "x" "Sin(x)") +(plot (make-points 40) "x" "Sin(x)") @print{} @group - Sin(x) ______________________________________________ - 1.25|- | - | | - 1|- **** | - | ** ** | - 0.75|- * * | - | * * | - 0.5|- * * | - | * | - 0.25|- * | - | * * | - 0|-------------------*--------------------------| - | * | - -0.25|- * * | - | * * | - -0.5|- * | - | * * | - -0.75|- * * | - | ** ** | - -1|- **** | - |____________:_____._____:_____._____:_________| - x 2 4 6 + Sin(x) _________________________________________ + 1|- **** | + | ** ** | + 0.75|- * * | + | * * | + 0.5|- * * | + | * *| + 0.25|- * * | + | * * | + 0|-------------------*------------------*--| + | * | + -0.25|- * * | + | * * | + -0.5|- * | + | * * | + -0.75|- * * | + | ** ** | + -1|- **** | + |:_____._____:_____._____:_____._____:____| + x 2 4 6 @end group @end example @end deffn -@deffn Procedure plot-function! func x1 x2 -@deffnx Procedure plot-function! func x1 x2 npts +@deffn {Procedure} plot func x1 x2 +@deffnx {Procedure} plot func x1 x2 npts Plots 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. + +@example +(plot sin 0 (* 2 pi)) +@print{} +@group + _________________________________________ + 1|-: **** | + | : ** ** | + 0.75|-: * * | + | : * * | + 0.5|-: ** ** | + | : * * | + 0.25|-:** ** | + | :* * | + 0|-*------------------*--------------------| + | : * * | + -0.25|-: ** ** | + | : * * | + -0.5|-: * ** | + | : * * | + -0.75|-: * ** | + | : ** ** | + -1|-: **** | + |_:_____._____:_____._____:_____._____:___| + 0 2 4 6 +@end group +@end example @end deffn +@deffn {Procedure} histograph data label +Creates and displays a histogram of the numerical values contained in +vector or list @var{data} + +@example +(require 'random-inexact) +(histograph (do ((idx 99 (+ -1 idx)) + (lst '() (cons (* .02 (random:normal)) lst))) + ((negative? idx) lst)) + "normal") +@print{} +@group + _________________________________________ + 8|- : I | + | : I | + 7|- I I : I | + | I I : I | + 6|- III I :I I | + | III I :I I | + 5|- IIIIIIIIII I | + | IIIIIIIIII I | + 4|- IIIIIIIIIIII | + | IIIIIIIIIIII | + 3|-I I I IIIIIIIIIIII II I | + | I I I IIIIIIIIIIII II I | + 2|-I I I IIIIIIIIIIIIIIIII I | + | I I I IIIIIIIIIIIIIIIII I | + 1|-II I I IIIIIIIIIIIIIIIIIIIII I I I | + | II I I IIIIIIIIIIIIIIIIIIIII I I I | + 0|-IIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIIII----| + |__.____:____.____:____.____:____.____:___| + normal -0.025 0 0.025 0.05 +@end group +@end example +@end deffn + + +@node PostScript Graphing, , Character Plotting, Graphing +@subsection PostScript Graphing + +@include grapheps.txi + + +@node Solid Modeling, Color, Graphing, Mathematical Packages +@section Solid Modeling + +@include solid.txi + + +@node Color, Root Finding, Solid Modeling, Mathematical Packages +@section Color + +@ifset html +<A NAME="Color"></A> +@end ifset + +@uref{http://swissnet.ai.mit.edu/~jaffer/Color} + +@noindent +The goals of this package are to provide methods to specify, compute, +and transform colors in a core set of additive color spaces. The color +spaces supported should be sufficient for working with the color data +encountered in practice and the literature. + +@menu +* Color Data-Type:: 'color +* Color Spaces:: XYZ, L*a*b*, L*u*v*, L*C*h, RGB709, sRGB +* Spectra:: Color Temperatures and CIEXYZ(1931) +* Color Difference Metrics:: Society of Dyers and Colorists +* Color Conversions:: Low-level +* Color Names:: in relational databases +* Daylight:: Sunlight and sky colors +@end menu + +@node Color Data-Type, Color Spaces, Color, Color +@subsection Color Data-Type + +@ifset html +<A NAME="Color_Data-Type"></A> +@end ifset +@code{(require 'color)} + +@defun color? obj +Returns #t if @var{obj} is a color. + +@defunx color? obj typ +Returns #t if @var{obj} is a color of color-space @var{typ}. The symbol +@var{typ} must be one of: + +@itemize @bullet +@item +CIEXYZ +@item +RGB709 +@item +L*a*b* +@item +L*u*v* +@item +sRGB +@item +e-sRGB +@item +L*C*h +@end itemize +@end defun + +@defun make-color space arg @dots{} +Returns a color of type @var{space}. +@end defun + +@defun color-space color +Returns the symbol for the color-space in which @var{color} is embedded. +@end defun + +@defun color-precision color +For colors in digital color-spaces, @code{color-precision} returns the +number of bits used for each of the R, G, and B channels of the +encoding. Otherwise, @code{color-precision} returns #f +@end defun + +@defun color-white-point color +Returns the white-point of @var{color} in all color-spaces except CIEXYZ. +@end defun + +@defun convert-color color space white-point +@defunx convert-color color space +@defunx convert-color color e-sRGB precision +Converts @var{color} into @var{space} at optional @var{white-point}. +@end defun + +@subsubsection External Representation + +@noindent +Each color encoding has an external, case-insensitive representation. +To ensure portability, the white-point for all color strings is D65. +@footnote{Readers may recognize these color string formats from Xlib. +X11's color management system was doomed by its fiction that CRT +monitors' (and X11 default) color-spaces were linear RGBi. Unable to +shed this legacy, the only practical way to view pictures on X is to +ignore its color management system and use an sRGB monitor. In this +implementation the device-independent RGB709 and sRGB spaces replace the +device-dependent RGBi and RGB spaces of Xlib.} + +@multitable @columnfractions .33 .66 +@item Color Space +@tab External Representation +@item CIEXYZ +@tab CIEXYZ:@i{<X>}/@i{<Y>}/@i{<Z>} +@item RGB709 +@tab RGBi:@i{<R>}/@i{<G>}/@i{<B>} +@item L*a*b* +@tab CIELAB:@i{<L>}/@i{<a>}/@i{<b>} +@item L*u*v* +@tab CIELuv:@i{<L>}/@i{<u>}/@i{<v>} +@item L*C*h +@tab CIELCh:@i{<L>}/@i{<C>}/@i{<h>} +@end multitable + +@noindent +The @var{X}, @var{Y}, @var{Z}, @var{L}, @var{a}, @var{b}, @var{u}, +@var{v}, @var{C}, @var{h}, @var{R}, @var{G}, and @var{B} fields are +(Scheme) real numbers within the appropriate ranges. + +@multitable @columnfractions .33 .66 +@item Color Space +@tab External Representation +@item sRGB +@tab sRGB:@i{<R>}/@i{<G>}/@i{<B>} +@item e-sRGB10 +@tab e-sRGB10:@i{<R>}/@i{<G>}/@i{<B>} +@item e-sRGB12 +@tab e-sRGB12:@i{<R>}/@i{<G>}/@i{<B>} +@item e-sRGB16 +@tab e-sRGB16:@i{<R>}/@i{<G>}/@i{<B>} +@end multitable + +@noindent +The @var{R}, @var{G}, and @var{B}, fields are non-negative exact decimal +integers within the appropriate ranges. + +@noindent +Several additional syntaxes are supported by @code{string->color}: + +@multitable @columnfractions .33 .66 +@item Color Space +@tab External Representation +@item sRGB +@tab sRGB:@i{<RRGGBB>} +@item sRGB +@tab #@i{<RRGGBB>} +@item sRGB +@tab 0x@i{<RRGGBB>} +@item sRGB +@tab #x@i{<RRGGBB>} +@end multitable + +Where @var{RRGGBB} is a non-negative six-digit hexadecimal number. + +@defun color->string color +Returns a string representation of @var{color}. +@end defun + +@defun string->color string +Returns the color represented by @var{string}. If @var{string} is not a +syntactically valid notation for a color, then @code{string->color} +returns #f. +@end defun + +@subsubsection White + +@noindent +We experience color relative to the illumination around us. +CIEXYZ coordinates, although subject to uniform scaling, are +objective. Thus other color spaces are specified relative to a +@cindex white point +@dfn{white point} in CIEXYZ coordinates. +@cindex white point + +@noindent +The white point for digital color spaces is set to D65. For the other +spaces a @var{white-point} argument can be specified. The default if +none is specified is the white-point with which the color was created +or last converted; and D65 if none has been specified. + +@defvr Constant D65 +Is the color of 6500.K (blackbody) illumination. D65 is close +to the average color of daylight. +@end defvr + +@defvr Constant D50 +Is the color of 5000.K (blackbody) illumination. D50 is the color of +indoor lighting by incandescent bulbs, whose filaments have +temperatures around 5000.K. +@end defvr + + +@node Color Spaces, Spectra, Color Data-Type, Color +@subsection Color Spaces + +@ifset html +<A NAME="Color_Spaces"></A> +@end ifset +@include color.txi + + + +@node Spectra, Color Difference Metrics, Color Spaces, Color +@subsection Spectra + +@ifset html +<A NAME="Spectra"></A> +@end ifset +@noindent +The following functions compute colors from spectra, scale color +luminance, and extract chromaticity. XYZ is used in the names of +procedures for unnormalized colors; the coordinates of CIEXYZ colors are +constrained as described in @ref{Color Spaces}. + +@code{(require 'color-space)} + +@noindent +A spectrum may be represented as: + +@itemize @bullet +@item +A procedure of one argument accepting real numbers from 380e-9 to +780e-9, the wavelength in meters; or +@item +A vector of real numbers representing intensity samples evenly spaced +over some range of wavelengths overlapping the range 380e-9 to 780e-9. +@end itemize + +@noindent +CIEXYZ values are calculated as dot-product with the X, Y (Luminance), +and Z @dfn{Spectral Tristimulus Values}. The files @file{cie1931.xyz} +and @file{cie1964.xyz} in the distribution contain these CIE-defined +values. +@cindex Spectral Tristimulus Values + +@deftp {Feature} cie1964 +@ftindex cie1964 +Loads the Spectral Tristimulus Values defining @cite{CIE 1964 +Supplementary Standard Colorimetric Observer}. +@deftpx {Feature} cie1931 +@ftindex cie1931 +Loads the Spectral Tristimulus Values defining @cite{CIE 1931 +Supplementary Standard Colorimetric Observer}. +@deftpx {Feature} ciexyz +@ftindex ciexyz +Requires Spectral Tristimulus Values, defaulting to cie1931. +@end deftp + +@noindent +@code{(require 'cie1964)} or @code{(require 'cie1931)} will +@findex load-ciexyz +@code{load-ciexyz} specific values used by the following spectrum +conversion procedures. The spectrum conversion procedures +@code{(require 'ciexyz)} to assure that a set is loaded. + +@defun spectrum->XYZ proc +@var{proc} must be a function of one argument. @code{spectrum->XYZ} +computes the CIEXYZ(1931) values for the spectrum returned by @var{proc} +when called with arguments from 380e-9 to 780e-9, the wavelength in +meters. + +@defunx spectrum->XYZ spectrum x1 x2 +@var{x1} and @var{x2} must be positive real numbers specifying the +wavelengths (in meters) corresponding to the zeroth and last elements of +vector or list @var{spectrum}. @code{spectrum->XYZ} returns the +CIEXYZ(1931) values for a light source with spectral values proportional +to the elements of @var{spectrum} at evenly spaced wavelengths between +@var{x1} and @var{x2}. + +Compute the colors of 6500.K and 5000.K blackbody radiation: + +@example +(require 'color-space) +(define xyz (spectrum->XYZ (blackbody-spectrum 6500))) +(define y_n (cadr xyz)) +(map (lambda (x) (/ x y_n)) xyz) + @result{} (0.9687111145512467 1.0 1.1210875945303613) + +(define xyz (spectrum->XYZ (blackbody-spectrum 5000))) +(map (lambda (x) (/ x y_n)) xyz) + @result{} (0.2933441826889158 0.2988931825387761 0.25783646831201573) +@end example + +@defunx spectrum->CIEXYZ proc +@defunx spectrum->CIEXYZ spectrum x1 x2 +@code{spectrum->CIEXYZ} computes the CIEXYZ(1931) values for the +spectrum, scaled so their sum is 1. +@end defun + +@defun spectrum->chromaticity proc +@defunx spectrum->chromaticity spectrum x1 x2 +Computes the chromaticity for the given spectrum. +@end defun + +@defun wavelength->XYZ w +@defunx wavelength->chromaticity w +@defunx wavelength->CIEXYZ w +@var{w} must be a number between 380e-9 to 780e-9. +@code{wavelength->XYZ} returns (unnormalized) XYZ values for a +monochromatic light source with wavelength @var{w}. +@code{wavelength->chromaticity} returns the chromaticity for a +monochromatic light source with wavelength @var{w}. +@code{wavelength->CIEXYZ} returns XYZ values for the saturated color +having chromaticity of a monochromatic light source with wavelength +@var{w}. +@end defun + +@defun blackbody-spectrum temp +@defunx blackbody-spectrum temp span +Returns a procedure of one argument (wavelength in meters), which +returns the radiance of a black body at @var{temp}. + +The optional argument @var{span} is the wavelength analog of bandwidth. +With the default @var{span} of 1.nm (1e-9.m), the values returned by the +procedure correspond to the power of the photons with wavelengths +@var{w} to @var{w}+1e-9. +@end defun + +@defun temperature->XYZ x +The positive number @var{x} is a temperature in degrees kelvin. +@code{temperature->XYZ} computes the CIEXYZ(1931) values for the +spectrum of a black body at temperature @var{x}. + +Compute the chromaticities of 6500.K and 5000.K blackbody radiation: + +@example +(require 'color-space) +(XYZ->chromaticity (temperature->XYZ 6500)) + @result{} (0.3135191660557008 0.3236456786200268) + +(XYZ->chromaticity (temperature->XYZ 5000)) + @result{} (0.34508082841161052 0.3516084965163377) +@end example +@end defun + +@defun temperature->CIEXYZ x +The positive number @var{x} is a temperature in degrees kelvin. +@code{temperature->CIEXYZ} computes the CIEXYZ(1931) values for the +spectrum of a black body at temperature @var{x}, scaled to be just +inside the RGB709 gamut. +@end defun + +@defun temperature->chromaticity x +@end defun + +@defun XYZ:normalize xyz +@var{xyz} is a list of three non-negative real numbers. +@code{XYZ:normalize} returns a list of numbers proportional to +@var{xyz}; scaled so their sum is 1. +@end defun + +@defun XYZ:normalize-colors colors @dots{} +@var{colors} is a list of XYZ triples. @code{XYZ:normalize-colors} +scales all the triples by a common factor such that the maximum sum of +numbers in a scaled triple is 1. +@end defun + +@defun XYZ->chromaticity xyz +Returns a two element list: the x and y components of @var{xyz} +normalized to 1 (= @var{x} + @var{y} + @var{z}). +@end defun + +@defun chromaticity->CIEXYZ x y +Returns the list of @var{x}, and @var{y}, 1 - @var{y} - @var{x}. +@end defun + +@defun chromaticity->whitepoint x y +Returns the CIEXYZ(1931) values having luminosity 1 and chromaticity +@var{x} and @var{y}. +@end defun + +@cindex xyY +@noindent +Many color datasets are expressed in @dfn{xyY} format; chromaticity with +CIE luminance (Y). But xyY is not a CIE standard like CIEXYZ, CIELAB, +and CIELUV. Although chrominance is well defined, the luminance +component is sometimes scaled to 1, sometimes to 100, but usually has no +obvious range. With no given whitepoint, the only reasonable course is +to ascertain the luminance range of a dataset and normalize the values +to lie from 0 to 1. + +@defun XYZ->xyY xyz +Returns a three element list: the @var{x} and @var{y} components of +@var{XYZ} normalized to 1, and CIE luminance @var{Y}. +@end defun + +@defun xyY->XYZ xyY +@end defun + +@defun xyY:normalize-colors colors +@var{colors} is a list of xyY triples. @code{xyY:normalize-colors} +scales each chromaticity so it sums to 1 or less; and divides the +@var{Y} values by the maximum @var{Y} in the dataset, so all lie between +0 and 1. + +@defunx xyY:normalize-colors colors n +If @var{n} is positive real, then @code{xyY:normalize-colors} divides +the @var{Y} values by @var{n} times the maximum @var{Y} in the dataset. + +If @var{n} is an exact non-positive integer, then +@code{xyY:normalize-colors} divides the @var{Y} values by the maximum of +the @var{Y}s in the dataset excepting the -@var{n} largest @var{Y} +values. + +In all cases, returned @var{Y} values are limited to lie from 0 to 1. +@end defun + +@noindent +Why would one want to normalize to other than 1? If the sun or its +reflection is the brightest object in a scene, then normalizing to its +luminance will tend to make the rest of the scene very dark. As with +photographs, limiting the specular highlights looks better than +darkening everything else. + +@noindent +The results of measurements being what they are, +@code{xyY:normalize-colors} is extremely tolerant. Negative numbers are +replaced with zero, and chromaticities with sums greater than one are +scaled to sum to one. + + +@node Color Difference Metrics, Color Conversions, Spectra, Color +@subsection Color Difference Metrics + +@ifset html +<A NAME="Color_Difference_Metrics"></A> +@end ifset + +@code{(require 'color-space)} + +The low-level metric functions operate on lists of 3 numbers, lab1, +lab2, lch1, or lch2. + +@code{(require 'color)} + +The wrapped functions operate on objects of type color, color1 and +color2 in the function entries. + +@defun L*a*b*:DE* lab1 lab2 +Returns the Euclidean distance between @var{lab1} and @var{lab2}. + +@defunx CIE:DE* color1 color2 white-point +@defunx CIE:DE* color1 color2 +Returns the Euclidean distance in L*a*b* space between @var{color1} and +@var{color2}. +@end defun + + +@defun L*C*h:DE*94 lch1 lch2 parametric-factors +@defunx L*C*h:DE*94 lch1 lch2 + +@defunx CIE:DE*94 color1 color2 parametric-factors +@defunx CIE:DE*94 color1 color2 + +Measures distance in the L*C*h cylindrical color-space. +The three axes are individually scaled (depending on C*) in their +contributions to the total distance. + +The CIE has defined reference conditions under which the metric with +default parameters can be expected to perform well. These are: + +@itemize @bullet +@item +The specimens are homogeneous in colour. +@item +The colour difference (CIELAB) is <= 5 units. +@item +They are placed in direct edge contact. +@item +Each specimen subtends an angle of >4 degrees to the assessor, whose +colour vision is normal. +@item +They are illuminated at 1000 lux, and viewed against a background of +uniform grey, with L* of 50, under illumination simulating D65. +@end itemize + +The @var{parametric-factors} argument is a list of 3 quantities kL, kC +and kH. @var{parametric-factors} independently adjust each +colour-difference term to account for any deviations from the reference +viewing conditions. Under the reference conditions explained above, the +default is kL = kC = kH = 1. +@end defun + + +@noindent +The Color Measurement Committee of The Society of Dyers and Colorists in +Great Britain created a more sophisticated color-distance function for +use in judging the consistency of dye lots. With CMC:DE* it is possible +to use a single value pass/fail tolerance for all shades. + +@defun CMC-DE lch1 lch2 parametric-factors +@defunx CMC-DE lch1 lch2 l c +@defunx CMC-DE lch1 lch2 l +@defunx CMC-DE lch1 lch2 + +@defunx CMC:DE* color1 color2 l c +@defunx CMC:DE* color1 color2 + +@code{CMC:DE} is a L*C*h metric. The @var{parametric-factors} +argument is a list of 2 numbers @var{l} and @var{c}. @var{l} and +@var{c} parameterize this metric. 1 and 1 are recommended for +perceptibility; the default, 2 and 1, for acceptability. +@end defun + + + +@node Color Conversions, Color Names, Color Difference Metrics, Color +@subsection Color Conversions + +@ifset html +<A NAME="Color_Conversions"></A> +@end ifset + +@noindent +This package contains the low-level color conversion and color metric +routines operating on lists of 3 numbers. There is no type or range +checking. + +@code{(require 'color-space)} + +@defvr Constant CIEXYZ:D65 +Is the color of 6500.K (blackbody) illumination. D65 is close to the +average color of daylight. +@end defvr + +@defvr Constant CIEXYZ:D50 +Is the color of 5000.K (blackbody) illumination. D50 is the color of +indoor lighting by incandescent bulbs. +@end defvr + +@defvr Constant CIEXYZ:A +@defvrx Constant CIEXYZ:B +@defvrx Constant CIEXYZ:C +@defvrx Constant CIEXYZ:E +CIE 1931 illuminants normalized to 1 = y. +@end defvr + +@defun color:linear-transform matrix row +@end defun + +@defun CIEXYZ->RGB709 xyz +@defunx RGB709->CIEXYZ srgb +@end defun + +@defun CIEXYZ->L*u*v* xyz white-point +@defunx CIEXYZ->L*u*v* xyz +@defunx L*u*v*->CIEXYZ L*u*v* white-point +@defunx L*u*v*->CIEXYZ L*u*v* +The @var{white-point} defaults to CIEXYZ:D65. +@end defun + +@defun CIEXYZ->L*a*b* xyz white-point +@defunx CIEXYZ->L*a*b* xyz +@defunx L*a*b*->CIEXYZ L*a*b* white-point +@defunx L*a*b*->CIEXYZ L*a*b* +The XYZ @var{white-point} defaults to CIEXYZ:D65. +@end defun + +@defun L*a*b*->L*C*h L*a*b* +@defunx L*C*h->L*a*b* L*C*h +@end defun + +@defun CIEXYZ->sRGB xyz +@defunx sRGB->CIEXYZ srgb +@end defun + +@defun CIEXYZ->xRGB xyz +@defunx xRGB->CIEXYZ srgb +@end defun + +@defun sRGB->xRGB xyz +@defunx xRGB->sRGB srgb +@end defun + +@defun CIEXYZ->e-sRGB n xyz +@defunx e-sRGB->CIEXYZ n srgb +@end defun + +@defun sRGB->e-sRGB n srgb +@defunx e-sRGB->sRGB n srgb +The integer @var{n} must be 10, 12, or 16. Because sRGB and e-sRGB use +the same RGB709 chromaticities, conversion between them is simpler than +conversion through CIEXYZ. +@end defun + +@noindent +Do not convert e-sRGB precision through @code{e-sRGB->sRGB} then +@code{sRGB->e-sRGB} -- values would be truncated to 8-bits! + +@defun e-sRGB->e-sRGB n1 srgb n2 +The integers @var{n1} and @var{n2} must be 10, 12, or 16. +@code{e-sRGB->e-sRGB} converts @var{srgb} to e-sRGB of precision +@var{n2}. +@end defun + + + +@node Color Names, Daylight, Color Conversions, Color +@subsection Color Names + +@ifset html +<A NAME="Color_Names"></A> +@end ifset +@include colornam.txi + +@include mkclrnam.txi + +@subsubheading The Short List + +@code{(require 'saturate)} +@ftindex saturate + +@defun saturate name +Looks for @var{name} among the 19 saturated colors from +@cite{Approximate Colors on CIE Chromaticity Diagram}: + +@multitable @columnfractions .25 .25 .25 .25 +@item reddish orange @tab orange @tab yellowish orange @tab yellow +@item greenish yellow @tab yellow green @tab yellowish green @tab green +@item bluish green @tab blue green @tab greenish blue @tab blue +@item purplish blue @tab bluish purple @tab purple @tab reddish purple +@item red purple @tab purplish red @tab red +@end multitable + +(@url{http://swissnet.ai.mit.edu/~jaffer/Color/saturate.pdf}). If +@var{name} is found, the corresponding color is returned. Otherwise #f +is returned. Use saturate only for light source colors. +@end defun + + +@noindent +Resene Paints Limited, New Zealand's largest privately-owned and +operated paint manufacturing company, has generously made their +@cite{Resene RGB Values List} available. + +@code{(require 'resene)} +@ftindex resene + +@defun resene name +Looks for @var{name} among the 1300 entries in the Resene color-name +dictionary (@url{http://swissnet.ai.mit.edu/~jaffer/Color/resene.pdf}). +If @var{name} is found, the corresponding color is returned. Otherwise +#f is returned. The @cite{Resene RGB Values List} is an excellent +source for surface colors. +@end defun + +@noindent +If you include the @dfn{Resene RGB Values List} in binary form in a +program, then you must include its license with your program: + +@quotation +Resene RGB Values List@* +For further information refer to http://www.resene.co.nz@* +Copyright Resene Paints Ltd 2001 + +Permission to copy this dictionary, 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. + +@enumerate +@item +Any text copy made of this dictionary must include this copyright +notice in full. + +@item +Any redistribution in binary form must reproduce this copyright +notice in the documentation or other materials provided with the +distribution. + +@item +Resene Paints Ltd makes no warranty or representation that this +dictionary is error-free, and is under no obligation to provide any +services, by way of maintenance, update, or otherwise. + +@item +There shall be no use of the name of Resene or Resene Paints Ltd +in any advertising, promotional, or sales literature without prior +written consent in each case. + +@item +These RGB colour formulations may not be used to the detriment of +Resene Paints Ltd. +@end enumerate +@end quotation + + +@node Daylight, , Color Names, Color +@subsection Daylight -@node Root Finding, Minimizing, Plotting, Mathematical Packages +@ifset html +<A NAME="Daylight"></A> +@end ifset +@include daylight.txi + + + +@node Root Finding, Minimizing, Color, Mathematical Packages @section Root Finding @code{(require 'root)} @ftindex root -@defun newtown:find-integer-root f df/dx x0 +@defun newton:find-integer-root f df/dx x0 Given integer valued procedure @var{f}, its derivative (with respect to its argument) @var{df/dx}, and initial integer value @var{x0} for which @var{df/dx}(@var{x0}) is non-zero, returns an integer @var{x} for which @@ -5119,7 +6149,7 @@ if the iteration should be stopped. @include minimize.txi -@node Commutative Rings, Determinant, Minimizing, Mathematical Packages +@node Commutative Rings, Matrix Algebra, Minimizing, Mathematical Packages @section Commutative Rings Scheme provides a consistent and capable set of numeric functions. @@ -5200,7 +6230,7 @@ the more restrictive Euclidean (Unique Factorization) Domain. @cindex Unique Factorization @cindex Euclidean Domain -@heading Rules and Rulesets +@section Rules and Rulesets The @dfn{commutative-ring} package allows control of ring properties through the use of @dfn{rulesets}. @@ -5234,10 +6264,12 @@ ruleset. Two rulesets are defined by this package. @defvr Constant distribute* -Contain the ruleset to distribute multiplication over addition and +Contains the ruleset to distribute multiplication over addition and subtraction. -@defvrx Constant distribute/ -Contain the ruleset to distribute division over addition and +@end defvr + +@defvr Constant distribute/ +Contains the ruleset to distribute division over addition and subtraction. Take care when using both @var{distribute*} and @var{distribute/} @@ -5281,7 +6313,7 @@ The following rule is the definition for distributing @code{*} over @end example @end defun -@heading How to Create a Commutative Ring +@section How to Create a Commutative Ring The first step in creating your commutative ring is to write procedures to create elements of the ring. A non-numeric element of the ring must @@ -5357,14 +6389,14 @@ Test the procedures to see if they work. (define (splice list1 list2) (cond ((eq? (last1 list1) (first list2)) (append list1 (cdr list2))) - (else (error 'splice list1 list2)))) + (else (slib:error 'splice list1 list2)))) ;;; where cyclicsplice is the result of leaving off the last element of ;;; splice(list1,list2). (define (cyclicsplice list1 list2) (cond ((and (eq? (last1 list1) (first list2)) (eq? (first list1) (last1 list2))) (butlast (splice list1 list2) 1)) - (else (error 'cyclicsplice list1 list2)))) + (else (slib:error 'cyclicsplice list1 list2)))) (N*N (S a b) (S a b)) @result{} (m a b) @end example @@ -5425,296 +6457,23 @@ Now we are ready to compute! (* (m a c e b g) (m d f))) @end example -@node Determinant, , Commutative Rings, Mathematical Packages -@section Determinant -@defun determinant square-matrix -Returns the determinant of @var{square-matrix}. +@node Matrix Algebra, , Commutative Rings, Mathematical Packages +@section Matrix Algebra -@example -(require 'determinant) -(determinant '((1 2) (3 4))) @result{} -2 -(determinant '((1 2 3) (4 5 6) (7 8 9))) @result{} 0 -(determinant '((1 2 3 4) (5 6 7 8) (9 10 11 12))) @result{} 0 -@end example -@end defun +@include determ.txi @node Database Packages, Other Packages, Mathematical Packages, Top @chapter Database Packages @menu -* Base Table:: * Relational Database:: 'relational-database +* Relational Infrastructure:: * Weight-Balanced Trees:: 'wt-tree @end menu -@node Base Table, Relational Database, Database Packages, Database Packages -@section Base Table - -A base table implementation using Scheme association lists is available -as the value of the identifier @code{alist-table} after doing: - -@code{(require 'alist-table)} -@ftindex alist-table - - -Association list base tables are suitable for small databases and -support all Scheme types when temporary and readable/writeable Scheme -types when saved. I hope support for other base table implementations -will be added in the future. - -This rest of this section documents the interface for a base table -implementation from which the @ref{Relational Database} package -constructs a Relational system. It will be of interest primarily to -those wishing to port or write new base-table implementations. - -All of these functions are accessed through a single procedure by -calling that procedure with the symbol name of the operation. A -procedure will be returned if that operation is supported and @code{#f} -otherwise. For example: - -@example -@group -(require 'alist-table) -@ftindex alist-table -(define open-base (alist-table 'make-base)) -make-base @result{} *a procedure* -(define foo (alist-table 'foo)) -foo @result{} #f -@end group -@end example - -@defun make-base filename key-dimension column-types -Returns a new, open, low-level database (collection of tables) -associated with @var{filename}. This returned database has an empty -table associated with @var{catalog-id}. The positive integer -@var{key-dimension} is the number of keys composed to make a -@var{primary-key} for the catalog table. The list of symbols -@var{column-types} describes the types of each column for that table. -If the database cannot be created as specified, @code{#f} is returned. - -Calling the @code{close-base} method on this database and possibly other -operations will cause @var{filename} to be written to. If -@var{filename} is @code{#f} a temporary, non-disk based database will be -created if such can be supported by the base table implelentation. -@end defun - -@defun open-base filename mutable -Returns an open low-level database associated with @var{filename}. If -@var{mutable?} is @code{#t}, this database will have methods capable of -effecting change to the database. If @var{mutable?} is @code{#f}, only -methods for inquiring the database will be available. If the database -cannot be opened as specified @code{#f} is returned. - -Calling the @code{close-base} (and possibly other) method on a -@var{mutable?} database will cause @var{filename} to be written to. -@end defun - -@defun write-base lldb filename -Causes the low-level database @var{lldb} to be written to -@var{filename}. If the write is successful, also causes @var{lldb} to -henceforth be associated with @var{filename}. Calling the -@code{close-database} (and possibly other) method on @var{lldb} may -cause @var{filename} to be written to. If @var{filename} is @code{#f} -this database will be changed to a temporary, non-disk based database if -such can be supported by the underlying base table implelentation. If -the operations completed successfully, @code{#t} is returned. -Otherwise, @code{#f} is returned. -@end defun - -@defun sync-base lldb -Causes the file associated with the low-level database @var{lldb} to be -updated to reflect its current state. If the associated filename is -@code{#f}, no action is taken and @code{#f} is returned. If this -operation completes successfully, @code{#t} is returned. Otherwise, -@code{#f} is returned. -@end defun - -@defun close-base lldb -Causes the low-level database @var{lldb} to be written to its associated -file (if any). If the write is successful, subsequent operations to -@var{lldb} will signal an error. If the operations complete -successfully, @code{#t} is returned. Otherwise, @code{#f} is returned. -@end defun - -@defun make-table lldb key-dimension column-types -Returns the @var{base-id} for a new base table, otherwise returns -@code{#f}. The base table can then be opened using @code{(open-table -@var{lldb} @var{base-id})}. The positive integer @var{key-dimension} is -the number of keys composed to make a @var{primary-key} for this table. -The list of symbols @var{column-types} describes the types of each -column. -@end defun - -@defvr Constant catalog-id -A constant @var{base-id} suitable for passing as a parameter to -@code{open-table}. @var{catalog-id} will be used as the base table for -the system catalog. -@end defvr - -@defun open-table lldb base-id key-dimension column-types -Returns a @var{handle} for an existing base table in the low-level -database @var{lldb} if that table exists and can be opened in the mode -indicated by @var{mutable?}, otherwise returns @code{#f}. - -As with @code{make-table}, the positive integer @var{key-dimension} is -the number of keys composed to make a @var{primary-key} for this table. -The list of symbols @var{column-types} describes the types of each -column. -@end defun - -@defun kill-table lldb base-id key-dimension column-types -Returns @code{#t} if the base table associated with @var{base-id} was -removed from the low level database @var{lldb}, and @code{#f} otherwise. -@end defun - -@defun make-keyifier-1 type -Returns a procedure which accepts a single argument which must be of -type @var{type}. This returned procedure returns an object suitable for -being a @var{key} argument in the functions whose descriptions follow. - -Any 2 arguments of the supported type passed to the returned function -which are not @code{equal?} must result in returned values which are not -@code{equal?}. -@end defun - -@defun make-list-keyifier key-dimension types -The list of symbols @var{types} must have at least @var{key-dimension} -elements. Returns a procedure which accepts a list of length -@var{key-dimension} and whose types must corresopond to the types named -by @var{types}. This returned procedure combines the elements of its -list argument into an object suitable for being a @var{key} argument in -the functions whose descriptions follow. - -Any 2 lists of supported types (which must at least include symbols and -non-negative integers) passed to the returned function which are not -@code{equal?} must result in returned values which are not -@code{equal?}. -@end defun - -@defun make-key-extractor key-dimension types column-number -Returns a procedure which accepts objects produced by application of the -result of @code{(make-list-keyifier @var{key-dimension} @var{types})}. -This procedure returns a @var{key} which is @code{equal?} to the -@var{column-number}th element of the list which was passed to create -@var{combined-key}. The list @var{types} must have at least -@var{key-dimension} elements. -@end defun - -@defun make-key->list key-dimension types -Returns a procedure which accepts objects produced by application of the -result of @code{(make-list-keyifier @var{key-dimension} @var{types})}. -This procedure returns a list of @var{key}s which are elementwise -@code{equal?} to the list which was passed to create @var{combined-key}. -@end defun - -@noindent -In the following functions, the @var{key} argument can always be assumed -to be the value returned by a call to a @emph{keyify} routine. - -@noindent -@cindex match-keys -@cindex match -@cindex wild-card -In contrast, a @var{match-keys} argument is a list of length equal to -the number of primary keys. The @var{match-keys} restrict the actions -of the table command to those records whose primary keys all satisfy the -corresponding element of the @var{match-keys} list. The elements and -their actions are: - -@quotation -@table @asis -@item @code{#f} -The false value matches any key in the corresponding position. -@item an object of type procedure -This procedure must take a single argument, the key in the corresponding -position. Any key for which the procedure returns a non-false value is -a match; Any key for which the procedure returns a @code{#f} is not. -@item other values -Any other value matches only those keys @code{equal?} to it. -@end table -@end quotation - -@noindent -The @var{key-dimension} and @var{column-types} arguments are needed to -decode the combined-keys for matching with @var{match-keys}. - -@defun for-each-key handle procedure key-dimension column-types match-keys -Calls @var{procedure} once with each @var{key} in the table opened in -@var{handle} which satisfy @var{match-keys} in an unspecified order. -An unspecified value is returned. -@end defun - -@defun map-key handle procedure key-dimension column-types match-keys -Returns a list of the values returned by calling @var{procedure} once -with each @var{key} in the table opened in @var{handle} which satisfy -@var{match-keys} in an unspecified order. -@end defun - -@defun ordered-for-each-key handle procedure key-dimension column-types match-keys -Calls @var{procedure} once with each @var{key} in the table opened in -@var{handle} which satisfy @var{match-keys} in the natural order for -the types of the primary key fields of that table. An unspecified value -is returned. -@end defun - -@defun delete* handle key-dimension column-types match-keys -Removes all rows which satisfy @var{match-keys} from the table opened in -@var{handle}. An unspecified value is returned. -@end defun - -@defun present? handle key -Returns a non-@code{#f} value if there is a row associated with -@var{key} in the table opened in @var{handle} and @code{#f} otherwise. -@end defun - -@defun delete handle key -Removes the row associated with @var{key} from the table opened in -@var{handle}. An unspecified value is returned. -@end defun - -@defun make-getter key-dimension types -Returns a procedure which takes arguments @var{handle} and @var{key}. -This procedure returns a list of the non-primary values of the relation -(in the base table opened in @var{handle}) whose primary key is -@var{key} if it exists, and @code{#f} otherwise. -@end defun - -@defun make-putter key-dimension types -Returns a procedure which takes arguments @var{handle} and @var{key} and -@var{value-list}. This procedure associates the primary key @var{key} -with the values in @var{value-list} (in the base table opened in -@var{handle}) and returns an unspecified value. -@end defun - -@defun supported-type? symbol -Returns @code{#t} if @var{symbol} names a type allowed as a column value -by the implementation, and @code{#f} otherwise. At a minimum, an -implementation must support the types @code{integer}, @code{symbol}, -@code{string}, @code{boolean}, and @code{base-id}. -@end defun - -@defun supported-key-type? symbol -Returns @code{#t} if @var{symbol} names a type allowed as a key value by -the implementation, and @code{#f} otherwise. At a minimum, an -implementation must support the types @code{integer}, and @code{symbol}. -@end defun - -@table @code -@item integer -Scheme exact integer. -@item symbol -Scheme symbol. -@item boolean -@code{#t} or @code{#f}. -@item base-id -Objects suitable for passing as the @var{base-id} parameter to -@code{open-table}. The value of @var{catalog-id} must be an acceptable -@code{base-id}. -@end table - -@node Relational Database, Weight-Balanced Trees, Base Table, Database Packages +@node Relational Database, Relational Infrastructure, Database Packages, Database Packages @section Relational Database @code{(require 'relational-database)} @@ -5725,271 +6484,84 @@ Model (@cite{E. F. Codd, A Relational Model of Data for Large Shared Data Banks}). An SLIB relational database implementation can be created from any @ref{Base Table} implementation. +Why relational database? For motivations and design issues see@* +@uref{http://swissnet.ai.mit.edu/~jaffer/DBManifesto.html}. + @menu -* Motivations:: Database Manifesto -* Creating and Opening Relational Databases:: -* Relational Database Operations:: +* Using Databases:: 'databases * Table Operations:: -* Catalog Representation:: -* Unresolved Issues:: -* Database Utilities:: 'database-utilities -* Database Reports:: +* Database Interpolation:: 'database-interpolate +* Embedded Commands:: 'database-commands +* Database Macros:: 'within-database * Database Browser:: 'database-browse @end menu -@node Motivations, Creating and Opening Relational Databases, Relational Database, Relational Database -@subsection Motivations - -Most nontrivial programs contain databases: Makefiles, configure -scripts, file backup, calendars, editors, source revision control, CAD -systems, display managers, menu GUIs, games, parsers, debuggers, -profilers, and even error reporting are all rife with databases. Coding -databases is such a common activity in programming that many may not be -aware of how often they do it. - -A database often starts as a dispatch in a program. The author, perhaps -because of the need to make the dispatch configurable, the need for -correlating dispatch in other routines, or because of changes or growth, -devises a data structure to contain the information, a routine for -interpreting that data structure, and perhaps routines for augmenting -and modifying the stored data. The dispatch must be converted into this -form and tested. - -The programmer may need to devise an interactive program for enabling -easy examination and modification of the information contained in this -database. Often, in an attempt to foster modularity and avoid delays in -release, intermediate file formats for the database information are -devised. It often turns out that users prefer modifying these -intermediate files with a text editor to using the interactive program -in order to do operations (such as global changes) not forseen by the -program's author. - -In order to address this need, the conscientious software engineer may -even provide a scripting language to allow users to make repetitive -database changes. Users will grumble that they need to read a large -manual and learn yet another programming language (even if it -@emph{almost} has language "xyz" syntax) in order to do simple -configuration. - -All of these facilities need to be designed, coded, debugged, -documented, and supported; often causing what was very simple in concept -to become a major developement project. - -This view of databases just outlined is somewhat the reverse of the view -of the originators of the @dfn{Relational Model} of database -abstraction. The relational model was devised to unify and allow -interoperation of large multi-user databases running on diverse -platforms. A fairly general purpose "Comprehensive Language" for -database manipulations is mandated (but not specified) as part of the -relational model for databases. - -One aspect of the Relational Model of some importance is that the -"Comprehensive Language" must be expressible in some form which can be -stored in the database. This frees the programmer from having to make -programs data-driven in order to use a database. - -This package includes as one of its basic supported types Scheme -@dfn{expression}s. This type allows expressions as defined by the -Scheme standards to be stored in the database. Using @code{slib:eval} -retrieved expressions can be evaluated (in the top-level environment). -Scheme's @code{lambda} facilitates closure of environments, modularity, -etc. so that procedures (which could not be stored directly most -databases) can still be effectively retrieved. Since @code{slib:eval} -evaluates expressions in the top-level environment, built-in and user -defined procedures can be easily accessed by name. - -This package's purpose is to standardize (through a common interface) -database creation and usage in Scheme programs. The relational model's -provision for inclusion of language expressions as data as well as the -description (in tables, of course) of all of its tables assures that -relational databases are powerful enough to assume the roles currently -played by thousands of ad-hoc routines and data formats. - -@noindent -Such standardization to a relational-like model brings many benefits: +@node Using Databases, Table Operations, Relational Database, Relational Database +@subsection Using Databases -@itemize @bullet -@item -Tables, fields, domains, and types can be dealt with by name in -programs. -@item -The underlying database implementation can be changed (for -performance or other reasons) by changing a single line of code. -@item -The formats of tables can be easily extended or changed without -altering code. -@item -Consistency checks are specified as part of the table descriptions. -Changes in checks need only occur in one place. -@item -All the configuration information which the developer wishes to group -together is easily grouped, without needing to change programs aware of -only some of these tables. -@item -Generalized report generators, interactive entry programs, and other -database utilities can be part of a shared library. The burden of -adding configurability to a program is greatly reduced. -@item -Scheme is the "comprehensive language" for these databases. Scripting -for configuration no longer needs to be in a separate language with -additional documentation. -@item -Scheme's latent types mesh well with the strict typing and logical -requirements of the relational model. -@item -Portable formats allow easy interchange of data. The included table -descriptions help prevent misinterpretation of format. -@end itemize +@include dbutil.txi -@node Creating and Opening Relational Databases, Relational Database Operations, Motivations, Relational Database -@subsection Creating and Opening Relational Databases -@defun make-relational-system base-table-implementation -Returns a procedure implementing a relational database using the -@var{base-table-implementation}. +@node Table Operations, Database Interpolation, Using Databases, Relational Database +@subsection Table Operations -All of the operations of a base table implementation are accessed -through a procedure defined by @code{require}ing that implementation. -Similarly, all of the operations of the relational database -implementation are accessed through the procedure returned by -@code{make-relational-system}. For instance, a new relational database -could be created from the procedure returned by -@code{make-relational-system} by: +@noindent +These are the descriptions of the methods available from an open +relational table. A method is retrieved from a table by calling +the table with the symbol name of the operation. For example: @example -(require 'alist-table) -@ftindex alist-table -(define relational-alist-system - (make-relational-system alist-table)) -(define create-alist-database - (relational-alist-system 'create-database)) -(define my-database - (create-alist-database "mydata.db")) +((plat 'get 'processor) 'djgpp) @result{} i386 @end example -@end defun @noindent -What follows are the descriptions of the methods available from -relational system returned by a call to @code{make-relational-system}. - -@defun create-database filename - -Returns an open, nearly empty relational database associated with -@var{filename}. The only tables defined are the system catalog and -domain table. Calling the @code{close-database} method on this database -and possibly other operations will cause @var{filename} to be written -to. If @var{filename} is @code{#f} a temporary, non-disk based database -will be created if such can be supported by the underlying base table -implelentation. If the database cannot be created as specified -@code{#f} is returned. For the fields and layout of descriptor tables, -@ref{Catalog Representation} -@end defun - -@defun open-database filename mutable? - -Returns an open relational database associated with @var{filename}. If -@var{mutable?} is @code{#t}, this database will have methods capable of -effecting change to the database. If @var{mutable?} is @code{#f}, only -methods for inquiring the database will be available. Calling the -@code{close-database} (and possibly other) method on a @var{mutable?} -database will cause @var{filename} to be written to. If the database -cannot be opened as specified @code{#f} is returned. -@end defun - -@node Relational Database Operations, Table Operations, Creating and Opening Relational Databases, Relational Database -@subsection Relational Database Operations +Some operations described below require primary key arguments. Primary +keys arguments are denoted @var{key1} @var{key2} @dots{}. It is an +error to call an operation for a table which takes primary key arguments +with the wrong number of primary keys for that table. -@noindent -These are the descriptions of the methods available from an open -relational database. A method is retrieved from a database by calling -the database with the symbol name of the operation. For example: +@defop {Operation} {relational-table} get column-name +Returns a procedure of arguments @var{key1} @var{key2} @dots{} which +returns the value for the @var{column-name} column of the row associated +with primary keys @var{key1}, @var{key2} @dots{} if that row exists in +the table, or @code{#f} otherwise. @example -(define my-database - (create-alist-database "mydata.db")) -(define telephone-table-desc - ((my-database 'create-table) 'telephone-table-desc)) +((plat 'get 'processor) 'djgpp) @result{} i386 +((plat 'get 'processor) 'be-os) @result{} #f @end example +@end defop -@defun close-database -Causes the relational database to be written to its associated file (if -any). If the write is successful, subsequent operations to this -database will signal an error. If the operations completed -successfully, @code{#t} is returned. Otherwise, @code{#f} is returned. -@end defun - -@defun write-database filename -Causes the relational database to be written to @var{filename}. If the -write is successful, also causes the database to henceforth be -associated with @var{filename}. Calling the @code{close-database} (and -possibly other) method on this database will cause @var{filename} to be -written to. If @var{filename} is @code{#f} this database will be -changed to a temporary, non-disk based database if such can be supported -by the underlying base table implelentation. If the operations -completed successfully, @code{#t} is returned. Otherwise, @code{#f} is -returned. -@end defun - -@defun sync-database -Causes any pending updates to the database file to be written out. If -the operations completed successfully, @code{#t} is returned. -Otherwise, @code{#f} is returned. -@end defun +@menu +* Single Row Operations:: +* Match-Keys:: +* Multi-Row Operations:: +* Indexed Sequential Access Methods:: +* Sequential Index Operations:: +* Table Administration:: +@end menu -@defun table-exists? table-name -Returns @code{#t} if @var{table-name} exists in the system catalog, -otherwise returns @code{#f}. -@end defun -@defun open-table table-name mutable? -Returns a @dfn{methods} procedure for an existing relational table in -this database if it exists and can be opened in the mode indicated by -@var{mutable?}, otherwise returns @code{#f}. -@end defun +@node Single Row Operations, Match-Keys, Table Operations, Table Operations +@subsubsection Single Row Operations @noindent -These methods will be present only in databases which are -@var{mutable?}. - -@defun delete-table table-name -Removes and returns the @var{table-name} row from the system catalog if -the table or view associated with @var{table-name} gets removed from the -database, and @code{#f} otherwise. -@end defun - -@defun create-table table-desc-name -Returns a methods procedure for a new (open) relational table for -describing the columns of a new base table in this database, otherwise -returns @code{#f}. For the fields and layout of descriptor tables, -@xref{Catalog Representation}. - -@defunx create-table table-name table-desc-name -Returns a methods procedure for a new (open) relational table with -columns as described by @var{table-desc-name}, otherwise returns -@code{#f}. -@end defun - -@defun create-view ?? -@defunx project-table ?? -@defunx restrict-table ?? -@defunx cart-prod-tables ?? -Not yet implemented. -@end defun - -@node Table Operations, Catalog Representation, Relational Database Operations, Relational Database -@subsection Table Operations +The term @dfn{row} used below refers to a Scheme list of values (one for +each column) in the order specified in the descriptor (table) for this +table. Missing values appear as @code{#f}. Primary keys must not +be missing. -@noindent -These are the descriptions of the methods available from an open -relational table. A method is retrieved from a table by calling -the table with the symbol name of the operation. For example: +@defop {Operation} {relational-table} row:insert +Adds the row @var{row} to this table. If a row for the primary key(s) +specified by @var{row} already exists in this table an error is +signaled. The value returned is unspecified. +@end defop @example @group (define telephone-table-desc ((my-database 'create-table) 'telephone-table-desc)) -(require 'common-list-functions) (define ndrp (telephone-table-desc 'row:insert)) (ndrp '(1 #t name #f string)) (ndrp '(2 #f telephone @@ -6004,43 +6576,80 @@ the table with the symbol name of the operation. For example: @end group @end example -@noindent -Some operations described below require primary key arguments. Primary -keys arguments are denoted @var{key1} @var{key2} @dots{}. It is an -error to call an operation for a table which takes primary key arguments -with the wrong number of primary keys for that table. - -@noindent -The term @dfn{row} used below refers to a Scheme list of values (one for -each column) in the order specified in the descriptor (table) for this -table. Missing values appear as @code{#f}. Primary keys must not -be missing. +@defop {Operation} {relational-table} row:update +Returns a procedure of one argument, @var{row}, which adds the row, +@var{row}, to this table. If a row for the primary key(s) specified by +@var{row} already exists in this table, it will be overwritten. The +value returned is unspecified. +@end defop -@defun get column-name +@defop {Operation} {relational-table} row:retrieve Returns a procedure of arguments @var{key1} @var{key2} @dots{} which -returns the value for the @var{column-name} column of the row associated -with primary keys @var{key1}, @var{key2} @dots{} if that row exists in -the table, or @code{#f} otherwise. +returns the row associated with primary keys @var{key1}, @var{key2} +@dots{} if it exists, or @code{#f} otherwise. +@end defop @example -((plat 'get 'processor) 'djgpp) @result{} i386 -((plat 'get 'processor) 'be-os) @result{} #f +((plat 'row:retrieve) 'linux) @result{} (linux i386 linux gcc) +((plat 'row:retrieve) 'multics) @result{} #f @end example -@defunx get* column-name +@defop {Operation} {relational-table} row:remove +Returns a procedure of arguments @var{key1} @var{key2} @dots{} which +removes and returns the row associated with primary keys @var{key1}, +@var{key2} @dots{} if it exists, or @code{#f} otherwise. +@end defop + +@defop {Operation} {relational-table} row:delete +Returns a procedure of arguments @var{key1} @var{key2} @dots{} which +deletes the row associated with primary keys @var{key1}, @var{key2} +@dots{} if it exists. The value returned is unspecified. +@end defop + + +@node Match-Keys, Multi-Row Operations, Single Row Operations, Table Operations +@subsubsection Match-Keys + +@noindent +@cindex match-keys +The (optional) @var{match-key1} @dots{} arguments are used to restrict +actions of a whole-table operation to a subset of that table. Those +procedures (returned by methods) which accept match-key arguments will +accept any number of match-key arguments between zero and the number of +primary keys in the table. Any unspecified @var{match-key} arguments +default to @code{#f}. + +@noindent +The @var{match-key1} @dots{} restrict the actions of the table command +to those records whose primary keys each satisfy the corresponding +@var{match-key} argument. The arguments and their actions are: + +@quotation +@table @asis +@item @code{#f} +The false value matches any key in the corresponding position. +@item an object of type procedure +This procedure must take a single argument, the key in the corresponding +position. Any key for which the procedure returns a non-false value is +a match; Any key for which the procedure returns a @code{#f} is not. +@item other values +Any other value matches only those keys @code{equal?} to it. +@end table +@end quotation + +@defop {Operation} {relational-table} get* column-name Returns a procedure of optional arguments @var{match-key1} @dots{} which returns a list of the values for the specified column for all rows in this table. The optional @var{match-key1} @dots{} arguments restrict -actions to a subset of the table. See the match-key description below -for details. +actions to a subset of the table. @example ((plat 'get* 'processor)) @result{} -(i386 8086 i386 8086 i386 i386 8086 m68000 +(i386 i8086 i386 i8086 i386 i386 i8086 m68000 m68000 m68000 m68000 m68000 powerpc) ((plat 'get* 'processor) #f) @result{} -(i386 8086 i386 8086 i386 i386 8086 m68000 +(i386 i8086 i386 i8086 i386 i386 i8086 m68000 m68000 m68000 m68000 m68000 powerpc) (define (a-key? key) @@ -6053,24 +6662,18 @@ for details. (atari-st-turbo-c atari-st-gcc amiga-sas/c-5.10 amiga-aztec amiga-dice-c aix) @end example -@end defun +@end defop -@defun row:retrieve -Returns a procedure of arguments @var{key1} @var{key2} @dots{} which -returns the row associated with primary keys @var{key1}, @var{key2} -@dots{} if it exists, or @code{#f} otherwise. -@example -((plat 'row:retrieve) 'linux) @result{} (linux i386 linux gcc) -((plat 'row:retrieve) 'multics) @result{} #f -@end example +@node Multi-Row Operations, Indexed Sequential Access Methods, Match-Keys, Table Operations +@subsubsection Multi-Row Operations -@defunx row:retrieve* -Returns a procedure of optional arguments @var{match-key1} @dots{} which -returns a list of all rows in this table. The optional @var{match-key1} -@dots{} arguments restrict actions to a subset of the table. See the -match-key description below for details. -@end defun +@defop {Operation} {relational-table} row:retrieve* +Returns a procedure of optional arguments @var{match-key1} @dots{} +which returns a list of all rows in this table. The optional +@var{match-key1} @dots{} arguments restrict actions to a subset of the +table. For details see @xref{Match-Keys}. +@end defop @example ((plat 'row:retrieve*) a-key?) @result{} @@ -6082,319 +6685,399 @@ match-key description below for details. (aix powerpc aix -)) @end example -@defun row:remove -Returns a procedure of arguments @var{key1} @var{key2} @dots{} which -removes and returns the row associated with primary keys @var{key1}, -@var{key2} @dots{} if it exists, or @code{#f} otherwise. - -@defunx row:remove* +@defop {Operation} {relational-table} row:remove* Returns a procedure of optional arguments @var{match-key1} @dots{} which removes and returns a list of all rows in this table. The optional @var{match-key1} @dots{} arguments restrict actions to a subset of the -table. See the match-key description below for details. -@end defun +table. +@end defop -@defun row:delete -Returns a procedure of arguments @var{key1} @var{key2} @dots{} which -deletes the row associated with primary keys @var{key1}, @var{key2} -@dots{} if it exists. The value returned is unspecified. +@defop {Operation} {relational-table} row:delete* +Returns a procedure of optional arguments @var{match-key1} @dots{} +which Deletes all rows from this table. The optional @var{match-key1} +@dots{} arguments restrict deletions to a subset of the table. The +value returned is unspecified. The descriptor table and catalog entry +for this table are not affected. +@end defop -@defunx row:delete* -Returns a procedure of optional arguments @var{match-key1} @dots{} which -Deletes all rows from this table. The optional @var{match-key1} @dots{} -arguments restrict deletions to a subset of the table. See the -match-key description below for details. The value returned is -unspecified. The descriptor table and catalog entry for this table are -not affected. -@end defun +@defop {Operation} {relational-table} for-each-row +Returns a procedure of arguments @var{proc} @var{match-key1} @dots{} +which calls @var{proc} with each @var{row} in this table. The +optional @var{match-key1} @dots{} arguments restrict actions to a +subset of the table. For details see @xref{Match-Keys}. +@end defop -@defun row:update -Returns a procedure of one argument, @var{row}, which adds the row, -@var{row}, to this table. If a row for the primary key(s) specified by -@var{row} already exists in this table, it will be overwritten. The -value returned is unspecified. +@noindent +Note that @code{row:insert*} and @code{row:update*} do @emph{not} use +match-keys. -@defunx row:update* +@defop {Operation} {relational-table} row:insert* Returns a procedure of one argument, @var{rows}, which adds each row in the list of rows, @var{rows}, to this table. If a row for the primary key specified by an element of @var{rows} already exists in this table, -it will be overwritten. The value returned is unspecified. -@end defun - -@defun row:insert -Adds the row @var{row} to this table. If a row for the primary key(s) -specified by @var{row} already exists in this table an error is -signaled. The value returned is unspecified. +an error is signaled. The value returned is unspecified. +@end defop -@defunx row:insert* +@defop {Operation} {relational-table} row:update* Returns a procedure of one argument, @var{rows}, which adds each row in the list of rows, @var{rows}, to this table. If a row for the primary key specified by an element of @var{rows} already exists in this table, -an error is signaled. The value returned is unspecified. -@end defun - -@defun for-each-row -Returns a procedure of arguments @var{proc} @var{match-key1} @dots{} -which calls @var{proc} with each @var{row} in this table in the -(implementation-dependent) natural ordering for rows. The optional -@var{match-key1} @dots{} arguments restrict actions to a subset of the -table. See the match-key description below for details. +it will be overwritten. The value returned is unspecified. +@end defop -@emph{Real} relational programmers would use some least-upper-bound join -for every row to get them in order; But we don't have joins yet. -@end defun -@noindent -@cindex match-keys -The (optional) @var{match-key1} @dots{} arguments are used to restrict -actions of a whole-table operation to a subset of that table. Those -procedures (returned by methods) which accept match-key arguments will -accept any number of match-key arguments between zero and the number of -primary keys in the table. Any unspecified @var{match-key} arguments -default to @code{#f}. +@node Indexed Sequential Access Methods, Sequential Index Operations, Multi-Row Operations, Table Operations +@subsubsection Indexed Sequential Access Methods @noindent -The @var{match-key1} @dots{} restrict the actions of the table command -to those records whose primary keys each satisfy the corresponding -@var{match-key} argument. The arguments and their actions are: - -@quotation -@table @asis -@item @code{#f} -The false value matches any key in the corresponding position. -@item an object of type procedure -This procedure must take a single argument, the key in the corresponding -position. Any key for which the procedure returns a non-false value is -a match; Any key for which the procedure returns a @code{#f} is not. -@item other values -Any other value matches only those keys @code{equal?} to it. -@end table -@end quotation - -@defun close-table -Subsequent operations to this table will signal an error. -@end defun - -@defvr Constant column-names -@defvrx Constant column-foreigns -@defvrx Constant column-domains -@defvrx Constant column-types -Return a list of the column names, foreign-key table names, domain -names, or type names respectively for this table. These 4 methods are -different from the others in that the list is returned, rather than a -procedure to obtain the list. - -@defvrx Constant primary-limit -Returns the number of primary keys fields in the relations in this -table. -@end defvr - -@node Catalog Representation, Unresolved Issues, Table Operations, Relational Database -@subsection Catalog Representation +@cindex ISAM +@dfn{Indexed Sequential Access Methods} are a way of arranging +database information so that records can be accessed both by key and +by key sequence (ordering). @dfn{ISAM} is not part of Codd's +relational model. Hardcore relational programmers might use some +least-upper-bound join for every row to get them into an order. @noindent -Each database (in an implementation) has a @dfn{system catalog} which -describes all the user accessible tables in that database (including -itself). +Associative memory in B-Trees is an example of a database +implementation which can support a native key ordering. SLIB's +@code{alist-table} implementation uses @code{sort} to implement +@code{for-each-row-in-order}, but does not support @code{isam-next} +and @code{isam-prev}. @noindent -The system catalog base table has the following fields. @code{PRI} -indicates a primary key for that table. +The multi-primary-key ordering employed by these operations is the +lexicographic collation of those primary-key fields in their given +order. For example: @example -@group -PRI table-name - column-limit the highest column number - coltab-name descriptor table name - bastab-id data base table identifier - user-integrity-rule - view-procedure A scheme thunk which, when called, - produces a handle for the view. coltab - and bastab are specified if and only if - view-procedure is not. -@end group +(12 a 34) < (12 a 36) < (12 b 1) < (13 a 0) @end example -@noindent -Descriptors for base tables (not views) are tables (pointed to by -system catalog). Descriptor (base) tables have the fields: -@example -@group -PRI column-number sequential integers from 1 - primary-key? boolean TRUE for primary key components - column-name - column-integrity-rule - domain-name -@end group -@end example +@node Sequential Index Operations, Table Administration, Indexed Sequential Access Methods, Table Operations +@subsubsection Sequential Index Operations @noindent -A @dfn{primary key} is any column marked as @code{primary-key?} in the -corresponding descriptor table. All the @code{primary-key?} columns -must have lower column numbers than any non-@code{primary-key?} columns. -Every table must have at least one primary key. Primary keys must be -sufficient to distinguish all rows from each other in the table. All of -the system defined tables have a single primary key. +The following procedures are individually optional depending on the +base-table implememtation. If an operation is @emph{not} supported, +then calling the table with that operation symbol will return false. -@noindent -This package currently supports tables having from 1 to 4 primary keys -if there are non-primary columns, and any (natural) number if @emph{all} -columns are primary keys. If you need more than 4 primary keys, I would -like to hear what you are doing! +@defop {Operation} {relational-table} for-each-row-in-order +Returns a procedure of arguments @var{proc} @var{match-key1} @dots{} +which calls @var{proc} with each @var{row} in this table in the +(implementation-dependent) natural, repeatable ordering for rows. The +optional @var{match-key1} @dots{} arguments restrict actions to a +subset of the table. For details see @xref{Match-Keys}. +@end defop -@noindent -A @dfn{domain} is a category describing the allowable values to occur in -a column. It is described by a (base) table with the fields: +@defop {Operation} {relational-table} isam-next +Returns a procedure of arguments @var{key1} @var{key2} @dots{} which +returns the key-list identifying the lowest record higher than +@var{key1} @var{key2} @dots{} which is stored in the relational-table; +or false if no higher record is present. -@example -@group -PRI domain-name - foreign-table - domain-integrity-rule - type-id - type-param -@end group -@end example +@defopx {Operation} {relational-table} isam-next column-name +The symbol @var{column-name} names a key field. In the list returned +by @code{isam-next}, that field, or a field to its left, will be +changed. This allows one to skip over less significant key fields. +@end defop -@noindent -The @dfn{type-id} field value is a symbol. This symbol may be used by -the underlying base table implementation in storing that field. +@defop {Operation} {relational-table} isam-prev +Returns a procedure of arguments @var{key1} @var{key2} @dots{} which +returns the key-list identifying the highest record less than +@var{key1} @var{key2} @dots{} which is stored in the relational-table; +or false if no lower record is present. -@noindent -If the @code{foreign-table} field is non-@code{#f} then that field names -a table from the catalog. The values for that domain must match a -primary key of the table referenced by the @var{type-param} (or -@code{#f}, if allowed). This package currently does not support -composite foreign-keys. +@defopx {Operation} {relational-table} isam-prev index +The symbol @var{column-name} names a key field. In the list returned +by @code{isam-next}, that field, or a field to its left, will be +changed. This allows one to skip over less significant key fields. +@end defop -@noindent -The types for which support is planned are: +For example, if a table has key fields: @example -@group - atom - symbol - string [<length>] - number [<base>] - money <currency> - date-time - boolean +(col1 col2) +(9 5) +(9 6) +(9 7) +(9 8) +(12 5) +(12 6) +(12 7) +@end example - foreign-key <table-name> - expression - virtual <expression> -@end group +Then: +@example +((table 'isam-next) '(9 5)) @result{} (9 6) +((table 'isam-next 'col2) '(9 5)) @result{} (9 6) +((table 'isam-next 'col1) '(9 5)) @result{} (12 5) +((table 'isam-prev) '(12 7)) @result{} (12 6) +((table 'isam-prev 'col2) '(12 7)) @result{} (12 6) +((table 'isam-prev 'col1) '(12 7)) @result{} (9 8) @end example -@node Unresolved Issues, Database Utilities, Catalog Representation, Relational Database -@subsection Unresolved Issues -Although @file{rdms.scm} is not large, I found it very difficult to -write (six rewrites). I am not aware of any other examples of a -generalized relational system (although there is little new in CS). I -left out several aspects of the Relational model in order to simplify -the job. The major features lacking (which might be addressed portably) -are views, transaction boundaries, and protection. +@node Table Administration, , Sequential Index Operations, Table Operations +@subsubsection Table Administration + +@defop {Operation} {relational-table} column-names +@defopx {Operation} {relational-table} column-foreigns +@defopx {Operation} {relational-table} column-domains +@defopx {Operation} {relational-table} column-types +Return a list of the column names, foreign-key table names, domain +names, or type names respectively for this table. These 4 methods are +different from the others in that the list is returned, rather than a +procedure to obtain the list. -Protection needs a model for specifying priveledges. Given how -operations are accessed from handles it should not be difficult to -restrict table accesses to those allowed for that user. +@defopx {Operation} {relational-table} primary-limit +Returns the number of primary keys fields in the relations in this +table. +@end defop -The system catalog has a field called @code{view-procedure}. This -should allow a purely functional implementation of views. This will -work but is unsatisfying for views resulting from a @dfn{select}ion -(subset of rows); for whole table operations it will not be possible to -reduce the number of keys scanned over when the selection is specified -only by an opaque procedure. +@defop {Operation} {relational-table} close-table +Subsequent operations to this table will signal an error. +@end defop -Transaction boundaries present the most intriguing area. Transaction -boundaries are actually a feature of the "Comprehensive Language" of the -Relational database and not of the database. Scheme would seem to -provide the opportunity for an extremely clean semantics for transaction -boundaries since the builtin procedures with side effects are small in -number and easily identified. +@node Database Interpolation, Embedded Commands, Table Operations, Relational Database +@subsection Database Interpolation -These side-effect builtin procedures might all be portably redefined to -versions which properly handled transactions. Compiled library routines -would need to be recompiled as well. Many system extensions -(delete-file, system, etc.) would also need to be redefined. +@code{(require 'database-interpolate)} @noindent -There are 2 scope issues that must be resolved for multiprocess -transaction boundaries: +Indexed sequential access methods allow finding the keys (having +associations) closest to a given value. This facilitates the +interpolation of associations between those in the table. -@table @asis -@item Process scope -The actions captured by a transaction should be only for the process -which invoked the start of transaction. Although standard Scheme does -not provide process primitives as such, @code{dynamic-wind} would -provide a workable hook into process switching for many implementations. -@item Shared utilities with state -Some shared utilities have state which should @emph{not} be part of a -transaction. An example would be calling a pseudo-random number -generator. If the success of a transaction depended on the -pseudo-random number and failed, the state of the generator would be set -back. Subsequent calls would keep returning the same number and keep -failing. - -Pseudo-random number generators are not reentrant; thus they would -require locks in order to operate properly in a multiprocess -environment. Are all examples of utilities whose state should not be -part of transactions also non-reentrant? If so, perhaps suspending -transaction capture for the duration of locks would solve this problem. -@end table +@defun interpolate-from-table table column +@var{Table} should be a relational table with one numeric primary key +field which supports the @code{isam-prev} and @code{isam-next} +operations. @var{column} should be a symbol or exact positive integer +designating a numerically valued column of @var{table}. + +@code{interpolate-from-table} calculates and returns a value +proportionally intermediate between its values in the next and +previous key records contained in @var{table}. For keys larger than +all the stored keys the value associated with the largest stored key +is used. For keys smaller than all the stored keys the value +associated with the smallest stored key is used. +@end defun -@node Database Utilities, Database Reports, Unresolved Issues, Relational Database -@subsection Database Utilities -@code{(require 'database-utilities)} -@ftindex database-utilities + +@node Embedded Commands, Database Macros, Database Interpolation, Relational Database +@subsection Embedded Commands + +@code{(require 'database-commands)} @noindent This enhancement wraps a utility layer on @code{relational-database} which provides: + @itemize @bullet @item -Automatic loading of the appropriate base-table package when opening a -database. -@item Automatic execution of initialization commands stored in database. @item Transparent execution of database commands stored in @code{*commands*} table in database. @end itemize -@noindent -Also included are utilities which provide: -@itemize @bullet -@item -Data definition from Scheme lists and -@item -Report generation -@end itemize -@noindent -for any SLIB relational database. +When an enhanced relational-database is called with a symbol which +matches a @var{name} in the @code{*commands*} table, the associated +procedure expression is evaluated and applied to the enhanced +relational-database. A procedure should then be returned which the user +can invoke on (optional) arguments. + +The command @code{*initialize*} is special. If present in the +@code{*commands*} table, @code{open-database} or @code{open-database!} +will return the value of the @code{*initialize*} command. Notice that +arbitrary code can be run when the @code{*initialize*} procedure is +automatically applied to the enhanced relational-database. + +Note also that if you wish to shadow or hide from the user +relational-database methods described in @ref{Database Operations}, this +can be done by a dispatch in the closure returned by the +@code{*initialize*} expression rather than by entries in the +@code{*commands*} table if it is desired that the underlying methods +remain accessible to code in the @code{*commands*} table. + + +@menu +* Database Extension:: +* Command Intrinsics:: +* Define-tables Example:: +* The *commands* Table:: +* Command Service:: +* Command Example:: +@end menu + + +@node Database Extension, Command Intrinsics, Embedded Commands, Embedded Commands +@subsubsection Database Extension + +@defun wrap-command-interface rdb +Returns relational database @var{rdb} wrapped with additional commands +defined in its *commands* table. +@end defun + +@defun add-command-tables rdb +The relational database @var{rdb} must be mutable. +@var{add-command-tables} adds a *command* table to @var{rdb}; then +returns @code{(wrap-command-interface @var{rdb})}. +@end defun + +@defun define-*commands* rdb spec-0 @dots{} + +Adds commands to the @code{*commands*} table as specified in +@var{spec-0} @dots{} to the open relational-database @var{rdb}. Each +@var{spec} has the form: + +@lisp +((@r{<name>} @r{<rdb>}) @r{"comment"} @r{<expression1>} @r{<expression2>} @dots{}) +@end lisp +or +@lisp +((@r{<name>} @r{<rdb>}) @r{<expression1>} @r{<expression2>} @dots{}) +@end lisp + +where @r{<name>} is the command name, @r{<rdb>} is a formal passed the +calling relational database, @r{"comment"} describes the +command, and @r{<expression1>}, @r{<expression1>}, @dots{} are the +body of the procedure. + +@code{define-*commands*} adds to the @code{*commands*} table a command +@r{<name>}: + +@lisp +(lambda (@r{<name>} @r{<rdb>}) @r{<expression1>} @r{<expression2>} @dots{}) +@end lisp -@defun create-database filename base-table-type -Returns an open, nearly empty enhanced (with @code{*commands*} table) -relational database (with base-table type @var{base-table-type}) -associated with @var{filename}. @end defun -@defun open-database filename -@defunx open-database filename base-table-type -Returns an open enchanced relational database associated with + +@defun open-command-database filename +@defunx open-command-database filename base-table-type +Returns an open enhanced relational database associated with @var{filename}. The database will be opened with base-table type @var{base-table-type}) if supplied. If @var{base-table-type} is not -supplied, @code{open-database} will attempt to deduce the correct +supplied, @code{open-command-database} will attempt to deduce the correct base-table-type. If the database can not be opened or if it lacks the @code{*commands*} table, @code{#f} is returned. -@defunx open-database! filename -@defunx open-database! filename base-table-type -Returns @emph{mutable} open enchanced relational database @dots{} +@defunx open-command-database! filename +@defunx open-command-database! filename base-table-type +Returns @emph{mutable} open enhanced relational database @dots{} + +@defunx open-command-database database +Returns @var{database} if it is an immutable relational database; #f +otherwise. + +@defunx open-command-database! database +Returns @var{database} if it is a mutable relational database; #f +otherwise. @end defun + +@node Command Intrinsics, Define-tables Example, Database Extension, Embedded Commands +@subsubsection Command Intrinsics + +Some commands are defined in all extended relational-databases. The are +called just like @ref{Database Operations}. + +@defop {Operation} {relational-database} add-domain domain-row +Adds @var{domain-row} to the @dfn{domains} table if there is no row in +the domains table associated with key @code{(car @var{domain-row})} and +returns @code{#t}. Otherwise returns @code{#f}. + +For the fields and layout of the domain table, @xref{Catalog +Representation}. Currently, these fields are +@itemize @bullet +@item +domain-name +@item +foreign-table +@item +domain-integrity-rule +@item +type-id +@item +type-param +@end itemize + +The following example adds 3 domains to the @samp{build} database. +@samp{Optstring} is either a string or @code{#f}. @code{filename} is a +string and @code{build-whats} is a symbol. + +@example +(for-each (build 'add-domain) + '((optstring #f + (lambda (x) (or (not x) (string? x))) + string + #f) + (filename #f #f string #f) + (build-whats #f #f symbol #f))) +@end example +@end defop + +@defop {Operation} {relational-database} delete-domain domain-name +Removes and returns the @var{domain-name} row from the @dfn{domains} +table. +@end defop + +@defop {Operation} {relational-database} domain-checker domain +Returns a procedure to check an argument for conformance to domain +@var{domain}. +@end defop + + +@node Define-tables Example, The *commands* Table, Command Intrinsics, Embedded Commands +@subsubsection Define-tables Example + +@noindent +The following example shows a new database with the name of +@file{foo.db} being created with tables describing processor families +and processor/os/compiler combinations. The database is then +solidified; saved and changed to immutable. + +@example +(require 'databases) +@ftindex databases +(define my-rdb (create-database "foo.db" 'alist-table)) +(define-tables my-rdb + '(processor-family + ((family atom)) + ((also-ran processor-family)) + ((m68000 #f) + (m68030 m68000) + (i386 i8086) + (i8086 #f) + (powerpc #f))) + + '(platform + ((name symbol)) + ((processor processor-family) + (os symbol) + (compiler symbol)) + ((aix powerpc aix -) + (amiga-dice-c m68000 amiga dice-c) + (amiga-aztec m68000 amiga aztec) + (amiga-sas/c-5.10 m68000 amiga sas/c) + (atari-st-gcc m68000 atari gcc) + (atari-st-turbo-c m68000 atari turbo-c) + (borland-c-3.1 i8086 ms-dos borland-c) + (djgpp i386 ms-dos gcc) + (linux i386 linux gcc) + (microsoft-c i8086 ms-dos microsoft-c) + (os/2-emx i386 os/2 gcc) + (turbo-c-2 i8086 ms-dos turbo-c) + (watcom-9.0 i386 ms-dos watcom)))) + +(solidify-database my-rdb) +@end example + + +@node The *commands* Table, Command Service, Define-tables Example, Embedded Commands +@subsubsection The *commands* Table + @noindent The table @code{*commands*} in an @dfn{enhanced} relational-database has the fields (with domains): @@ -6417,7 +7100,7 @@ plain-text queries) can operate from the same table. A @code{parameter-list} table has the following fields: @example @group -PRI index uint +PRI index ordinal name symbol arity parameter-arity domain domain @@ -6458,26 +7141,9 @@ Note that since the @code{defaulter} procedure is called every time a default parameter is needed for this column, @dfn{sticky} defaults can be implemented using shared state with the domain-integrity-rule. -@subsubheading Invoking Commands -When an enhanced relational-database is called with a symbol which -matches a @var{name} in the @code{*commands*} table, the associated -procedure expression is evaluated and applied to the enhanced -relational-database. A procedure should then be returned which the user -can invoke on (optional) arguments. - -The command @code{*initialize*} is special. If present in the -@code{*commands*} table, @code{open-database} or @code{open-database!} -will return the value of the @code{*initialize*} command. Notice that -arbitrary code can be run when the @code{*initialize*} procedure is -automatically applied to the enhanced relational-database. - -Note also that if you wish to shadow or hide from the user -relational-database methods described in @ref{Relational Database -Operations}, this can be done by a dispatch in the closure returned by -the @code{*initialize*} expression rather than by entries in the -@code{*commands*} table if it is desired that the underlying methods -remain accessible to code in the @code{*commands*} table. +@node Command Service, Command Example, The *commands* Table, Embedded Commands +@subsubsection Command Service @defun make-command-server rdb table-name Returns a procedure of 2 arguments, a (symbol) command and a call-back @@ -6518,21 +7184,31 @@ more than one alias per @var{parameter-name}. @end table @end defun -For information about parameters, @xref{Parameter lists}. Here is an -example of setting up a command with arguments and parsing those -arguments from a @code{getopt} style argument list (@pxref{Getopt}). +For information about parameters, @xref{Parameter lists}. + + +@node Command Example, , Command Service, Embedded Commands +@subsubsection Command Example + +Here is an example of setting up a command with arguments and parsing +those arguments from a @code{getopt} style argument list +(@pxref{Getopt}). @example -(require 'database-utilities) -@ftindex database-utilities -(require 'fluid-let) -@ftindex fluid-let +(require 'database-commands) +@ftindex database-commands +(require 'databases) +@ftindex databases +(require 'getopt-parameters) +@ftindex getopt-parameters (require 'parameters) @ftindex parameters (require 'getopt) @ftindex getopt +(require 'fluid-let) +(require 'printf) -(define my-rdb (create-database #f 'alist-table)) +(define my-rdb (add-command-tables (create-database #f 'alist-table))) (define-tables my-rdb '(foo-params @@ -6544,13 +7220,13 @@ arguments from a @code{getopt} style argument list (@pxref{Getopt}). (lambda (pl) '()) #f "zero or more symbols") (3 nary1-symbols nary1 symbol (lambda (pl) '(symb)) #f "one or more symbols") - (4 optional-number optional uint + (4 optional-number optional ordinal (lambda (pl) '()) #f "zero or one number") (5 flag boolean boolean (lambda (pl) '(#f)) #f "a boolean flag"))) '(foo-pnames ((name string)) - ((parameter-index uint)) + ((parameter-index ordinal)) (("s" 1) ("single-string" 1) ("n" 2) @@ -6573,15 +7249,13 @@ arguments from a @code{getopt} style argument list (@pxref{Getopt}). (lambda (rdb) (lambda args (print args))) "test command arguments")))) -(define (dbutil:serve-command-line rdb command-table - command argc argv) - (set! argv (if (vector? argv) (vector->list argv) argv)) +(define (dbutil:serve-command-line rdb command-table command argv) + (set! *argv* (if (vector? argv) (vector->list argv) argv)) ((make-command-server rdb command-table) command (lambda (comname comval options positions arities types defaulters dirs aliases) - (apply comval (getopt->arglist - argc argv options positions + (apply comval (getopt->arglist options positions arities types defaulters dirs aliases))))) (define (cmd . opts) @@ -6630,68 +7304,59 @@ Usage: cmd [OPTION ARGUMENT ...] ... ERROR: getopt->parameter-list "unrecognized option" "-?" @end example -Some commands are defined in all extended relational-databases. The are -called just like @ref{Relational Database Operations}. -@defun add-domain domain-row -Adds @var{domain-row} to the @dfn{domains} table if there is no row in -the domains table associated with key @code{(car @var{domain-row})} and -returns @code{#t}. Otherwise returns @code{#f}. -For the fields and layout of the domain table, @xref{Catalog -Representation}. Currently, these fields are -@itemize @bullet -@item -domain-name -@item -foreign-table -@item -domain-integrity-rule -@item -type-id -@item -type-param -@end itemize +@node Database Macros, Database Browser, Embedded Commands, Relational Database +@subsection Database Macros -The following example adds 3 domains to the @samp{build} database. -@samp{Optstring} is either a string or @code{#f}. @code{filename} is a -string and @code{build-whats} is a symbol. +@code{(require 'within-database)} + +The object-oriented programming interface to SLIB relational databases +has failed to support clear, understandable, and modular code-writing +for database applications. + +This seems to be a failure of the object-oriented paradigm where the +type of an object is not manifest (or even traceable) in source code. + +@code{within-database}, along with the @samp{databases} package, +reorganizes high-level database functions toward a more declarative +style. Using this package, one can tag database table and command +declarations for emacs: @example -(for-each (build 'add-domain) - '((optstring #f - (lambda (x) (or (not x) (string? x))) - string - #f) - (filename #f #f string #f) - (build-whats #f #f symbol #f))) +etags -lscheme -r'/ *(define-\(command\|table\) (\([^; \t]+\)/\2/' \ + source1.scm ... @end example -@end defun -@defun delete-domain domain-name -Removes and returns the @var{domain-name} row from the @dfn{domains} -table. -@end defun +@menu +* Within-database Example:: +@end menu -@defun domain-checker domain -Returns a procedure to check an argument for conformance to domain -@var{domain}. +@defun within-database database statement-1 @dots{} + +@code{within-database} creates a lexical scope in which the commands +@code{define-table} and @code{define-command} create tables and +@code{*commands*}-table entries respectively in open relational +database @var{database}. + +@code{within-database} Returns @var{database}. @end defun -@subsubheading Defining Tables +@deffn Syntax define-command (@r{<name>} @r{<rdb>}) @r{"comment"} @r{<expression1>} @r{<expression2>} @dots{} +@deffnx Syntax define-command (@r{<name>} @r{<rdb>}) @r{<expression1>} @r{<expression2>} @dots{} -@deffn Procedure 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: +Adds to the @code{*commands*} table a command +@r{<name>}: @lisp -(@r{<name>} @r{<descriptor-name>} @r{<descriptor-name>} @r{<rows>}) -@end lisp -or -@lisp -(@r{<name>} @r{<primary-key-fields>} @r{<other-fields>} @r{<rows>}) +(lambda (@r{<name>} @r{<rdb>}) @r{<expression1>} @r{<expression2>} @dots{}) @end lisp +@end deffn + +@deffn Syntax define-table @r{<name>} @r{<descriptor-name>} @r{<descriptor-name>} @r{<rows>} +@deffnx Syntax define-table @r{<name>} @r{<primary-key-fields>} @r{<other-fields>} @r{<rows>} + where @r{<name>} is the table name, @r{<descriptor-name>} is the symbol name of a descriptor table, @r{<primary-key-fields>} and @r{<other-fields>} describe the primary keys and other fields @@ -6716,205 +7381,105 @@ an error). If @r{<domain>} 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 foriegn-key domain will be created for it. +key field table, a foreign-key domain will be created for it. + @end deffn -@noindent -The following example shows a new database with the name of -@file{foo.db} being created with tables describing processor families -and processor/os/compiler combinations. +@node Within-database Example, , Database Macros, Database Macros +@subsubsection Within-database Example @noindent -The database command @code{define-tables} is defined to call -@code{define-tables} with its arguments. The database is also -configured to print @samp{Welcome} when the database is opened. The -database is then closed and reopened. +Here is an example of @code{within-database} macros: @example -(require 'database-utilities) -@ftindex database-utilities -(define my-rdb (create-database "foo.db" 'alist-table)) - -(define-tables my-rdb - '(*commands* - ((name symbol)) - ((parameters parameter-list) - (procedure expression) - (documentation string)) - ((define-tables - no-parameters - no-parameter-names - (lambda (rdb) (lambda specs (apply define-tables rdb specs))) - "Create or Augment tables from list of specs") - (*initialize* - no-parameters - no-parameter-names - (lambda (rdb) (display "Welcome") (newline) rdb) - "Print Welcome")))) - -((my-rdb 'define-tables) - '(processor-family - ((family atom)) - ((also-ran processor-family)) - ((m68000 #f) - (m68030 m68000) - (i386 8086) - (8086 #f) - (powerpc #f))) - - '(platform - ((name symbol)) - ((processor processor-family) - (os symbol) - (compiler symbol)) - ((aix powerpc aix -) - (amiga-dice-c m68000 amiga dice-c) +(require 'within-database) + +(define my-rdb + (add-command-tables + (create-database "foo.db" 'alist-table))) + +(within-database my-rdb + (define-command (*initialize* rdb) + "Print Welcome" + (display "Welcome") + (newline) + rdb) + (define-command (without-documentation rdb) + (display "without-documentation called") + (newline)) + (define-table (processor-family + ((family atom)) + ((also-ran processor-family))) + (m68000 #f) + (m68030 m68000) + (i386 i8086) + (i8086 #f) + (powerpc #f)) + (define-table (platform + ((name symbol)) + ((processor processor-family) + (os symbol) + (compiler symbol))) + (aix powerpc aix -) + ;; ... (amiga-aztec m68000 amiga aztec) (amiga-sas/c-5.10 m68000 amiga sas/c) (atari-st-gcc m68000 atari gcc) - (atari-st-turbo-c m68000 atari turbo-c) - (borland-c-3.1 8086 ms-dos borland-c) - (djgpp i386 ms-dos gcc) - (linux i386 linux gcc) - (microsoft-c 8086 ms-dos microsoft-c) - (os/2-emx i386 os/2 gcc) - (turbo-c-2 8086 ms-dos turbo-c) - (watcom-9.0 i386 ms-dos watcom)))) - -((my-rdb 'close-database)) - -(set! my-rdb (open-database "foo.db" 'alist-table)) -@print{} -Welcome -@end example - -@subsubheading Listing Tables + ;; ... + (watcom-9.0 i386 ms-dos watcom)) + (define-command (get-processor rdb) + "Get processor for given platform." + (((rdb 'open-table) 'platform #f) 'get 'processor))) -@deffn Procedure 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 deffn - - -@node Database Reports, Database Browser, Database Utilities, Relational Database -@subsection Database Reports - -@noindent -Code for generating database reports is in @file{report.scm}. After -writing it using @code{format}, I discovered that Common-Lisp -@code{format} is not useable for this application because there is no -mechanismm for truncating fields. @file{report.scm} needs to be -rewritten using @code{printf}. - -@deffn Procedure create-report rdb destination report-name table -@deffnx Procedure create-report rdb destination report-name -The symbol @var{report-name} must be primary key in the table named -@code{*reports*} in the relational database @var{rdb}. -@var{destination} is a port, string, or symbol. If @var{destination} is -a: - -@table @asis -@item port -The table is created as ascii text and written to that port. -@item string -The table is created as ascii text and written to the file named by -@var{destination}. -@item symbol -@var{destination} is the primary key for a row in the table named *printers*. -@end table - -The report is prepared as follows: - -@itemize @bullet -@item -@code{Format} (@pxref{Format}) is called with the @code{header} field -and the (list of) @code{column-names} of the table. -@item -@code{Format} is called with the @code{reporter} field and (on -successive calls) each record in the natural order for the table. A -count is kept of the number of newlines output by format. When the -number of newlines to be output exceeds the number of lines per page, -the set of lines will be broken if there are more than -@code{minimum-break} left on this page and the number of lines for this -row is larger or equal to twice @code{minimum-break}. -@item -@code{Format} is called with the @code{footer} field and the (list of) -@code{column-names} of the table. The footer field should not output a -newline. -@item -A new page is output. -@item -This entire process repeats until all the rows are output. -@end itemize -@end deffn +(close-database my-rdb) -Each row in the table *reports* has the fields: +(set! my-rdb (open-command-database! "foo.db")) +@print{} +Welcome -@table @asis -@item name -The report name. -@item default-table -The table to report on if none is specified. -@item header, footer -A @code{format} string. At the beginning and end of each page -respectively, @code{format} is called with this string and the (list of) -column-names of this table. -@item reporter -A @code{format} string. For each row in the table, @code{format} is -called with this string and the row. -@item minimum-break -The minimum number of lines into which the report lines for a row can be -broken. Use @code{0} if a row's lines should not be broken over page -boundaries. -@end table +(my-rdb 'without-documentation) +@print{} +without-documentation called -Each row in the table *printers* has the fields: +((my-rdb 'get-processor) 'amiga-sas/c-5.10) +@result{} m68000 -@table @asis -@item name -The printer name. -@item print-procedure -The procedure to call to actually print. -@end table +(close-database my-rdb) +@end example -@node Database Browser, , Database Reports, Relational Database +@node Database Browser, , Database Macros, Relational Database @subsection Database Browser (require 'database-browse) -@deffn Procedure browse database +@deffn {Procedure} browse database Prints the names of all the tables in @var{database} and sets browse's default to @var{database}. -@deffnx Procedure browse +@deffnx {Procedure} browse Prints the names of all the tables in the default database. -@deffnx Procedure browse table-name +@deffnx {Procedure} browse table-name For each record of the table named by the symbol @var{table-name}, prints a line composed of all the field values. -@deffnx Procedure browse pathname +@deffnx {Procedure} browse pathname Opens the database named by the string @var{pathname}, prints the names of all its tables, and sets browse's default to the database. -@deffnx Procedure browse database table-name +@deffnx {Procedure} browse database table-name Sets browse's default to @var{database} and prints the records of the table named by the symbol @var{table-name}. -@deffnx Procedure browse pathname table-name +@deffnx {Procedure} browse pathname table-name Opens the database named by the string @var{pathname} and sets browse's default to it; @code{browse} prints the records of the table named by @@ -6922,7 +7487,642 @@ the symbol @var{table-name}. @end deffn -@node Weight-Balanced Trees, , Relational Database, Database Packages + +@node Relational Infrastructure, Weight-Balanced Trees, Relational Database, Database Packages +@section Relational Infrastructure + + +@menu +* Base Table:: +* Catalog Representation:: +* Relational Database Objects:: +* Database Operations:: +@end menu + + +@node Base Table, Catalog Representation, Relational Infrastructure, Relational Infrastructure +@subsection Base Table + +@cindex base-table +A @dfn{base-table} is the primitive database layer upon which SLIB +relational databases are built. At the minimum, it must support the +types integer, symbol, string, and boolean. The base-table may restrict +the size of integers, symbols, and strings it supports. + +A base table implementation is available as the value of the identifier +naming it (eg. @var{alist-table}) after requiring the symbol of that +name. + +@deftp {Feature} alist-table +@code{(require 'alist-table)} +@ftindex alist-table + +Association-list base tables support all Scheme types and are suitable +for small databases. In order to be retrieved after being written to a +file, the data stored should include only objects which are readable and +writeable in the Scheme implementation. + +The @dfn{alist-table} base-table implementation is included in the +SLIB distribution. +@end deftp + +@dfn{WB} is a B-tree database package with SCM interfaces. Being +disk-based, WB databases readily store and access hundreds of +megabytes of data. WB comes with two base-table embeddings. + +@deftp {Feature} wb-table +@code{(require 'wb-table)} +@ftindex wb-table + +@cindex WB +@code{wb-table} supports scheme expressions for keys and values whose +text representations are less than 255 characters in length. +@xref{wb-table, , , wb, WB}. +@end deftp + + +@deftp {Feature} rwb-isam +@code{(require 'rwb-isam)} +@ftindex rwb-isam + +@dfn{rwb-isam} is a sophisticated base-table implementation built on +WB and SCM which uses binary numerical formats for key and non-key +fields. It supports IEEE floating-point and fixed-precision integer +keys with the correct numerical collation order. +@end deftp + +This rest of this section documents the interface for a base table +implementation from which the @ref{Relational Database} package +constructs a Relational system. It will be of interest primarily to +those wishing to port or write new base-table implementations. + +@defvar *base-table-implementations* +To support automatic dispatch for @code{open-database}, each base-table +module adds an association to @var{*base-table-implementations*} when +loaded. This association is the list of the base-table symbol and the +value returned by @code{(make-relational-system @var{base-table})}. +@end defvar + +@menu +* The Base:: +* Base Tables:: +* Base Field Types:: +* Composite Keys:: +* Base Record Operations:: +* Match Keys:: +* Aggregate Base Operations:: +* Base ISAM Operations:: +@end menu + +@node The Base, Base Tables, Base Table, Base Table +@subsubsection The Base + +All of these functions are accessed through a single procedure by +calling that procedure with the symbol name of the operation. A +procedure will be returned if that operation is supported and @code{#f} +otherwise. For example: + +@example +@group +(require 'alist-table) +@ftindex alist-table +@findex alist-table +(define my-base (alist-table 'make-base)) +my-base @result{} *a procedure* +(define foo (alist-table 'foo)) +foo @result{} #f +@end group +@end example + +@defop {Operation} {base-table} make-base filename key-dimension column-types +Returns a new, open, low-level database (collection of tables) +associated with @var{filename}. This returned database has an empty +table associated with @var{catalog-id}. The positive integer +@var{key-dimension} is the number of keys composed to make a +@var{primary-key} for the catalog table. The list of symbols +@var{column-types} describes the types of each column for that table. +If the database cannot be created as specified, @code{#f} is returned. + +Calling the @code{close-base} method on this database and possibly other +operations will cause @var{filename} to be written to. If +@var{filename} is @code{#f} a temporary, non-disk based database will be +created if such can be supported by the base table implelentation. +@end defop + +@defop {Operation} {base-table} open-base filename mutable +Returns an open low-level database associated with @var{filename}. If +@var{mutable} is @code{#t}, this database will have methods capable of +effecting change to the database. If @var{mutable} is @code{#f}, only +methods for inquiring the database will be available. If the database +cannot be opened as specified @code{#f} is returned. + +Calling the @code{close-base} (and possibly other) method on a +@var{mutable} database will cause @var{filename} to be written to. +@end defop + +@defop {Operation} {base-table} write-base lldb filename +Causes the low-level database @var{lldb} to be written to +@var{filename}. If the write is successful, also causes @var{lldb} to +henceforth be associated with @var{filename}. Calling the +@code{close-database} (and possibly other) method on @var{lldb} may +cause @var{filename} to be written to. If @var{filename} is @code{#f} +this database will be changed to a temporary, non-disk based database if +such can be supported by the underlying base table implelentation. If +the operations completed successfully, @code{#t} is returned. +Otherwise, @code{#f} is returned. +@end defop + +@defop {Operation} {base-table} sync-base lldb +Causes the file associated with the low-level database @var{lldb} to be +updated to reflect its current state. If the associated filename is +@code{#f}, no action is taken and @code{#f} is returned. If this +operation completes successfully, @code{#t} is returned. Otherwise, +@code{#f} is returned. +@end defop + +@defop {Operation} {base-table} close-base lldb +Causes the low-level database @var{lldb} to be written to its associated +file (if any). If the write is successful, subsequent operations to +@var{lldb} will signal an error. If the operations complete +successfully, @code{#t} is returned. Otherwise, @code{#f} is returned. +@end defop + + +@node Base Tables, Base Field Types, The Base, Base Table +@subsubsection Base Tables + +@defop {Operation} {base-table} make-table lldb key-dimension column-types +Returns the ordinal @var{base-id} for a new base table, otherwise +returns @code{#f}. The base table can then be opened using +@code{(open-table @var{lldb} @var{base-id})}. The positive integer +@var{key-dimension} is the number of keys composed to make a +@var{primary-key} for this table. The list of symbols +@var{column-types} describes the types of each column. +@end defop + +@defop {Operation} {base-table} open-table lldb base-id key-dimension column-types +Returns a @var{handle} for an existing base table in the low-level +database @var{lldb} if that table exists and can be opened in the mode +indicated by @var{mutable}, otherwise returns @code{#f}. + +As with @code{make-table}, the positive integer @var{key-dimension} is +the number of keys composed to make a @var{primary-key} for this table. +The list of symbols @var{column-types} describes the types of each +column. +@end defop + +@defop {Operation} {base-table} kill-table lldb base-id key-dimension column-types +Returns @code{#t} if the base table associated with @var{base-id} was +removed from the low level database @var{lldb}, and @code{#f} otherwise. +@end defop + +@defop {Operation} {base-table} catalog-id +A constant @var{base-id} ordinal suitable for passing as a parameter to +@code{open-table}. @var{catalog-id} will be used as the base table for +the system catalog. +@end defop + + +@node Base Field Types, Composite Keys, Base Tables, Base Table +@subsubsection Base Field Types + +@defop {Operation} {base-table} supported-type? symbol +Returns @code{#t} if @var{symbol} names a type allowed as a column +value by the implementation, and @code{#f} otherwise. At a minimum, +an implementation must support the types @code{integer}, +@code{ordinal}, @code{symbol}, @code{string}, and @code{boolean}. +@end defop + +@defop {Operation} {base-table} supported-key-type? symbol +Returns @code{#t} if @var{symbol} names a type allowed as a key value +by the implementation, and @code{#f} otherwise. At a minimum, an +implementation must support the types @code{ordinal}, and +@code{symbol}. +@end defop + +@noindent +An @dfn{ordinal} is an exact positive integer. The other types are +standard Scheme. + + +@node Composite Keys, Base Record Operations, Base Field Types, Base Table +@subsubsection Composite Keys + +@defop {Operation} {base-table} make-keyifier-1 type +Returns a procedure which accepts a single argument which must be of +type @var{type}. This returned procedure returns an object suitable for +being a @var{key} argument in the functions whose descriptions follow. + +Any 2 arguments of the supported type passed to the returned function +which are not @code{equal?} must result in returned values which are not +@code{equal?}. +@end defop + +@defop {Operation} {base-table} make-list-keyifier key-dimension types +The list of symbols @var{types} must have at least @var{key-dimension} +elements. Returns a procedure which accepts a list of length +@var{key-dimension} and whose types must corresopond to the types named +by @var{types}. This returned procedure combines the elements of its +list argument into an object suitable for being a @var{key} argument in +the functions whose descriptions follow. + +Any 2 lists of supported types (which must at least include symbols and +non-negative integers) passed to the returned function which are not +@code{equal?} must result in returned values which are not +@code{equal?}. +@end defop + +@defop {Operation} {base-table} make-key-extractor key-dimension types column-number +Returns a procedure which accepts objects produced by application of the +result of @code{(make-list-keyifier @var{key-dimension} @var{types})}. +This procedure returns a @var{key} which is @code{equal?} to the +@var{column-number}th element of the list which was passed to create +@var{composite-key}. The list @var{types} must have at least +@var{key-dimension} elements. +@end defop + +@defop {Operation} {base-table} make-key->list key-dimension types +Returns a procedure which accepts objects produced by application of +the result of @code{(make-list-keyifier @var{key-dimension} +@var{types})}. This procedure returns a list of @var{key}s which are +elementwise @code{equal?} to the list which was passed to create +@var{composite-key}. +@end defop + + +@node Base Record Operations, Match Keys, Composite Keys, Base Table +@subsubsection Base Record Operations + +@noindent +In the following functions, the @var{key} argument can always be assumed +to be the value returned by a call to a @emph{keyify} routine. + +@defop {Operation} {base-table} present? handle key +Returns a non-@code{#f} value if there is a row associated with +@var{key} in the table opened in @var{handle} and @code{#f} otherwise. +@end defop + +@defop {Operation} {base-table} make-getter key-dimension types +Returns a procedure which takes arguments @var{handle} and @var{key}. +This procedure returns a list of the non-primary values of the relation +(in the base table opened in @var{handle}) whose primary key is +@var{key} if it exists, and @code{#f} otherwise. +@end defop + +@noindent +@code{make-getter-1} is a new operation. The relational-database +module works with older base-table implementations by using +@code{make-getter}. + +@defop {Operation} {base-table} make-getter-1 key-dimension types index +Returns a procedure which takes arguments @var{handle} and @var{key}. +This procedure returns the value of the @var{index}th field (in the +base table opened in @var{handle}) whose primary key is @var{key} if +it exists, and @code{#f} otherwise. + +@var{index} must be larger than @var{key-dimension}. +@end defop + +@defop {Operation} {base-table} make-putter key-dimension types +Returns a procedure which takes arguments @var{handle} and @var{key} and +@var{value-list}. This procedure associates the primary key @var{key} +with the values in @var{value-list} (in the base table opened in +@var{handle}) and returns an unspecified value. +@end defop + +@defop {Operation} {base-table} delete handle key +Removes the row associated with @var{key} from the table opened in +@var{handle}. An unspecified value is returned. +@end defop + + +@node Match Keys, Aggregate Base Operations, Base Record Operations, Base Table +@subsubsection Match Keys + +@noindent +@cindex match-keys +@cindex match +@cindex wild-card +A @var{match-keys} argument is a list of length equal to +the number of primary keys. The @var{match-keys} restrict the actions +of the table command to those records whose primary keys all satisfy the +corresponding element of the @var{match-keys} list. The elements and +their actions are: + +@quotation +@table @asis +@item @code{#f} +The false value matches any key in the corresponding position. +@item an object of type procedure +This procedure must take a single argument, the key in the corresponding +position. Any key for which the procedure returns a non-false value is +a match; Any key for which the procedure returns a @code{#f} is not. +@item other values +Any other value matches only those keys @code{equal?} to it. +@end table +@end quotation + + +@node Aggregate Base Operations, Base ISAM Operations, Match Keys, Base Table +@subsubsection Aggregate Base Operations + +@noindent +The @var{key-dimension} and @var{column-types} arguments are needed to +decode the composite-keys for matching with @var{match-keys}. + +@defop {Operation} {base-table} delete* handle key-dimension column-types match-keys +Removes all rows which satisfy @var{match-keys} from the table opened in +@var{handle}. An unspecified value is returned. +@end defop + +@defop {Operation} {base-table} for-each-key handle procedure key-dimension column-types match-keys +Calls @var{procedure} once with each @var{key} in the table opened in +@var{handle} which satisfy @var{match-keys} in an unspecified order. +An unspecified value is returned. +@end defop + +@defop {Operation} {base-table} map-key handle procedure key-dimension column-types match-keys +Returns a list of the values returned by calling @var{procedure} once +with each @var{key} in the table opened in @var{handle} which satisfy +@var{match-keys} in an unspecified order. +@end defop + + +@node Base ISAM Operations, , Aggregate Base Operations, Base Table +@subsubsection Base ISAM Operations + +@noindent +These operations are optional for a Base-Table implementation. + +@defop {Operation} {base-table} ordered-for-each-key handle procedure key-dimension column-types match-keys +Calls @var{procedure} once with each @var{key} in the table opened in +@var{handle} which satisfy @var{match-keys} in the natural order for +the types of the primary key fields of that table. An unspecified value +is returned. +@end defop + +@defop {Operation} {base-table} make-nexter handle key-dimension column-types index +Returns a procedure of arguments @var{key1} @var{key2} @dots{} which +returns the key-list identifying the lowest record higher than +@var{key1} @var{key2} @dots{} which is stored in the base-table and +which differs in column @var{index} or a lower indexed key; or false +if no higher record is present. +@end defop + +@defop {Operation} {base-table} make-prever handle key-dimension column-types index +Returns a procedure of arguments @var{key1} @var{key2} @dots{} which +returns the key-list identifying the highest record less than +@var{key1} @var{key2} @dots{} which is stored in the base-table and +which differs in column @var{index} or a lower indexed key; or false +if no higher record is present. +@end defop + +@node Catalog Representation, Relational Database Objects, Base Table, Relational Infrastructure +@subsection Catalog Representation + +@noindent +Each database (in an implementation) has a @dfn{system catalog} which +describes all the user accessible tables in that database (including +itself). + +@noindent +The system catalog base table has the following fields. @code{PRI} +indicates a primary key for that table. + +@example +@group +PRI table-name + column-limit the highest column number + coltab-name descriptor table name + bastab-id data base table identifier + user-integrity-rule + view-procedure A scheme thunk which, when called, + produces a handle for the view. coltab + and bastab are specified if and only if + view-procedure is not. +@end group +@end example + +@noindent +Descriptors for base tables (not views) are tables (pointed to by +system catalog). Descriptor (base) tables have the fields: + +@example +@group +PRI column-number sequential integers from 1 + primary-key? boolean TRUE for primary key components + column-name + column-integrity-rule + domain-name +@end group +@end example + +@noindent +A @dfn{primary key} is any column marked as @code{primary-key?} in the +corresponding descriptor table. All the @code{primary-key?} columns +must have lower column numbers than any non-@code{primary-key?} columns. +Every table must have at least one primary key. Primary keys must be +sufficient to distinguish all rows from each other in the table. All of +the system defined tables have a single primary key. + +@noindent +A @dfn{domain} is a category describing the allowable values to occur in +a column. It is described by a (base) table with the fields: + +@example +@group +PRI domain-name + foreign-table + domain-integrity-rule + type-id + type-param +@end group +@end example + +@noindent +The @dfn{type-id} field value is a symbol. This symbol may be used by +the underlying base table implementation in storing that field. + +@noindent +If the @code{foreign-table} field is non-@code{#f} then that field names +a table from the catalog. The values for that domain must match a +primary key of the table referenced by the @var{type-param} (or +@code{#f}, if allowed). This package currently does not support +composite foreign-keys. + +@noindent +The types for which support is planned are: +@example +@group + atom + symbol + string [<length>] + number [<base>] + money <currency> + date-time + boolean + + foreign-key <table-name> + expression + virtual <expression> +@end group +@end example + + +@node Relational Database Objects, Database Operations, Catalog Representation, Relational Infrastructure +@subsection Relational Database Objects + +@noindent +This object-oriented interface is deprecated for typical database +applications; @ref{Using Databases} provides an application programmer +interface which is easier to understand and use. + +@defun make-relational-system base-table-implementation + +Returns a procedure implementing a relational database using the +@var{base-table-implementation}. + +All of the operations of a base table implementation are accessed +through a procedure defined by @code{require}ing that implementation. +Similarly, all of the operations of the relational database +implementation are accessed through the procedure returned by +@code{make-relational-system}. For instance, a new relational database +could be created from the procedure returned by +@code{make-relational-system} by: + +@example +(require 'alist-table) +@ftindex alist-table +(define relational-alist-system + (make-relational-system alist-table)) +(define create-alist-database + (relational-alist-system 'create-database)) +(define my-database + (create-alist-database "mydata.db")) +@end example +@end defun + +@noindent +What follows are the descriptions of the methods available from +relational system returned by a call to @code{make-relational-system}. + +@defop {Operation} {relational-system} create-database filename + +Returns an open, nearly empty relational database associated with +@var{filename}. The only tables defined are the system catalog and +domain table. Calling the @code{close-database} method on this database +and possibly other operations will cause @var{filename} to be written +to. If @var{filename} is @code{#f} a temporary, non-disk based database +will be created if such can be supported by the underlying base table +implelentation. If the database cannot be created as specified +@code{#f} is returned. For the fields and layout of descriptor tables, +@ref{Catalog Representation} +@end defop + +@defop {Operation} {relational-system} open-database filename mutable? + +Returns an open relational database associated with @var{filename}. If +@var{mutable?} is @code{#t}, this database will have methods capable of +effecting change to the database. If @var{mutable?} is @code{#f}, only +methods for inquiring the database will be available. Calling the +@code{close-database} (and possibly other) method on a @var{mutable?} +database will cause @var{filename} to be written to. If the database +cannot be opened as specified @code{#f} is returned. +@end defop + + +@node Database Operations, , Relational Database Objects, Relational Infrastructure +@subsection Database Operations + +@noindent +This object-oriented interface is deprecated for typical database +applications; @ref{Using Databases} provides an application programmer +interface which is easier to understand and use. + +@noindent +These are the descriptions of the methods available from an open +relational database. A method is retrieved from a database by calling +the database with the symbol name of the operation. For example: + +@example +(define my-database + (create-alist-database "mydata.db")) +(define telephone-table-desc + ((my-database 'create-table) 'telephone-table-desc)) +@end example + +@defop {Operation} {relational-database} close-database +Causes the relational database to be written to its associated file (if +any). If the write is successful, subsequent operations to this +database will signal an error. If the operations completed +successfully, @code{#t} is returned. Otherwise, @code{#f} is returned. +@end defop + +@defop {Operation} {relational-database} write-database filename +Causes the relational database to be written to @var{filename}. If the +write is successful, also causes the database to henceforth be +associated with @var{filename}. Calling the @code{close-database} (and +possibly other) method on this database will cause @var{filename} to be +written to. If @var{filename} is @code{#f} this database will be +changed to a temporary, non-disk based database if such can be supported +by the underlying base table implelentation. If the operations +completed successfully, @code{#t} is returned. Otherwise, @code{#f} is +returned. +@end defop + +@defop {Operation} {relational-database} sync-database +Causes any pending updates to the database file to be written out. If +the operations completed successfully, @code{#t} is returned. +Otherwise, @code{#f} is returned. +@end defop + +@defop {Operation} {relational-database} solidify-database +Causes any pending updates to the database file to be written out. If +the writes completed successfully, then the database is changed to be +immutable and @code{#t} is returned. Otherwise, @code{#f} is returned. +@end defop + +@defop {Operation} {relational-database} table-exists? table-name +Returns @code{#t} if @var{table-name} exists in the system catalog, +otherwise returns @code{#f}. +@end defop + +@defop {Operation} {relational-database} open-table table-name mutable? +Returns a @dfn{methods} procedure for an existing relational table in +this database if it exists and can be opened in the mode indicated by +@var{mutable?}, otherwise returns @code{#f}. +@end defop + +@noindent +These methods will be present only in mutable databases. + +@defop {Operation} {relational-database} delete-table table-name +Removes and returns the @var{table-name} row from the system catalog if +the table or view associated with @var{table-name} gets removed from the +database, and @code{#f} otherwise. +@end defop + +@defop {Operation} {relational-database} create-table table-desc-name +Returns a methods procedure for a new (open) relational table for +describing the columns of a new base table in this database, otherwise +returns @code{#f}. For the fields and layout of descriptor tables, +@xref{Catalog Representation}. + +@defopx {Operation} {relational-database} create-table table-name table-desc-name +Returns a methods procedure for a new (open) relational table with +columns as described by @var{table-desc-name}, otherwise returns +@code{#f}. +@end defop + +@defop {Operation} {relational-database} create-view ?? +@defopx {Operation} {relational-database} project-table ?? +@defopx {Operation} {relational-database} restrict-table ?? +@defopx {Operation} {relational-database} cart-prod-tables ?? +Not yet implemented. +@end defop + + +@node Weight-Balanced Trees, , Relational Infrastructure, Database Packages @section Weight-Balanced Trees @code{(require 'wt-tree)} @@ -7013,7 +8213,7 @@ To use weight balanced trees, execute @example (load-option 'wt-tree) @end example -@findex load-option +@ftindex load-option @noindent once before calling any of the procedures defined here. @@ -7126,10 +8326,10 @@ trees. These operations are the usual tree operations for insertion, deletion and lookup, some predicates and a procedure for determining the number of associations in a tree. -@deffn {procedure+} wt-tree? object -Returns @code{#t} if @var{object} is a weight-balanced tree, otherwise -returns @code{#f}. -@end deffn +@c @deffn {procedure+} wt-tree? object +@c Returns @code{#t} if @var{object} is a weight-balanced tree, otherwise +@c returns @code{#f}. +@c @end deffn @deffn {procedure+} wt-tree/empty? wt-tree Returns @code{#t} if @var{wt-tree} contains no associations, otherwise @@ -7366,15 +8566,13 @@ number of associations in the tree. Indexing can be used to find the median and maximum keys in the tree as follows: +@end deffn @example -median: (wt-tree/index @var{wt-tree} - (quotient (wt-tree/size @var{wt-tree}) 2)) +median: (wt-tree/index @var{wt-tree} (quotient (wt-tree/size @var{wt-tree}) 2)) -maximum: (wt-tree/index @var{wt-tree} - (-1+ (wt-tree/size @var{wt-tree}))) +maximum: (wt-tree/index @var{wt-tree} (-1+ (wt-tree/size @var{wt-tree}))) @end example -@end deffn @deffn {procedure+} wt-tree/rank wt-tree key Determines the 0-based position of @var{key} in the sorted sequence of @@ -7441,7 +8639,8 @@ operation is equivalent to * Procedures:: Miscellaneous utility procedures. * Standards Support:: Support for Scheme Standards. * Session Support:: REPL and Debugging. -* Extra-SLIB Packages:: +* System Interface:: 'system, 'getenv, and other programs. +* Extra-SLIB Packages:: Outside the envelope. @end menu @@ -7452,14 +8651,16 @@ operation is equivalent to @menu * Arrays:: 'array +* Subarrays:: 'subarray * Array Mapping:: 'array-for-each * Association Lists:: 'alist * Byte:: 'byte +* Byte/Number Conversions:: 'byte-number +* MAT-File Format:: 'matfile * Portable Image Files:: 'pnm * Collections:: 'collect * Dynamic Data Type:: 'dynamic * Hash Tables:: 'hash-table -* Hashing:: 'hash, 'sierpinski, 'soundex * Object:: 'object * Priority Queues:: 'priority-queue * Queues:: 'queue @@ -7469,277 +8670,52 @@ operation is equivalent to -@node Arrays, Array Mapping, Data Structures, Data Structures +@node Arrays, Subarrays, Data Structures, Data Structures @subsection Arrays @include array.txi -@node Array Mapping, Association Lists, Arrays, Data Structures -@subsection Array Mapping +@node Subarrays, Array Mapping, Arrays, Data Structures +@subsection Subarrays -@code{(require 'array-for-each)} -@ftindex array-for-each +@include subarray.txi -@defun 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 defun -@defun array-for-each @var{proc} @var{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 @var{array} -Returns an array of lists of indexes for @var{array} such that, if -@var{li} is a list of indexes for which @var{array} is defined, (equal? -@var{li} (apply array-ref (array-indexes @var{array}) @var{li})). -@end defun - -@defun array-index-map! array proc -applies @var{proc} to the indices of each element of @var{array} in -turn, storing the result in the corresponding element. The value -returned and the order of application are unspecified. - -One can implement @var{array-indexes} as -@example -(define (array-indexes array) - (let ((ra (apply make-array #f (array-shape array)))) - (array-index-map! ra (lambda x x)) - ra)) -@end example -Another example: -@example -(define (apl:index-generator n) - (let ((v (make-uniform-vector n 1))) - (array-index-map! v (lambda (i) i)) - v)) -@end example -@end defun +@node Array Mapping, Association Lists, Subarrays, Data Structures +@subsection Array Mapping -@defun 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 defun +@include arraymap.txi @node Association Lists, Byte, Array Mapping, Data Structures @subsection Association Lists -@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. +@include alist.txi -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 -@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:@refill -@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:@refill -@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 - -@node Byte, Portable Image Files, Association Lists, Data Structures +@node Byte, Byte/Number Conversions, Association Lists, Data Structures @subsection Byte -@code{(require 'byte)} - -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 - -@deffn Function 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. -@findex byte-ref -@end deffn - -@deffn Procedure byte-set! bytes k byte -@var{k} must be a valid index of @var{bytes}%, and @var{byte} must be a -small integer. @code{Byte-set!} stores @var{byte} in element @var{k} -of @var{bytes} -@findex byte-set! -and returns an unspecified value. @c <!> +@include byte.txi -@end deffn - -@deffn Function make-bytes k -@deffnx Function make-bytes k byte - -@code{Make-bytes} returns a newly allocated byte-array of -@findex make-bytes -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 deffn - -@deffn Function bytes-length bytes +@node Byte/Number Conversions, MAT-File Format, Byte, Data Structures +@subsection Byte/Number Conversions -@code{bytes-length} returns length of byte-array @var{bytes}. -@findex bytes-length +@include bytenumb.txi -@end deffn -@deffn Function write-byte byte -@deffnx Function write-byte byte port +@node MAT-File Format, Portable Image Files, Byte/Number Conversions, Data Structures +@subsection MAT-File Format -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 +@include matfile.txi -@end deffn - -@deffn Function read-byte -@deffnx Function read-byte port - -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 deffn - -@deffn Function bytes byte @dots{} - -Returns a newly allocated byte-array composed of the arguments. - -@end deffn - -@deffn Function bytes->list bytes -@deffnx Function list->bytes bytes - -@code{Bytes->list} returns a newly allocated list of the -@findex bytes->list -bytes that make up the given byte-array. @code{List->bytes} -@findex list->bytes -returns a newly allocated byte-array formed from the small integers in -the list @var{bytes}. @code{Bytes->list} and @code{list->bytes} are -@findex list->bytes -@findex bytes->list -inverses so far as @code{equal?} is concerned. -@findex equal? - -@end deffn -@node Portable Image Files, Collections, Byte, Data Structures +@node Portable Image Files, Collections, MAT-File Format, Data Structures @subsection Portable Image Files -@code{(require 'pnm)} - -@deffn Function pnm:type-dimensions path -The string @var{path} must name a @dfn{portable bitmap graphics} file. -@code{pnm:type-dimensions} returns a list of 4 items: -@enumerate -@item -A symbol describing the type of the file named by @var{path}. -@item -The image width in pixels. -@item -The image height in pixels. -@item -The maximum value of pixels assume in the file. -@end enumerate - -The current set of file-type symbols is: -@table @asis -@item pbm -@itemx pbm-raw -Black-and-White image; pixel values are 0 or 1. -@item pgm -@itemx pgm-raw -Gray (monochrome) image; pixel values are from 0 to @var{maxval} -specified in file header. -@item ppm -@itemx ppm-raw -RGB (full color) image; red, green, and blue interleaved pixel values -are from 0 to @var{maxval} -@end table - -@end deffn - -@deffn Function pnm:image-file->array path array - -Reads the @dfn{portable bitmap graphics} file named by @var{path} into -@var{array}. @var{array} must be the correct size and type for -@var{path}. @var{array} is returned. - -@deffnx Function pnm:image-file->array path - -@code{pnm:image-file->array} creates and returns an array with the -@dfn{portable bitmap graphics} file named by @var{path} read into it. - -@end deffn - -@deffn Procedure pnm:array-write type array maxval path - -Writes the contents of @var{array} to a @var{type} image file named -@var{path}. The file will have pixel values between 0 and @var{maxval}, -which must be compatible with @var{type}. For @samp{pbm} files, -@var{maxval} must be @samp{1}. - -@end deffn +@include pnm.txi @node Collections, Dynamic Data Type, Portable Image Files, Data Structures @@ -7752,14 +8728,17 @@ which must be compatible with @var{type}. For @samp{pbm} files, @code{(require 'collect)} @ftindex collect +@noindent Routines for managing collections. Collections are aggregate data structures supporting iteration over their elements, similar to the Dylan(TM) language, but with a different interface. They have @dfn{elements} indexed by corresponding @dfn{keys}, although the keys may be implicit (as with lists). +@noindent New types of collections may be defined as YASOS objects (@pxref{Yasos}). They must support the following operations: + @itemize @bullet @item @code{(collection? @var{self})} (always returns @code{#t}); @@ -7770,28 +8749,33 @@ They must support the following operations: @item @code{(print @var{self} @var{port})} is a specialized print operation for the collection which prints a suitable representation on the given -@var{port} or returns it as a string if @var{port} is @code{#t};@refill +@var{port} or returns it as a string if @var{port} is @code{#t}; @item +@findex gen-elts @code{(gen-elts @var{self})} returns a thunk which on successive invocations yields elements of @var{self} in order or gives an error if -it is invoked more than @code{(size @var{self})} times;@refill +it is invoked more than @code{(size @var{self})} times; @item +@findex gen-keys @code{(gen-keys @var{self})} is like @code{gen-elts}, but yields the collection's keys in order. - @end itemize + +@noindent They might support specialized @code{for-each-key} and @code{for-each-elt} operations. + + @defun collection? obj A predicate, true initially of lists, vectors and strings. New sorts of collections must answer @code{#t} to @code{collection?}. @end defun -@deffn Procedure map-elts proc collection1 @dots{} -@deffnx Procedure do-elts proc collection1 @dots{} +@deffn {Procedure} map-elts proc collection1 @dots{} +@deffnx {Procedure} do-elts proc collection1 @dots{} @var{proc} is a procedure taking as many arguments as there are @var{collections} (at least one). The @var{collections} are iterated over in their natural order and @var{proc} is applied to the elements @@ -7809,8 +8793,8 @@ Example: @end lisp @end deffn -@deffn Procedure map-keys proc collection1 @dots{} -@deffnx Procedure do-keys proc collection1 @dots{} +@deffn {Procedure} map-keys proc collection1 @dots{} +@deffnx {Procedure} do-keys proc collection1 @dots{} These are analogous to @code{map-elts} and @code{do-elts}, but each iteration is over the @var{collections}' @emph{keys} rather than their elements. @@ -7822,14 +8806,14 @@ Example: @end lisp @end deffn -@deffn Procedure for-each-key collection proc -@deffnx Procedure for-each-elt collection proc +@deffn {Procedure} for-each-key collection proc +@deffnx {Procedure} for-each-elt collection proc These are like @code{do-keys} and @code{do-elts} but only for a single collection; they are potentially more efficient. @end deffn @defun reduce proc seed collection1 @dots{} -A generalization of the list-based @code{comlist:reduce-init} +A generalization of the list-based @code{reduce-init} (@pxref{Lists as sequences}) to collections which will shadow the list-based version if @code{(require 'collect)} follows @ftindex collect @@ -7858,8 +8842,8 @@ Example: @end defun @defun every? pred collection1 @dots{} -A generalization of the list-based @code{every} (@pxref{Lists as -sequences}) to collections. +A generalization of the list-based @code{every} +(@pxref{Lists as sequences}) to collections. Example: @lisp @@ -7934,6 +8918,7 @@ Here is a sample collection: @code{simple-table} which is also a (loop (cdr last) (cdr this))) ) ) ) )) +@group ;; collection behaviors ((COLLECTION? self) #t) ((GEN-KEYS self) (collect:list-gen-elts (map car table))) @@ -7943,8 +8928,8 @@ Here is a sample collection: @code{simple-table} which is also a ) ((FOR-EACH-ELT self proc) (for-each (lambda (bucket) (proc (cdr bucket))) table) - ) - ) ) ) + ) ) ) ) +@end group @end lisp @@ -7972,7 +8957,7 @@ Return the value of the given dynamic in the current dynamic environment. @end defun -@deffn Procedure dynamic-set! dyn obj +@deffn {Procedure} dynamic-set! dyn obj Change the value of the given dynamic to @var{obj} in the current dynamic environment. The returned value is unspecified. @end deffn @@ -7991,297 +8976,29 @@ The @code{dynamic-bind} macro is not implemented. -@node Hash Tables, Hashing, Dynamic Data Type, Data Structures +@node Hash Tables, Object, Dynamic Data Type, Data Structures @subsection Hash Tables -@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 - -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 - -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 - - - - - -@node Hashing, Object, Hash Tables, Data Structures -@subsection Hashing - -@code{(require 'hash)} -@ftindex hash - -These hashing functions are for use in quickly classifying objects. -Hash tables use these functions. - -@defun hashq obj k -@defunx hashv obj k -@defunx hash obj k -Returns an exact non-negative integer less than @var{k}. For each -non-negative integer less than @var{k} there are arguments @var{obj} for -which the hashing functions applied to @var{obj} and @var{k} returns -that integer. - -For @code{hashq}, @code{(eq? obj1 obj2)} implies @code{(= (hashq obj1 k) -(hashq obj2))}. - -For @code{hashv}, @code{(eqv? obj1 obj2)} implies @code{(= (hashv obj1 k) -(hashv obj2))}. - -For @code{hash}, @code{(equal? obj1 obj2)} implies @code{(= (hash obj1 k) -(hash obj2))}. - -@code{hash}, @code{hashv}, and @code{hashq} return in time bounded by a -constant. Notice that items having the same @code{hash} implies the -items have the same @code{hashv} implies the items have the same -@code{hashq}. -@end defun - - -@code{(require 'sierpinski)} -@ftindex sierpinski - -@defun make-sierpinski-indexer max-coordinate -Returns a procedure (eg hash-function) of 2 numeric arguments which -preserves @emph{nearness} in its mapping from NxN to N. - -@var{max-coordinate} is the maximum coordinate (a positive integer) of a -population of points. The returned procedures is a function that takes -the x and y coordinates of a point, (non-negative integers) and returns -an integer corresponding to the relative position of that point along a -Sierpinski curve. (You can think of this as computing a (pseudo-) -inverse of the Sierpinski spacefilling curve.) - -Example use: Make an indexer (hash-function) for integer points lying in -square of integer grid points [0,99]x[0,99]: -@example -(define space-key (make-sierpinski-indexer 100)) -@end example -Now let's compute the index of some points: -@example -(space-key 24 78) @result{} 9206 -(space-key 23 80) @result{} 9172 -@end example - -Note that locations (24, 78) and (23, 80) are near in index and -therefore, because the Sierpinski spacefilling curve is continuous, we -know they must also be near in the plane. Nearness in the plane does -not, however, necessarily correspond to nearness in index, although it -@emph{tends} to be so. - -Example applications: -@itemize @bullet - -@item -Sort points by Sierpinski index to get heuristic solution to -@emph{travelling salesman problem}. For details of performance, -see L. Platzman and J. Bartholdi, "Spacefilling curves and the -Euclidean travelling salesman problem", JACM 36(4):719--737 -(October 1989) and references therein. - -@item -Use Sierpinski index as key by which to store 2-dimensional data -in a 1-dimensional data structure (such as a table). Then -locations that are near each other in 2-d space will tend to -be near each other in 1-d data structure; and locations that -are near in 1-d data structure will be near in 2-d space. This -can significantly speed retrieval from secondary storage because -contiguous regions in the plane will tend to correspond to -contiguous regions in secondary storage. (This is a standard -technique for managing CAD/CAM or geographic data.) - -@end itemize -@end defun - - - -@code{(require 'soundex)} -@ftindex soundex - -@defun soundex name -Computes the @emph{soundex} hash of @var{name}. Returns a string of an -initial letter and up to three digits between 0 and 6. Soundex -supposedly has the property that names that sound similar in normal -English pronunciation tend to map to the same key. - -Soundex was a classic algorithm used for manual filing of personal -records before the advent of computers. It performs adequately for -English names but has trouble with other languages. - -See Knuth, Vol. 3 @cite{Sorting and searching}, pp 391--2 - -To manage unusual inputs, @code{soundex} omits all non-alphabetic -characters. Consequently, in this implementation: - -@example -(soundex <string of blanks>) @result{} "" -(soundex "") @result{} "" -@end example - -Examples from Knuth: - -@example -(map soundex '("Euler" "Gauss" "Hilbert" "Knuth" - "Lloyd" "Lukasiewicz")) - @result{} ("E460" "G200" "H416" "K530" "L300" "L222") - -(map soundex '("Ellery" "Ghosh" "Heilbronn" "Kant" - "Ladd" "Lissajous")) - @result{} ("E460" "G200" "H416" "K530" "L300" "L222") -@end example - -Some cases in which the algorithm fails (Knuth): - -@example -(map soundex '("Rogers" "Rodgers")) @result{} ("R262" "R326") - -(map soundex '("Sinclair" "St. Clair")) @result{} ("S524" "S324") +@include hashtab.txi -(map soundex '("Tchebysheff" "Chebyshev")) @result{} ("T212" "C121") -@end example -@end defun -@node Object, Priority Queues, Hashing, Data Structures +@node Object, Priority Queues, Hash Tables, Data Structures @subsection Macroless Object System -@include objdoc.txi + +@include object.texi @node Priority Queues, Queues, Object, Data Structures @subsection Priority Queues -@code{(require 'priority-queue)} -@ftindex priority-queue - -@defun make-heap pred<? -Returns a binary heap suitable which can be used for priority queue -operations. -@end defun - -@defun heap-length heap -Returns the number of elements in @var{heap}. -@end defun - -@deffn Procedure heap-insert! heap item -Inserts @var{item} into @var{heap}. @var{item} can be inserted multiple -times. The value returned is unspecified. -@end deffn - -@defun heap-extract-max! heap -Returns the item which is larger than all others according to the -@var{pred<?} argument to @code{make-heap}. If there are no items in -@var{heap}, an error is signaled. -@end defun - -The algorithm for priority queues was taken from @cite{Introduction to -Algorithms} by T. Cormen, C. Leiserson, R. Rivest. 1989 MIT Press. - +@include priorque.txi @node Queues, Records, Priority Queues, Data Structures @subsection Queues -@code{(require 'queue)} -@ftindex queue - -A @dfn{queue} is a list where elements can be added to both the front -and rear, and removed from the front (i.e., they are what are often -called @dfn{dequeues}). A queue may also be used like a stack. - -@defun make-queue -Returns a new, empty queue. -@end defun - -@defun queue? obj -Returns @code{#t} if @var{obj} is a queue. -@end defun - -@defun queue-empty? q -Returns @code{#t} if the queue @var{q} is empty. -@end defun - -@deffn Procedure queue-push! q datum -Adds @var{datum} to the front of queue @var{q}. -@end deffn - -@deffn Procedure enquque! q datum -Adds @var{datum} to the rear of queue @var{q}. -@end deffn - -All of the following functions raise an error if the queue @var{q} is -empty. - -@defun queue-front q -Returns the datum at the front of the queue @var{q}. -@end defun - -@defun queue-rear q -Returns the datum at the rear of the queue @var{q}. -@end defun - -@deffn Prcoedure queue-pop! q -@deffnx Procedure dequeue! q -Both of these procedures remove and return the datum at the front of the -queue. @code{queue-pop!} is used to suggest that the queue is being -used like a stack. -@end deffn - - +@include queue.txi @@ -8309,7 +9026,7 @@ unspecified how record-type descriptors are represented. @c type, disjoint from all others. The @var{type-name} argument must be a @c string. The @var{field-names} argument is a list of symbols naming the @c additional @dfn{fields} to be appended to @var{field-names} of -@c @var{rtd}. It is an error if the combinded list contains any +@c @var{rtd}. It is an error if the combined list contains any @c duplicates. @c @c Record-modifiers and record-accessors for @var{rtd} work for the new @@ -8426,6 +9143,9 @@ created the type represented by @var{rtd}. * Chapter Ordering:: 'chapter-order * Sorting:: 'sort * Topological Sort:: Keep your socks on. +* Hashing:: 'hash +* Space-Filling Curves:: 'hilbert and 'sierpinski +* Soundex:: Dimension Reduction of Last Names * String Search:: Also Search from a Port. * Sequence Comparison:: 'diff and longest-common-subsequence @end menu @@ -8472,7 +9192,8 @@ Example: @defun list* obj1 obj2 @dots{} Works like @code{list} except that the cdr of the last pair is the last argument unless there is only one argument, when the result is just that -argument. Sometimes called @code{cons*}. E.g.:@refill +argument. Sometimes called @code{cons*}. E.g.: + @lisp (list* 1) @result{} 1 @@ -8537,22 +9258,23 @@ Example: @end defun @defun union l1 l2 -@code{union} returns the combination of @var{l1} and @var{l2}. -Duplicates between @var{l1} and @var{l2} are culled. Duplicates within -@var{l1} or within @var{l2} may or may not be removed. +@code{union} returns a list of all elements that are in @var{l1} or +@var{l2}. Duplicates between @var{l1} and @var{l2} are culled. +Duplicates within @var{l1} or within @var{l2} may or may not be +removed. Example: @lisp (union '(1 2 3 4) '(5 6 7 8)) - @result{} (8 7 6 5 1 2 3 4) -(union '(1 2 3 4) '(3 4 5 6)) - @result{} (6 5 1 2 3 4) + @result{} (1 2 3 4 5 6 7 8) +(union '(0 1 2 3 4) '(3 4 5 6)) + @result{} (5 6 0 1 2 3 4) @end lisp @end defun @defun intersection l1 l2 -@code{intersection} returns all elements that are in both @var{l1} and -@var{l2}. +@code{intersection} returns a list of all elements that are in both +@var{l1} and @var{l2}. Example: @lisp @@ -8564,8 +9286,8 @@ Example: @end defun @defun set-difference l1 l2 -@code{set-difference} returns all elements that are in @var{l1} but not -in @var{l2}. +@code{set-difference} returns a list of all elements that are in +@var{l1} but not in @var{l2}. Example: @lisp @@ -8576,17 +9298,31 @@ Example: @end lisp @end defun +@defun subset? list1 list2 +Returns @code{#t} if every element of @var{list1} is @code{eqv?} an +element of @var{list2}; otherwise returns @code{#f}. + +Example: +@lisp +(subset? '(1 2 3 4) '(3 4 5 6)) + @result{} #f +(subset? '(1 2 3 4) '(6 5 4 3 2 1 0)) + @result{} #t +@end lisp +@end defun + @defun member-if pred lst -@code{member-if} returns @var{lst} if @code{(@var{pred} @var{element})} -is @code{#t} for any @var{element} in @var{lst}. Returns @code{#f} if -@var{pred} does not apply to any @var{element} in @var{lst}. +@code{member-if} returns the list headed by the first element of +@var{lst} to satisfy @code{(@var{pred} @var{element})}. +@code{Member-if} returns @code{#f} if @var{pred} returns @code{#f} for +every @var{element} in @var{lst}. Example: @lisp -(member-if vector? '(1 2 3 4)) +(member-if vector? '(a 2 b 4)) @result{} #f -(member-if number? '(1 2 3 4)) - @result{} (1 2 3 4) +(member-if number? '(a 2 b 4)) + @result{} (2 b 4) @end lisp @end defun @@ -8607,7 +9343,7 @@ Example: (some odd? '(2 4 6 8)) @result{} #f -(some > '(2 3) '(1 4)) +(some > '(1 3) '(2 4)) @result{} #f @end lisp @end defun @@ -8973,7 +9709,7 @@ given identical arugments. These procedures may mutate the list they operate on, but any such mutation is undefined. -@deffn Procedure nconc args +@deffn {Procedure} nconc args @code{nconc} destructively concatenates its arguments. (Compare this with @code{append}, which copies arguments rather than destroying them.) Sometimes called @code{append!} (@pxref{Rev2 Procedures}). @@ -8984,8 +9720,8 @@ Example: You want to find the subsets of a set. Here's the obvious way: (define (subsets set) (if (null? set) '(()) - (append (mapcar (lambda (sub) (cons (car set) sub)) - (subsets (cdr set))) + (append (map (lambda (sub) (cons (car set) sub)) + (subsets (cdr set))) (subsets (cdr set))))) @end lisp But that does way more consing than you need. Instead, you could @@ -9005,7 +9741,7 @@ x @code{nconc} is the same as @code{append!} in @file{sc2.scm}. @end deffn -@deffn Procedure nreverse lst +@deffn {Procedure} nreverse lst @code{nreverse} reverses the order of elements in @var{lst} by mutating @code{cdr}s of the list. Sometimes called @code{reverse!}. @@ -9020,7 +9756,8 @@ foo Some people have been confused about how to use @code{nreverse}, thinking that it doesn't return a value. It needs to be pointed out -that@refill +that + @lisp (set! lst (nreverse lst)) @end lisp @@ -9032,21 +9769,21 @@ is the proper usage, not The example should suffice to show why this is the case. @end deffn -@deffn Procedure delete elt lst -@deffnx Procedure delete-if pred lst -@deffnx Procedure delete-if-not pred lst +@deffn {Procedure} delete elt lst +@deffnx {Procedure} delete-if pred lst +@deffnx {Procedure} delete-if-not pred lst Destructive versions of @code{remove} @code{remove-if}, and @code{remove-if-not}. Example: @lisp -(define lst '(foo bar baz bang)) +(define lst (list 'foo 'bar 'baz 'bang)) (delete 'foo lst) @result{} (bar baz bang) lst @result{} (foo bar baz bang) -(define lst '(1 2 3 4 5 6 7 8 9)) +(define lst (list 1 2 3 4 5 6 7 8 9)) (delete-if odd? lst) @result{} (2 4 6 8) lst @@ -9054,8 +9791,9 @@ lst @end lisp Some people have been confused about how to use @code{delete}, -@code{delete-if}, and @code{delete-if}, thinking that they dont' return -a value. It needs to be pointed out that@refill +@code{delete-if}, and @code{delete-if}, thinking that they don't return +a value. It needs to be pointed out that + @lisp (set! lst (delete el lst)) @end lisp @@ -9076,7 +9814,7 @@ The examples should suffice to show why this is the case. @code{and?} checks to see if all its arguments are true. If they are, @code{and?} returns @code{#t}, otherwise, @code{#f}. (In contrast to @code{and}, this is a function, so all arguments are always evaluated -and in an unspecified order.)@refill +and in an unspecified order.) Example: @lisp @@ -9090,7 +9828,7 @@ Example: @defun or? arg1 @dots{} @code{or?} checks to see if any of its arguments are true. If any is true, @code{or?} returns @code{#t}, and @code{#f} otherwise. (To -@code{or} as @code{and?} is to @code{and}.)@refill +@code{or} as @code{and?} is to @code{and}.) Example: @lisp @@ -9118,96 +9856,13 @@ pair. (Called @code{atom} in Common LISP.) @node Tree Operations, Chapter Ordering, Common List Functions, Sorting and Searching @subsection Tree operations -@code{(require 'tree)} -@ftindex tree - -These are operations that treat lists a representations of trees. - -@defun subst new old tree -@defunx subst new old tree equ? -@defunx substq new old tree -@defunx substv new old tree -@code{subst} makes a copy of @var{tree}, substituting @var{new} for -every subtree or leaf of @var{tree} which is @code{equal?} to @var{old} -and returns a modified tree. The original @var{tree} is unchanged, but -may share parts with the result. - -@code{substq} and @code{substv} are similar, but test against @var{old} -using @code{eq?} and @code{eqv?} respectively. If @code{subst} is -called with a fourth argument, @var{equ?} is the equality predicate. - -Examples: -@lisp -(substq 'tempest 'hurricane '(shakespeare wrote (the hurricane))) - @result{} (shakespeare wrote (the tempest)) -(substq 'foo '() '(shakespeare wrote (twelfth night))) - @result{} (shakespeare wrote (twelfth night . foo) . foo) -(subst '(a . cons) '(old . pair) - '((old . spice) ((old . shoes) old . pair) (old . pair))) - @result{} ((old . spice) ((old . shoes) a . cons) (a . cons)) -@end lisp -@end defun - -@defun copy-tree tree -Makes a copy of the nested list structure @var{tree} using new pairs and -returns it. All levels are copied, so that none of the pairs in the -tree are @code{eq?} to the original ones -- only the leaves are. - -Example: -@lisp -(define bar '(bar)) -(copy-tree (list bar 'foo)) - @result{} ((bar) foo) -(eq? bar (car (copy-tree (list bar 'foo)))) - @result{} #f -@end lisp -@end defun +@include tree.txi @node Chapter Ordering, Sorting, Tree Operations, Sorting and Searching @subsection Chapter Ordering -@code{(require 'chapter-order)} -@ftindex chapter-order - -The @samp{chap:} functions deal with strings which are ordered like -chapter numbers (or letters) in a book. Each section of the string -consists of consecutive numeric or consecutive aphabetic characters of -like case. - -@defun chap:string<? string1 string2 -Returns #t if the first non-matching run of alphabetic upper-case or the -first non-matching run of alphabetic lower-case or the first -non-matching run of numeric characters of @var{string1} is -@code{string<?} than the corresponding non-matching run of characters of -@var{string2}. - -@example -(chap:string<? "a.9" "a.10") @result{} #t -(chap:string<? "4c" "4aa") @result{} #t -(chap:string<? "Revised^@{3.99@}" "Revised^@{4@}") @result{} #t -@end example - -@defunx 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:string<?} than the result. - -@example -(chap:next-string "a.9") @result{} "a.10" -(chap:next-string "4c") @result{} "4d" -(chap:next-string "4z") @result{} "4aa" -(chap:next-string "Revised^@{4@}") @result{} "Revised^@{5@}" - -@end example -@end defun +@include chap.txi @node Sorting, Topological Sort, Chapter Ordering, Sorting and Searching @@ -9298,7 +9953,7 @@ Common LISP as made sense, in order to avoid NIH-itis. Each of the five functions has a required @emph{last} parameter which is a comparison function. A comparison function @code{f} is a function of -2 arguments which acts like @code{<}. For example,@refill +2 arguments which acts like @code{<}. For example, @lisp (not (f x x)) @@ -9317,7 +9972,8 @@ according to @var{less?} (that is, there is no adjacent pair @code{@dots{} x y @dots{}} for which @code{(less? y x)}). Returns @code{#f} when the sequence contains at least one out-of-order -pair. It is an error if the sequence is neither a list nor a vector. +pair. It is an error if the sequence is not a list, vector, or +string. @end defun @defun merge list1 list2 less? @@ -9330,7 +9986,7 @@ bit of work anyway. I did, however, appeal to CL to determine the @emph{order} of the arguments. @end defun -@deffn Procedure merge! list1 list2 less? +@deffn {Procedure} merge! list1 list2 less? Merges two lists, re-using the pairs of @var{list1} and @var{list2} to build the result. If the code is compiled, and @var{less?} constructs no new pairs, no pairs at all will be allocated. The first pair of the @@ -9340,22 +9996,23 @@ result will be either the first pair of @var{list1} or the first pair of The code of @code{merge} and @code{merge!} could have been quite a bit simpler, but they have been coded to reduce the amount of work done per iteration. (For example, we only have one @code{null?} test per -iteration.)@refill +iteration.) + @end deffn @defun sort sequence less? -Accepts either a list or a vector, and returns a new sequence which is -sorted. The new sequence is the same type as the input. Always -@code{(sorted? (sort sequence less?) less?)}. The original sequence is -not altered in any way. The new sequence shares its @emph{elements} -with the old one; no elements are copied. +Accepts either a list, vector, or string; and returns a new sequence +which is sorted. The new sequence is the same type as the input. +Always @code{(sorted? (sort sequence less?) less?)}. The original +sequence is not altered in any way. The new sequence shares its +@emph{elements} with the old one; no elements are copied. @end defun -@deffn Procedure sort! sequence less? +@deffn {Procedure} sort! sequence less? Returns its sorted result in the original boxes. If the original -sequence is a list, no new storage is allocated at all. If the original -sequence is a vector, the sorted elements are put back in the same -vector. +sequence is a list, no new storage is allocated at all. If the +original sequence is a vector or string, the sorted elements are put +back in the same vector or string. Some people have been confused about how to use @code{sort!}, thinking that it doesn't return a value. It needs to be pointed out that @@ -9371,7 +10028,8 @@ is the proper usage, not Note that these functions do @emph{not} accept a CL-style @samp{:key} argument. A simple device for obtaining the same expressiveness is to -define@refill +define + @lisp (define (keyed less? key) (lambda (x y) (less? (key x) (key y)))) @@ -9389,84 +10047,190 @@ in Common LISP, just write @noindent in Scheme. -@node Topological Sort, String Search, Sorting, Sorting and Searching +@node Topological Sort, Hashing, Sorting, Sorting and Searching @subsection Topological Sort -@code{(require 'topological-sort)} or @code{(require 'tsort)} -@ftindex topological-sort -@ftindex tsort +@include tsort.txi -@noindent -The algorithm is inspired by Cormen, Leiserson and Rivest (1990) -@cite{Introduction to Algorithms}, chapter 23. -@defun tsort dag pred -@defunx topological-sort dag pred -where -@table @var -@item dag -is a list of sublists. The car of each sublist is a vertex. The cdr is -the adjacency list of that vertex, i.e. a list of all vertices to which -there exists an edge from the car vertex. -@item pred -is one of @code{eq?}, @code{eqv?}, @code{equal?}, @code{=}, -@code{char=?}, @code{char-ci=?}, @code{string=?}, or @code{string-ci=?}. -@end table +@node Hashing, Space-Filling Curves, Topological Sort, Sorting and Searching +@subsection Hashing -Sort the directed acyclic graph @var{dag} so that for every edge from -vertex @var{u} to @var{v}, @var{u} will come before @var{v} in the -resulting list of vertices. +@code{(require 'hash)} +@ftindex hash -Time complexity: O (|V| + |E|) +These hashing functions are for use in quickly classifying objects. +Hash tables use these functions. -Example (from Cormen): -@quotation -Prof. Bumstead topologically sorts his clothing when getting -dressed. The first argument to `tsort' describes which -garments he needs to put on before others. (For example, -Prof Bumstead needs to put on his shirt before he puts on his -tie or his belt.) `tsort' gives the correct order of dressing: -@end quotation +@defun hashq obj k +@defunx hashv obj k +@defunx hash obj k +Returns an exact non-negative integer less than @var{k}. For each +non-negative integer less than @var{k} there are arguments @var{obj} for +which the hashing functions applied to @var{obj} and @var{k} returns +that integer. + +For @code{hashq}, @code{(eq? obj1 obj2)} implies @code{(= (hashq obj1 k) +(hashq obj2))}. + +For @code{hashv}, @code{(eqv? obj1 obj2)} implies @code{(= (hashv obj1 k) +(hashv obj2))}. + +For @code{hash}, @code{(equal? obj1 obj2)} implies @code{(= (hash obj1 k) +(hash obj2))}. + +@code{hash}, @code{hashv}, and @code{hashq} return in time bounded by a +constant. Notice that items having the same @code{hash} implies the +items have the same @code{hashv} implies the items have the same +@code{hashq}. +@end defun + + +@node Space-Filling Curves, Soundex, Hashing, Sorting and Searching +@subsection Space-Filling Curves + +@menu +* Peano-Hilbert Space-Filling Curve:: +* Sierpinski Curve:: +@end menu + +@node Peano-Hilbert Space-Filling Curve, Sierpinski Curve, Space-Filling Curves, Space-Filling Curves +@subsubsection Peano-Hilbert Space-Filling Curve + +@include phil-spc.txi + + +@node Sierpinski Curve, , Peano-Hilbert Space-Filling Curve, Space-Filling Curves +@subsubsection Sierpinski Curve + +@code{(require 'sierpinski)} +@ftindex sierpinski + +@defun make-sierpinski-indexer max-coordinate +Returns a procedure (eg hash-function) of 2 numeric arguments which +preserves @emph{nearness} in its mapping from NxN to N. +@var{max-coordinate} is the maximum coordinate (a positive integer) of a +population of points. The returned procedures is a function that takes +the x and y coordinates of a point, (non-negative integers) and returns +an integer corresponding to the relative position of that point along a +Sierpinski curve. (You can think of this as computing a (pseudo-) +inverse of the Sierpinski spacefilling curve.) + +Example use: Make an indexer (hash-function) for integer points lying in +square of integer grid points [0,99]x[0,99]: @example -(require 'tsort) -@ftindex tsort -(tsort '((shirt tie belt) - (tie jacket) - (belt jacket) - (watch) - (pants shoes belt) - (undershorts pants shoes) - (socks shoes)) - eq?) -@result{} -(socks undershorts pants shoes watch shirt belt tie jacket) +(define space-key (make-sierpinski-indexer 100)) +@end example +Now let's compute the index of some points: +@example +(space-key 24 78) @result{} 9206 +(space-key 23 80) @result{} 9172 +@end example + +Note that locations (24, 78) and (23, 80) are near in index and +therefore, because the Sierpinski spacefilling curve is continuous, we +know they must also be near in the plane. Nearness in the plane does +not, however, necessarily correspond to nearness in index, although it +@emph{tends} to be so. + +Example applications: +@itemize @bullet + +@item +Sort points by Sierpinski index to get heuristic solution to +@emph{travelling salesman problem}. For details of performance, +see L. Platzman and J. Bartholdi, "Spacefilling curves and the +Euclidean travelling salesman problem", JACM 36(4):719--737 +(October 1989) and references therein. + +@item +Use Sierpinski index as key by which to store 2-dimensional data +in a 1-dimensional data structure (such as a table). Then +locations that are near each other in 2-d space will tend to +be near each other in 1-d data structure; and locations that +are near in 1-d data structure will be near in 2-d space. This +can significantly speed retrieval from secondary storage because +contiguous regions in the plane will tend to correspond to +contiguous regions in secondary storage. (This is a standard +technique for managing CAD/CAM or geographic data.) + +@end itemize +@end defun + + +@node Soundex, String Search, Space-Filling Curves, Sorting and Searching +@subsection Soundex + +@code{(require 'soundex)} +@ftindex soundex + +@defun soundex name +Computes the @emph{soundex} hash of @var{name}. Returns a string of an +initial letter and up to three digits between 0 and 6. Soundex +supposedly has the property that names that sound similar in normal +English pronunciation tend to map to the same key. + +Soundex was a classic algorithm used for manual filing of personal +records before the advent of computers. It performs adequately for +English names but has trouble with other languages. + +See Knuth, Vol. 3 @cite{Sorting and searching}, pp 391--2 + +To manage unusual inputs, @code{soundex} omits all non-alphabetic +characters. Consequently, in this implementation: + +@example +(soundex <string of blanks>) @result{} "" +(soundex "") @result{} "" +@end example + +Examples from Knuth: + +@example +(map soundex '("Euler" "Gauss" "Hilbert" "Knuth" + "Lloyd" "Lukasiewicz")) + @result{} ("E460" "G200" "H416" "K530" "L300" "L222") + +(map soundex '("Ellery" "Ghosh" "Heilbronn" "Kant" + "Ladd" "Lissajous")) + @result{} ("E460" "G200" "H416" "K530" "L300" "L222") +@end example + +Some cases in which the algorithm fails (Knuth): + +@example +(map soundex '("Rogers" "Rodgers")) @result{} ("R262" "R326") + +(map soundex '("Sinclair" "St. Clair")) @result{} ("S524" "S324") + +(map soundex '("Tchebysheff" "Chebyshev")) @result{} ("T212" "C121") @end example @end defun -@node String Search, Sequence Comparison, Topological Sort, Sorting and Searching +@node String Search, Sequence Comparison, Soundex, Sorting and Searching @subsection String Search @code{(require 'string-search)} @ftindex string-search -@deffn Procedure string-index string char -@deffnx Procedure string-index-ci string char +@deffn {Procedure} string-index string char +@deffnx {Procedure} string-index-ci string char Returns the index of the first occurence of @var{char} within @var{string}, or @code{#f} if the @var{string} does not contain a character @var{char}. @end deffn -@deffn Procedure string-reverse-index string char -@deffnx Procedure string-reverse-index-ci string char +@deffn {Procedure} string-reverse-index string char +@deffnx {Procedure} string-reverse-index-ci string char Returns the index of the last occurence of @var{char} within @var{string}, or @code{#f} if the @var{string} does not contain a character @var{char}. @end deffn -@deffn procedure substring? pattern string -@deffnx procedure substring-ci? pattern string +@deffn {Procedure} substring? pattern string +@deffnx {Procedure} substring-ci? pattern string Searches @var{string} to see if some substring of @var{string} is equal to @var{pattern}. @code{substring?} returns the index of the first character of the first substring of @var{string} that is equal to @@ -9480,19 +10244,19 @@ character of the first substring of @var{string} that is equal to @end example @end deffn -@deffn Procedure find-string-from-port? str in-port max-no-chars +@deffn {Procedure} find-string-from-port? str in-port max-no-chars Looks for a string @var{str} within the first @var{max-no-chars} chars of the input port @var{in-port}. -@deffnx Procedure find-string-from-port? str in-port +@deffnx {Procedure} find-string-from-port? str in-port When called with two arguments, the search span is limited by the end of the input stream. -@deffnx Procedure find-string-from-port? str in-port char +@deffnx {Procedure} find-string-from-port? str in-port char Searches up to the first occurrence of character @var{char} in @var{str}. -@deffnx Procedure find-string-from-port? str in-port proc +@deffnx {Procedure} find-string-from-port? str in-port proc Searches up to the first occurrence of the procedure @var{proc} returning non-false when called with a character (from @var{in-port}) argument. @@ -9510,8 +10274,13 @@ open to a pipe or other communication channel. @defun string-subst txt old1 new1 @dots{} Returns a copy of string @var{txt} with all occurrences of string -@var{old1} in @var{txt} replaced with @var{new1}, @var{old2} replaced -with @var{new2} @dots{}. +@var{old1} in @var{txt} replaced with @var{new1}; then @var{old2} +replaced with @var{new2} @dots{}. Matches are found from the left. +Matches do not overlap. +@end defun + +@defun count-newlines str +Returns the number of @samp{#\newline} characters in string @var{str}. @end defun @@ -9555,15 +10324,15 @@ up here. @code{(require 'string-case)} @ftindex string-case -@deffn Procedure string-upcase str -@deffnx Procedure string-downcase str -@deffnx Procedure string-capitalize str +@deffn {Procedure} string-upcase str +@deffnx {Procedure} string-downcase str +@deffnx {Procedure} string-capitalize str The obvious string conversion routines. These are non-destructive. @end deffn @defun string-upcase! str @defunx string-downcase! str -@defunx string-captialize! str +@defunx string-capitalize! str The destructive versions of the functions above. @end defun @@ -9579,6 +10348,29 @@ symbol case; the case of symbol characters is not changed. #f is converted to the empty string (symbol). @end defun +@defun StudlyCapsExpand str delimiter +@defunx StudlyCapsExpand str +@var{delimiter} must be a string or character. If absent, +@var{delimiter} defaults to @samp{-}. @code{StudlyCapsExpand} returns a +copy of @var{str} where @var{delimiter} is inserted between each +lower-case character immediately followed by an upper-case character; +and between two upper-case characters immediately followed by a +lower-case character. + +@example +(StudlyCapsExpand "aX" " ") @result{} "a X" +(StudlyCapsExpand "aX" "..") @result{} "a..X" +(StudlyCapsExpand "AX") @result{} "AX" +(StudlyCapsExpand "Ax") @result{} "Ax" +(StudlyCapsExpand "AXLE") @result{} "AXLE" +(StudlyCapsExpand "aAXACz") @result{} "a-AXA-Cz" +(StudlyCapsExpand "AaXACz") @result{} "Aa-XA-Cz" +(StudlyCapsExpand "AAaXACz") @result{} "A-Aa-XA-Cz" +(StudlyCapsExpand "AAaXAC") @result{} "A-Aa-XAC" +@end example + +@end defun + @node String Ports, Line I/O, String-Case, Procedures @@ -9587,14 +10379,14 @@ converted to the empty string (symbol). @code{(require 'string-port)} @ftindex string-port -@deffn Procedure call-with-output-string proc +@deffn {Procedure} call-with-output-string proc @var{proc} must be a procedure of one argument. This procedure calls @var{proc} with one argument: a (newly created) output port. When the function returns, the string composed of the characters written into the port is returned. @end deffn -@deffn Procedure call-with-input-string string proc +@deffn {Procedure} call-with-input-string string proc @var{proc} must be a procedure of one argument. This procedure calls @var{proc} with one argument: an (newly created) input port from which @var{string}'s contents may be read. When @var{proc} returns, the port @@ -9621,25 +10413,25 @@ returned. This module implements asynchronous (non-polled) time-sliced multi-processing in the SCM Scheme implementation using procedures @code{alarm} and @code{alarm-interrupt}. -@findex alarm -@findex alarm-interrupt +@cindex alarm +@cindex alarm-interrupt Until this is ported to another implementation, consider it an example of writing schedulers in Scheme. -@deffn Procedure add-process! proc +@deffn {Procedure} add-process! proc Adds proc, which must be a procedure (or continuation) capable of accepting accepting one argument, to the @code{process:queue}. The value returned is unspecified. The argument to @var{proc} should be ignored. If @var{proc} returns, the process is killed. @end deffn -@deffn Procedure process:schedule! +@deffn {Procedure} process:schedule! Saves the current process on @code{process:queue} and runs the next process from @code{process:queue}. The value returned is unspecified. @end deffn -@deffn Procedure kill-process! +@deffn {Procedure} kill-process! Kills the current process and runs the next process from @code{process:queue}. If there are no more processes on @code{process:queue}, @code{(slib:exit)} is called (@pxref{System}). @@ -9724,7 +10516,7 @@ A unit exponent follows the unit, separated by a CIRCUMFLEX (@samp{^}). Exponents may be positive or negative. Fractional exponents must be parenthesized. -@subsubheading SI Prefixes +@subsubsection SI Prefixes @example Factor Name Symbol | Factor Name Symbol ====== ==== ====== | ====== ==== ====== @@ -9740,7 +10532,7 @@ parenthesized. 1e1 deka da | 1e-24 yocto y @end example -@subsubheading Binary Prefixes +@subsubsection Binary Prefixes These binary prefixes are valid only with the units B (byte) and bit. However, decimal prefixes can also be used with bit; and decimal @@ -9757,7 +10549,7 @@ multiple (not submultiple) prefixes can also be used with B (byte). 1.024e3 (2^10) kibi Ki @end example -@subsubheading Unit Symbols +@subsubsection Unit Symbols @example Type of Quantity Name Symbol Equivalent @@ -9861,6 +10653,7 @@ if linear conversion (by a factor) is not possible. @menu +* RnRS:: Revised Reports on Scheme * With-File:: 'with-file * Transcripts:: 'transcript * Rev2 Procedures:: 'rev2-procedures @@ -9868,14 +10661,54 @@ if linear conversion (by a factor) is not possible. * Multi-argument / and -:: 'multiarg/and- * Multi-argument Apply:: 'multiarg-apply * Rationalize:: 'rationalize -* Promises:: 'promise +* Promises:: 'delay * Dynamic-Wind:: 'dynamic-wind * Eval:: 'eval * Values:: 'values * SRFI:: 'http://srfi.schemers.org/srfi-0/srfi-0.html @end menu -@node With-File, Transcripts, Standards Support, Standards Support +@node RnRS, With-File, Standards Support, Standards Support +@subsection RnRS + +@noindent +The @code{r2rs}, @code{r3rs}, @code{r4rs}, and @code{r5rs} features +attempt to provide procedures and macros to bring a Scheme +implementation to the desired version of Scheme. + +@deftp {Feature} r2rs +@ftindex r2rs +Requires features implementing procedures and optional procedures +specified by @cite{Revised^2 Report on the Algorithmic Language Scheme}; +namely @code{rev3-procedures} and @code{rev2-procedures}. +@end deftp + +@deftp {Feature} r3rs +@ftindex r3rs +Requires features implementing procedures and optional procedures +specified by @cite{Revised^3 Report on the Algorithmic Language Scheme}; +namely @code{rev3-procedures}. + +@emph{Note:} SLIB already mandates the @code{r3rs} procedures which can +be portably implemented in @code{r4rs} implementations. +@end deftp + +@deftp {Feature} r4rs +@ftindex r4rs +Requires features implementing procedures and optional procedures +specified by @cite{Revised^4 Report on the Algorithmic Language Scheme}; +namely @code{rev4-optional-procedures}. +@end deftp + +@deftp {Feature} r5rs +@ftindex r5rs +Requires features implementing procedures and optional procedures +specified by @cite{Revised^5 Report on the Algorithmic Language Scheme}; +namely @code{values}, @code{macro}, and @code{eval}. +@end deftp + + +@node With-File, Transcripts, RnRS, Standards Support @subsection With-File @code{(require 'with-file)} @@ -9910,13 +10743,13 @@ Redefines @code{read-char}, @code{read}, @code{write-char}, The procedures below were specified in the @cite{Revised^2 Report on Scheme}. @strong{N.B.}: The symbols @code{1+} and @code{-1+} are not -@cite{R4RS} syntax. Scheme->C, for instance, barfs on this +@cite{R4RS} syntax. Scheme->C, for instance, chokes on this module. -@deffn Procedure substring-move-left! string1 start1 end1 string2 start2 -@deffnx Procedure substring-move-right! string1 start1 end1 string2 start2 +@deffn {Procedure} substring-move-left! string1 start1 end1 string2 start2 +@deffnx {Procedure} substring-move-right! string1 start1 end1 string2 start2 @var{string1} and @var{string2} must be a strings, and @var{start1}, -@var{start2} and @var{end1} must be exact integers satisfying@refill +@var{start2} and @var{end1} must be exact integers satisfying @display 0 <= @var{start1} <= @var{end1} <= (string-length @var{string1}) @@ -9933,7 +10766,7 @@ increasing indices. @code{substring-move-right!} stores characters in time order of increasing indeces. @end deffn -@deffn Procedure substring-fill! string start end char +@deffn {Procedure} substring-fill! string start end char Fills the elements @var{start}--@var{end} of @var{string} with the character @var{char}. @end deffn @@ -9942,7 +10775,7 @@ character @var{char}. @equiv{} @code{(= 0 (string-length @var{str}))} @end defun -@deffn Procedure append! pair1 @dots{} +@deffn {Procedure} append! pair1 @dots{} Destructively appends its arguments. Equivalent to @code{nconc}. @end deffn @@ -9986,7 +10819,7 @@ For the specification of these optional procedures, @defun string-copy @end defun -@deffn Procedure string-fill! s obj +@deffn {Procedure} string-fill! s obj @end deffn @defun list->vector l @@ -9995,7 +10828,7 @@ For the specification of these optional procedures, @defun vector->list s @end defun -@deffn Procedure vector-fill! s obj +@deffn {Procedure} vector-fill! s obj @end deffn @@ -10005,25 +10838,15 @@ For the specification of these optional procedures, @node Multi-argument / and -, Multi-argument Apply, Rev4 Optional Procedures, Standards Support @subsection Multi-argument / and - -@code{(require 'mutliarg/and-)} -@ftindex mutliarg +@code{(require 'multiarg/and-)} +@ftindex multiarg For the specification of these optional forms, @xref{Numerical -operations, , ,r4rs, Revised(4) Scheme}. The @code{two-arg:}* forms are -only defined if the implementation does not support the many-argument -forms. - -@defun two-arg:/ n1 n2 -The original two-argument version of @code{/}. -@end defun +operations, , ,r4rs, Revised(4) Scheme}. @defun / dividend divisor1 @dots{} @end defun -@defun two-arg:- n1 n2 -The original two-argument version of @code{-}. -@end defun - @defun - minuend subtrahend1 @dots{} @end defun @@ -10041,61 +10864,16 @@ The original two-argument version of @code{-}. For the specification of this optional form, @xref{Control features, , ,r4rs, Revised(4) Scheme}. -@defun two-arg:apply proc l -The implementation's native @code{apply}. Only defined for -implementations which don't support the many-argument version. -@end defun - @defun apply proc arg1 @dots{} @end defun - - @node Rationalize, Promises, Multi-argument Apply, Standards Support @subsection Rationalize -@code{(require 'rationalize)} -@ftindex rationalize - -The procedure @dfn{rationalize} is interesting because most programming -languages do not provide anything analogous to it. Thanks to Alan -Bawden for contributing this algorithm. - -@defun rationalize x y -Computes the correct result for exact arguments (provided the -implementation supports exact rational numbers of unlimited precision); -and produces a reasonable answer for inexact arguments when inexact -arithmetic is implemented using floating-point. -@end defun - -@code{Rationalize} has limited use in implementations lacking exact -(non-integer) rational numbers. The following procedures return a list -of the numerator and denominator. - -@defun find-ratio x y -@code{find-ratio} returns the list of the @emph{simplest} -numerator and denominator whose quotient differs from @var{x} by no more -than @var{y}. +@include ratize.txi -@format -@t{(find-ratio 3/97 .0001) @result{} (3 97) -(find-ratio 3/97 .001) @result{} (1 32) -} -@end format -@end defun - -@defun find-ratio-between x y -@code{find-ratio-between} returns the list of the @emph{simplest} -numerator and denominator between @var{x} and @var{y}. - -@format -@t{(find-ratio-between 2/7 3/5) @result{} (1 2) -(find-ratio-between -3/5 -2/7) @result{} (-1 2) -} -@end format -@end defun @node Promises, Dynamic-Wind, Rationalize, Standards Support @@ -10107,13 +10885,21 @@ numerator and denominator between @var{x} and @var{y}. @defun make-promise proc @end defun +@defun force promise +@end defun + +@code{(require 'delay)} provides @code{force} and @code{delay}: + +@defmac delay obj Change occurrences of @code{(delay @var{expression})} to -@code{(make-promise (lambda () @var{expression}))} and @code{(define -force promise:force)} to implement promises if your implementation -doesn't support them -(@pxref{Control features, , ,r4rs, Revised(4) Scheme}). +@example +(make-promise (lambda () @var{expression})) +@end example + +@end defmac +(@pxref{Control features, , ,r4rs, Revised(4) Scheme}). @node Dynamic-Wind, Eval, Promises, Standards Support @@ -10126,7 +10912,7 @@ This facility is a generalization of Common LISP @code{unwind-protect}, designed to take into account the fact that continuations produced by @code{call-with-current-continuation} may be reentered. -@deffn Procedure dynamic-wind thunk1 thunk2 thunk3 +@deffn {Procedure} dynamic-wind thunk1 thunk2 thunk3 The arguments @var{thunk1}, @var{thunk2}, and @var{thunk3} must all be procedures of no arguments (thunks). @@ -10150,6 +10936,7 @@ the time of the error or interrupt. @subsection Eval @code{(require 'eval)} +@ftindex eval @defun eval expression environment-specifier @@ -10270,15 +11057,49 @@ unspecified. @menu * SRFI-1:: list-processing +* SRFI-2:: guarded LET* special form +* SRFI-8:: Binding to multiple values +* SRFI-9:: Defining Record Types @end menu -@node SRFI-1, , SRFI, SRFI +@node SRFI-1, SRFI-2, SRFI, SRFI @subsubsection SRFI-1 @include srfi-1.txi +@node SRFI-2, SRFI-8, SRFI-1, SRFI +@subsubsection SRFI-2 + +@include srfi-2.txi -@node Session Support, Extra-SLIB Packages, Standards Support, Other Packages +@node SRFI-8, SRFI-9, SRFI-2, SRFI +@subsubsection SRFI-8 + +@include srfi-8.txi + +@node SRFI-9, , SRFI-8, SRFI +@subsubsection SRFI-9 + +@code{(require 'srfi-9)} +@ftindex srfi-9 + +@url{http://srfi.schemers.org/srfi-9/srfi-9.html} + +@defspec define-record-type <type-name> (<constructor-name> <field-tag> ...) <predicate-name> <field spec> ... + +Where +@lisp +<field-spec> @equiv{} (<field-tag> <accessor-name>) + @equiv{} (<field-tag> <accessor-name> <modifier-name>) + +@end lisp + +@code{define-record-type} is a syntax wrapper for the SLIB +@code{record} module. +@end defspec + + +@node Session Support, System Interface, Standards Support, Other Packages @section Session Support @menu @@ -10287,7 +11108,6 @@ unspecified. * Debug:: To err is human ... * Breakpoints:: Pause execution * Trace:: 'trace -* System Interface:: 'system, 'getenv, and 'net-clients @end menu @@ -10299,7 +11119,7 @@ unspecified. Here is a read-eval-print-loop which, given an eval, evaluates forms. -@deffn Procedure repl:top-level repl:eval +@deffn {Procedure} repl:top-level repl:eval @code{read}s, @code{repl:eval}s and @code{write}s expressions from @code{(current-input-port)} to @code{(current-output-port)} until an end-of-file is encountered. @code{load}, @code{slib:eval}, @@ -10307,7 +11127,7 @@ end-of-file is encountered. @code{load}, @code{slib:eval}, @code{repl:top-level}. @end deffn -@deffn Procedure repl:quit +@deffn {Procedure} repl:quit Exits from the invocation of @code{repl:top-level}. @end deffn @@ -10350,9 +11170,9 @@ Common-Lisp's @ref{Format} from consideration; even when variables bit-vectors are @emph{not} limited. @end quotation -@deffn Procedure qp arg1 @dots{} -@deffnx Procedure qpn arg1 @dots{} -@deffnx Procedure qpr arg1 @dots{} +@deffn {Procedure} qp arg1 @dots{} +@deffnx {Procedure} qpn arg1 @dots{} +@deffnx {Procedure} qpr arg1 @dots{} @code{qp} writes its arguments, separated by spaces, to @code{(current-output-port)}. @code{qp} compresses printing by substituting @samp{...} for substructure it does not have sufficient @@ -10362,8 +11182,11 @@ its last argument. @end deffn @defvar *qp-width* -@code{*qp-width*} is the largest number of characters that @code{qp} -should use. +@var{*qp-width*} is the largest number of characters that @code{qp} +should use. If @var{*qp-width*} is #f, then all items will be +@code{write}n. If @var{*qp-width*} is 0, then all items except +procedures will be @code{write}n; procedures will be indicated by +@samp{#[proc]}. @end defvar @node Debug, Breakpoints, Quick Print, Session Support @@ -10387,18 +11210,20 @@ printer for @code{qp}. This example shows how to do this: @ftindex debug @end example -@deffn Procedure trace-all file @dots{} +@deffn {Procedure} trace-all file @dots{} Traces (@pxref{Trace}) all procedures @code{define}d at top-level in @file{file} @dots{}. -@deffnx Procedure track-all file @dots{} + +@deffnx {Procedure} track-all file @dots{} Tracks (@pxref{Trace}) all procedures @code{define}d at top-level in @file{file} @dots{}. -@deffnx Procedure stack-all file @dots{} + +@deffnx {Procedure} stack-all file @dots{} Stacks (@pxref{Trace}) all procedures @code{define}d at top-level in @file{file} @dots{}. @end deffn -@deffn Procedure break-all file @dots{} +@deffn {Procedure} break-all file @dots{} Breakpoints (@pxref{Breakpoints}) all procedures @code{define}d at top-level in @file{file} @dots{}. @end deffn @@ -10483,7 +11308,7 @@ To unbreak, type @end lisp @end defun -@node Trace, System Interface, Breakpoints, Session Support +@node Trace, , Breakpoints, Session Support @subsection Tracing @code{(require 'trace)} @@ -10567,6 +11392,10 @@ supported by your implementation, these might be more convenient to use. @defun tracef proc @defunx tracef proc name +@defunx trackf proc +@defunx trackf proc name +@defunx stackf proc +@defunx stackf proc name To trace, type @lisp (set! @var{symbol} (tracef @var{symbol})) @@ -10597,8 +11426,8 @@ To untrace, type @end defun -@node System Interface, , Trace, Session Support -@subsection System Interface +@node System Interface, Extra-SLIB Packages, Session Support, Other Packages +@section System Interface @noindent If @code{(provided? 'getenv)}: @@ -10616,18 +11445,43 @@ Executes the @var{command-string} on the computer and returns the integer status code. @end defun + +@menu +* Directories:: +* Transactions:: +* CVS:: +@end menu + +@node Directories, Transactions, System Interface, System Interface +@subsection Directories + +@include dirs.txi + + +@node Transactions, CVS, Directories, System Interface +@subsection Transactions + @noindent If @code{system} is provided by the Scheme implementation, the -@dfn{net-clients} package provides interfaces to common network client -programs like FTP, mail, and Netscape. +@dfn{transact} package provides functions for file-locking and +file-replacement transactions. + +@code{(require 'transact)} +@ftindex transact + +@include transact.txi -@code{(require 'net-clients)} -@ftindex net-clients -@include nclients.txi +@node CVS, , Transactions, System Interface +@subsection CVS +@code{(require 'cvs)} +@ftindex cvs -@node Extra-SLIB Packages, , Session Support, Other Packages +@include cvs.txi + + +@node Extra-SLIB Packages, , System Interface, Other Packages @section Extra-SLIB Packages Several Scheme packages have been written using SLIB. There are several @@ -10690,18 +11544,19 @@ http://www.cs.tut.fi/staff/pk/scheme/psd/article/article.html @sp 1 @item SCHELOG -is an embedding of Prolog in Scheme. +is an embedding of Prolog in Scheme.@* @ifset html -<A HREF="http://www.cs.rice.edu/CS/PLT/packages/schelog/"> +<A HREF="http://www.ccs.neu.edu/~dorai/schelog/schelog.html"> @end ifset -http://www.cs.rice.edu/CS/PLT/packages/schelog/ +http://www.ccs.neu.edu/~dorai/schelog/schelog.html @ifset html </A> @end ifset @sp 1 @item JFILTER -is a Scheme program which converts text among the JIS, EUC, and Shift-JIS Japanese character sets. +is a Scheme program which converts text among the JIS, EUC, and +Shift-JIS Japanese character sets.@* @ifset html <A HREF="http://www.sci.toyama-u.ac.jp/~iwao/Scheme/Jfilter/index.html"> @end ifset @@ -10733,13 +11588,13 @@ Aubrey Jaffer <agj @@ alum.mit.edu>@* * Porting:: SLIB to new platforms. * Coding Guidelines:: How to write modules for SLIB. * Copyrights:: Intellectual propery issues. +* About this manual:: @end menu @node Installation, Porting, About SLIB, About SLIB @section Installation - @ifset html <A NAME="Installation"> @end ifset @@ -10747,6 +11602,8 @@ Aubrey Jaffer <agj @@ alum.mit.edu>@* </A> @end ifset +@cindex install +@cindex installation There are four parts to installation: @itemize @bullet @@ -10818,6 +11675,15 @@ SLIB), then: (require 'new-catalog) @end example +The catalog also supports color-name dictionaries. With an +SLIB-installed scheme implementation, type: +@example +(require 'color-names) +(make-slib-color-name-db) +(require 'new-catalog) +(slib:exit) +@end example + @subsection Implementation-specific Instructions Multiple implementations of Scheme can all use the same SLIB directory. @@ -10885,7 +11751,7 @@ initialization file. To use SLIB in MzScheme, set the @var{SCHEME_LIBRARY_PATH} environment variable to the installed SLIB location; then invoke MzScheme thus: -@code{mzscheme -L init.ss slibinit} +@code{mzscheme -f $@{SCHEME_LIBRARY_PATH@}DrScheme.init} @end deftp @deftp Implementation {MIT Scheme} @@ -10903,10 +11769,15 @@ variable to the installed SLIB location; then invoke MzScheme thus: If there is no initialization file for your Scheme implementation, you will have to create one. Your Scheme implementation must be largely -compliant with @cite{IEEE Std 1178-1990}, @cite{Revised^4 Report on the -Algorithmic Language Scheme}, or @cite{Revised^5 Report on the -Algorithmic Language Scheme} in order to support SLIB. @footnote{If you -are porting a @cite{Revised^3 Report on the Algorithmic Language Scheme} +compliant with +@lisp +@cite{IEEE Std 1178-1990}, +@cite{Revised^4 Report on the Algorithmic Language Scheme}, or +@cite{Revised^5 Report on the Algorithmic Language Scheme} +@end lisp +@noindent +in order to support SLIB. @footnote{If you are porting a +@cite{Revised^3 Report on the Algorithmic Language Scheme} implementation, then you will need to finish writing @file{sc4sc3.scm} and @code{load} it from your initialization file.} @@ -10921,9 +11792,9 @@ Your customized version should then be loaded as part of your scheme implementation's initialization. It will load @file{require.scm} from the library; this will allow the use of @code{provide}, @code{provided?}, and @code{require} along with the @dfn{vicinity} -functions (these functions are documented in the section @ref{Require}). -The rest of the library will then be accessible in a system independent -fashion. +functions (these functions are documented in the sections +@ref{Feature} and @ref{Require}). The rest of the library will then +be accessible in a system independent fashion. Please mail new working configuration files to @code{agj @@ alum.mit.edu} so that they can be included in the SLIB distribution. @@ -10935,28 +11806,39 @@ so that they can be included in the SLIB distribution. All library packages are written in IEEE P1178 Scheme and assume that a configuration file and @file{require.scm} package have already been loaded. Other versions of Scheme can be supported in library packages -as well by using, for example, @code{(provided? 'rev3-report)} or -@code{(require 'rev3-report)} (@pxref{Require}). -@ftindex rev3-report +as well by using, for example, @code{(provided? 'r3rs)} or +@code{(require 'r3rs)} (@pxref{Require}). +@ftindex r3rs + +If a procedure defined in a module is called by other procedures in +that module, then those procedures should instead call an alias +defined in that module: -The module name and @samp{:} should prefix each symbol defined in the -package. Definitions for external use should then be exported by having -@code{(define foo module-name:foo)}. +@lisp +(define module-name:foo foo) +@end lisp + +The module name and @samp{:} should prefix that symbol for the +internal name. Do not export internal aliases. -Code submitted for inclusion in SLIB should not duplicate routines -already in SLIB files. Use @code{require} to force those library -routines to be used by your package. Care should be taken that there -are no circularities in the @code{require}s and @code{load}s between the -library packages. +A procedure is exported from a module by putting Schmooz-style +comments (@pxref{Schmooz}) or @samp{;@@} at the beginning of the line +immediately preceding the definition (@code{define}, +@code{define-syntax}, or @code{defmacro}). Modules, exports and other +relevant issues are discussed in @ref{Compiling Scheme}. + +Code submitted for inclusion in SLIB should not duplicate (more than +one) routines already in SLIB files. Use @code{require} to force +those library routines to be used by your package. Documentation should be provided in Emacs Texinfo format if possible, -But documentation must be provided. +but documentation must be provided. Your package will be released sooner with SLIB if you send me a file which tests your code. Please run this test @emph{before} you send me the code! -@subheading Modifications +@subsection Modifications Please document your changes. A line or two for @file{ChangeLog} is sufficient for simple fixes or extensions. Look at the format of @@ -10975,7 +11857,7 @@ Please @emph{do not} reformat the source code with your favorite beautifier, make 10 fixes, and send me the resulting source code. I do not have the time to fish through 10000 diffs to find your 10 real fixes. -@node Copyrights, , Coding Guidelines, About SLIB +@node Copyrights, About this manual, Coding Guidelines, About SLIB @section Copyrights @ifset html @@ -10986,6 +11868,7 @@ not have the time to fish through 10000 diffs to find your 10 real fixes. @end ifset This section has instructions for SLIB authors regarding copyrights. +@cindex copyright Each package in SLIB must either be in the public domain, or come with a statement of terms permitting users to copy, redistribute and modify it. @@ -10995,88 +11878,111 @@ The comments at the beginning of @file{require.scm} and If your code or changes amount to less than about 10 lines, you do not need to add your copyright or send a disclaimer. -@subheading Putting code into the Public Domain +@subsection Putting code into the Public Domain In order to put code in the public domain you should sign a copyright disclaimer and send it to the SLIB maintainer. Contact agj @@ alum.mit.edu for the address to mail the disclaimer to. +@need 1000 @quotation -I, @var{name}, hereby affirm that I have placed the software package -@var{name} in the public domain. +I, @var{<my-name>}, hereby affirm that I have placed the software +package @var{<name>} in the public domain. I affirm that I am the sole author and sole copyright holder for the software package, that I have the right to place this software package in the public domain, and that I will do nothing to undermine this status in the future. - @flushright @var{signature and date} @end flushright @end quotation This wording assumes that you are the sole author. If you are not the -sole author, the wording needs to be different. If you don't want to be -bothered with sending a letter every time you release or modify a +sole author, the wording needs to be different. If you don't want to +be bothered with sending a letter every time you release or modify a module, make your letter say that it also applies to your future revisions of that module. -Make sure no employer has any claim to the copyright on the work you are -submitting. If there is any doubt, create a copyright disclaimer and -have your employer sign it. Mail the signed disclaimer to the SLIB -maintainer. Contact agj @@ alum.mit.edu for the address to mail the -disclaimer to. An example disclaimer follows. +Make sure no employer has any claim to the copyright on the work you +are submitting. If there is any doubt, create a copyright disclaimer +and have your employer sign it. Mail the signed disclaimer to the +SLIB maintainer. Contact agj @@ alum.mit.edu for the address to mail +the disclaimer to. An example disclaimer follows. -@subheading Explicit copying terms +@subsection Explicit copying terms @noindent -If you submit more than about 10 lines of code which you are not placing -into the Public Domain (by sending me a disclaimer) you need to: +If you submit more than about 10 lines of code which you are not +placing into the Public Domain (by sending me a disclaimer) you need +to: @itemize @bullet @item Arrange that your name appears in a copyright line for the appropriate -year. Multiple copyright lines are acceptable. +year. Multiple copyright lines are acceptable. @item -With your copyright line, specify any terms you require to be different -from those already in the file. +With your copyright line, specify any terms you require to be +different from those already in the file. @item -Make sure no employer has any claim to the copyright on the work you are -submitting. If there is any doubt, create a copyright disclaimer and -have your employer sign it. Mail the signed disclaim to the SLIB +Make sure no employer has any claim to the copyright on the work you +are submitting. If there is any doubt, create a copyright disclaimer +and have your employer sign it. Mail the signed disclaim to the SLIB maintainer. Contact agj @@ alum.mit.edu for the address to mail the disclaimer to. @end itemize -@subheading Example: Company Copyright Disclaimer +@subsection Example: Company Copyright Disclaimer -This disclaimer should be signed by a vice president or general manager -of the company. If you can't get at them, anyone else authorized to -license out software produced there will do. Here is a sample wording: +This disclaimer should be signed by a vice president or general +manager of the company. If you can't get at them, anyone else +authorized to license out software produced there will do. Here is a +sample wording: @quotation -@var{employer} Corporation hereby disclaims all copyright -interest in the program @var{program} written by @var{name}. +@var{<employer>} Corporation hereby disclaims all copyright +interest in the program @var{<program>} written by @var{<name>}. -@var{employer} Corporation affirms that it has no other intellectual -property interest that would undermine this release, and will do nothing -to undermine it in the future. +@var{<employer>} Corporation affirms that it has no other intellectual +property interest that would undermine this release, and will do +nothing to undermine it in the future. @flushleft -@var{signature and date}, -@var{name}, @var{title}, @var{employer} Corporation +@var{<signature and date>}, +@var{<name>}, @var{<title>}, @var{<employer>} Corporation @end flushleft @end quotation +@node About this manual, , Copyrights, About SLIB +@section About this manual + +@itemize @bullet +@item +Entries that are labeled as Functions are called for their return +values. Entries that are labeled as Procedures are called primarily for +their side effects. + +@item +Examples in this text were produced using the @code{scm} Scheme +implementation. + +@item +At the beginning of each section, there is a line that looks like +@ftindex feature +@code{(require 'feature)}. Include this line in your code prior to +using the package. +@end itemize + + @node Index, , About SLIB, Top -@c @node Procedure and Macro Index, Variable Index, About SLIB, Top +@c @node Procedure and Macro Index, Operator Index, About SLIB, Top @unnumbered Procedure and Macro Index This is an alphabetical list of all the procedures and macros in SLIB. @printindex fn -@c @node Variable Index, Concept Index, Procedure and Macro Index, Top +@c @node Variable Index, Concept Index, Operator Index, Top @unnumbered Variable Index This is an alphabetical list of all the global variables in SLIB. diff --git a/solid.scm b/solid.scm new file mode 100644 index 0000000..8b0ea56 --- /dev/null +++ b/solid.scm @@ -0,0 +1,943 @@ +;;; "solid.scm" Solid Modeling with VRML97 +; 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 'printf) +(require 'array) +(require 'array-for-each) +(require 'color) +(require 'color-space) ;for xyY:normalize-colors +(require-if 'compiling 'daylight) + +;;@ifset html +;;<A NAME="Solid"> +;;@end ifset +;;@code{(require 'solid)} +;;@ifset html +;;</A> +;;@end ifset +;;@ftindex solids +;;@ftindex solid +;;@ftindex solid-modeling +;; +;;@noindent +;;@uref{http://swissnet.ai.mit.edu/~jaffer/Solid/#Example} gives an +;;example use of this package. + +(define pi/180 (/ (* 4 (atan 1)) 180)) + +;;@body Returns the VRML97 string (including header) of the concatenation +;;of strings @1, @dots{}. +(define (vrml . nodes) + (apply vrml-append (sprintf #f "#VRML V2.0 utf8\\n") nodes)) + +;;@body Returns the concatenation with interdigitated newlines of +;;strings @1, @2, @dots{}. +(define (vrml-append node1 . node2) + (define nl (string #\newline)) + (apply string-append + node1 + (apply append (map (lambda (node) (list nl node)) node2)))) + +;;@body Writes to file named @1 the VRML97 string (including header) of +;;the concatenation of strings @2, @dots{}. +(define (vrml-to-file file . nodes) + (call-with-output-file file + (lambda (oprt) + (for-each (lambda (str) (display str oprt) (newline oprt)) + (cons (sprintf #f "#VRML V2.0 utf8") nodes))))) + +;;@body Returns a VRML97 string setting the title of the file in which +;;it appears to @1. Additional strings @2, @dots{} are comments. +(define (world:info title . info) + (string-append + (apply string-append + (sprintf #f "WorldInfo {title %#a info [" title) + (map (lambda (str) (sprintf #f " %#a\\n" str)) info)) + (sprintf #f " ]\\n}\\n"))) + +;;@noindent +;; +;;VRML97 strings passed to @code{vrml} and @code{vrml-to-file} as +;;arguments will appear in the resulting VRML code. This string turns +;;off the headlight at the viewpoint: +;;@example +;;" NavigationInfo @{headlight FALSE@}" +;;@end example + +;;@body Specifies the distant images on the inside faces of the cube +;;enclosing the virtual world. +(define (scene:panorama front right back left top bottom) + (sprintf #f "Background {%s%s%s%s%s%s}" + (if front (sprintf #f "\\n frontUrl %#a" front) "") + (if right (sprintf #f "\\n rightUrl %#a" right) "") + (if back (sprintf #f "\\n backUrl %#a" back) "") + (if left (sprintf #f "\\n leftUrl %#a" left) "") + (if top (sprintf #f "\\n topUrl %#a" top) "") + (if bottom (sprintf #f "\\n bottomUrl %#a" bottom) ""))) + +;; 2-dimensional coordinates. +(define (coordinates2string obj) + (if (vector? obj) (set! obj (vector->list obj))) + (case (length obj) + ((2) (apply sprintf #f "%g %g" obj)) + (else (slib:error 'coordinates2string obj)))) + +;; This one will duplicate number argument. +(define (coordinate2string obj) + (coordinates2string (if (number? obj) (list obj obj) obj))) + +;; 3-dimensional coordinates. +(define (coordinates3string obj) + (if (vector? obj) (set! obj (vector->list obj))) + (case (length obj) + ((3) (apply sprintf #f "%g %g %g" obj)) + (else (slib:error 'coordinates3string obj)))) + +;; This one will triplicate number argument. +(define (coordinate3string obj) + (coordinates3string (if (number? obj) (list obj obj obj) obj))) + +(define (solid-color->sRGB obj) + (cond ((not obj) #f) + ((color? obj) (map (lambda (x) (/ x 255.0)) (color->sRGB obj))) + ((list? obj) obj) + ((vector? obj) obj) + ((integer? obj) + (list (/ (quotient obj 65536) 255) + (/ (modulo (quotient obj 256) 256) 255) + (/ (modulo obj 256) 255))) + (else (slib:error 'solid:color? obj)))) + +(define (color->vrml-field obj) + (and obj (coordinates3string (solid-color->sRGB obj)))) + +(define (colors->vrml-field objs) + (if (null? objs) + "[]" + (sprintf #f "[ %s%s ]" + (color->vrml-field (car objs)) + (apply string-append + (map (lambda (obj) + (sprintf #f ",\\n %s" (color->vrml-field obj))) + (cdr objs)))))) + +(define (angles->vrml-field objs) + (if (null? objs) + "[]" + (sprintf #f "[ %g%s ]" + (* pi/180 (car objs)) + (apply string-append + (map (lambda (obj) (sprintf #f ", %g" (* pi/180 obj))) + (cdr objs)))))) + +(define (direction->vrml-field obj) + (if (vector? obj) (set! obj (vector->list obj))) + (coordinates3string + (case (length obj) + ((2) (let ((th (* (car obj) pi/180)) + (ph (* (cadr obj) pi/180))) + (list (* (sin ph) (sin th)) + (- (cos th)) + (* -1 (cos ph) (sin th))))) + ((3) obj) + (else (slib:error 'not 'direction obj))))) + +;;@body +;; +;;@1 is a list of color objects. Each may be of type @ref{Color +;;Data-Type, color}, a 24-bit sRGB integer, or a list of 3 numbers +;;between 0.0 and 1.0. +;; +;;@2 is a list of non-increasing angles the same length as +;;@1. Each angle is between 90 and -90 degrees. If 90 or -90 are not +;;elements of @2, then the color at the zenith and nadir are taken from +;;the colors paired with the angles nearest them. +;; +;;@0 fills horizontal bands with interpolated colors on the backgroud +;;sphere encasing the world. +(define (scene:sphere colors angles) + (define seen0? 0) + (if (vector? colors) (set! colors (vector->list colors))) + (if (vector? angles) (set! angles (vector->list angles))) + (if (not (eqv? (length colors) (length angles))) + (slib:error 'scene:sphere 'length (length colors) (length angles))) + ;;(@print angles) + (cond ((< (car angles) 90) + (set! colors (cons (car colors) colors)) + (set! angles (cons 90 angles)))) + (set! colors (reverse colors)) + (set! angles (reverse angles)) + (cond ((> (car angles) -90) + (set! colors (cons (car colors) colors)) + (set! angles (cons -90 angles)))) + (let loop ((colors colors) (angles angles) + (ground-colors '()) (ground-angles '())) + ;;(print 'loop 'angles angles 'ground-angles ground-angles) + (cond + ((null? angles) ; No ground colors + (sprintf + #f "Background {%s%s}" + (sprintf #f "\\n skyColor %s" (colors->vrml-field colors)) + (sprintf #f "\\n skyAngle %s" (angles->vrml-field (cdr angles))))) + ((and (zero? seen0?) (zero? (car angles))) + (set! seen0? (+ 1 seen0?)) + (loop (cdr colors) (cdr angles) + (cons (car colors) ground-colors) + (cons 0 ground-angles))) + ((>= (car angles) 0) + (or (> seen0? 1) + (null? colors) + (null? ground-colors) + (zero? (car angles)) + (let* ((sw (- (car ground-angles))) + (gw (car angles)) + (avgclr + (map (lambda (sx gx) + (/ (+ (* sw sx) (* gw gx)) (+ sw gw))) + (solid-color->sRGB (car colors)) + (solid-color->sRGB (car ground-colors))))) + (set! colors (cons avgclr colors)) + (set! angles (cons 0 angles)) + (set! ground-colors (cons avgclr ground-colors)) + (set! ground-angles (cons 0 ground-angles)))) + (set! colors (reverse colors)) + (set! angles (reverse angles)) + (set! ground-colors (reverse ground-colors)) + (set! ground-angles (reverse ground-angles)) + (set! angles (map (lambda (angle) (- 90 angle)) angles)) + (set! ground-angles (map (lambda (angle) (+ 90 angle)) ground-angles)) + ;;(print 'final 'angles angles 'ground-angles ground-angles) + (sprintf + #f "Background {%s%s%s%s}" + (sprintf #f "\\n skyColor %s" (colors->vrml-field colors)) + (sprintf #f "\\n skyAngle %s" (angles->vrml-field (cdr angles))) + (sprintf #f "\\n groundColor %s" (colors->vrml-field ground-colors)) + (sprintf #f "\\n groundAngle %s" (angles->vrml-field (cdr ground-angles))))) + (else (loop (cdr colors) (cdr angles) + (cons (car colors) ground-colors) + (cons (car angles) ground-angles)))))) + +;;@body Returns a blue and brown backgroud sphere encasing the world. +(define (scene:sky-and-dirt) + (scene:sphere + '((0.0 0.2 0.7) + (0.0 0.5 1.0) + (0.9 0.9 0.9) + (0.6 0.6 0.6) + (0.4 0.25 0.2) + (0.2 0.1 0.0) + (0.3 0.2 0.0)) + '(90 15 0 0 -15 -70 -90))) + +;;@body Returns a blue and green backgroud sphere encasing the world. +(define (scene:sky-and-grass) + (scene:sphere + '((0.0 0.2 0.7) + (0.0 0.5 1.0) + (0.9 0.9 0.9) + (0.6 0.6 0.6) + (0.1 0.4 0.1) + (0.2 0.4 0.25) + (0.2 0.1 0.0) + (0.3 0.2 0.0)) + '(90 15 0 0 -10 -31 -70 -90))) + +(define (replicate-for-strength strength proc) + (apply string-append + (vector->list (make-vector + (inexact->exact (ceiling strength)) + (proc (/ strength (ceiling strength))))))) + +;;@args latitude julian-day hour turbidity strength +;;@args latitude julian-day hour turbidity +;; +;;@1 is the virtual place's latitude in degrees. @2 is an integer from +;;0 to 366, the day of the year. @3 is a real number from 0 to 24 for +;;the time of day; 12 is noon. @4 is the degree of fogginess described +;;in @xref{Daylight, turbidity}. +;; +;;@0 returns a bright yellow, distant sphere where the sun would be at +;;@3 on @2 at @1. If @5 is positive, included is a light source of @5 +;;(default 1). +(define (scene:sun latitude julian-day hour turbidity . strength) + (require 'daylight) + (let* ((theta_s (solar-polar (solar-declination julian-day) + latitude + (solar-hour julian-day hour))) + (phi_s (cadr theta_s)) + (sun-xyz (sunlight-CIEXYZ turbidity (car theta_s))) + (sun-color (and sun-xyz (CIEXYZ->color sun-xyz)))) + (set! theta_s (car theta_s)) + (set! strength (if (null? strength) 1 (car strength))) + (if (not strength) (set! strength 0)) + (vrml-append + (if (positive? strength) + (light:directional sun-color (list theta_s phi_s) strength) + "") + (if (positive? strength) + (light:ambient sun-color strength) + "") + (solid:rotation + '(0 -1 0) phi_s + (solid:rotation + '(1 0 0) theta_s + (solid:translation + '(0 150.e1 0) + (solid:sphere .695e1 (solid:color #f #f #f #f sun-color)))))))) + +;;@args latitude julian-day hour turbidity strength +;;@args latitude julian-day hour turbidity +;; +;;@1 is the virtual place's latitude in degrees. @2 is an integer from +;;0 to 366, the day of the year. @3 is a real number from 0 to 24 for +;;the time of day; 12 is noon. @4 is the degree of cloudiness described +;;in @xref{Daylight, turbidity}. +;; +;;@0 returns an overcast sky as it might look at @3 on @2 at @1. If @5 +;;is positive, included is an ambient light source of @5 (default 1). +(define (scene:overcast latitude julian-day hour turbidity . strength) + (require 'daylight) + (let* ((theta_s (solar-polar (solar-declination julian-day) + latitude + (solar-hour julian-day hour))) + (phi_s (cadr theta_s)) + (sun-xyz (sunlight-CIEXYZ turbidity (car theta_s))) + (sun-color (and sun-xyz (CIEXYZ->color sun-xyz))) + (color-func (overcast-sky-color-xyY turbidity (car theta_s)))) + (set! theta_s (car theta_s)) + (set! strength (if (null? strength) 1 (car strength))) + (if (not strength) (set! strength 0)) + (vrml-append + (if (positive? strength) + (light:ambient sun-color strength) + "") + (do ((elev 90 (/ elev 2)) + (angles '() (cons elev angles)) + (xyYs '() (cons (color-func (- 90 elev)) xyYs))) + ((< elev 2) + (scene:sphere + (map (lambda (xyY) (CIEXYZ->color (xyY->XYZ xyY))) + (reverse (xyY:normalize-colors (cons '(0 0 0) xyYs)))) + (reverse (cons -90 angles)))))))) + +;;@noindent +;;Viewpoints are objects in the virtual world, and can be transformed +;;individually or with solid objects. + +;;@args name distance compass pitch +;;@args name distance compass +;;Returns a viewpoint named @1 facing the origin and placed @2 from it. +;;@3 is a number from 0 to 360 giving the compass heading. @4 is a +;;number from -90 to 90, defaulting to 0, specifying the angle from the +;;horizontal. +(define (scene:viewpoint name distance compass . pitch) + (set! pitch (* pi/180 (if (null? pitch) 0 (car pitch)))) + (set! compass (* pi/180 compass)) + (let ((vp + (sprintf #f "Viewpoint {description \"%s\" %s %s}" + name + (sprintf #f "position 0 0 %g" distance) + (sprintf #f "orientation 1 0 0 %g" pitch)))) + (sprintf #f "Transform {rotation 0 -1 0 %g children [%s]}\\n" compass vp))) + +;;@body Returns 6 viewpoints, one at the center of each face of a cube +;;with sides 2 * @1, centered on the origin. +(define (scene:viewpoints proximity) + (string-append + (scene:viewpoint "North" proximity 0) + (scene:viewpoint "Up" proximity 0 90) + (scene:viewpoint "East" proximity 90) + (scene:viewpoint "South" proximity 180) + (scene:viewpoint "Down" proximity 0 -90) + (scene:viewpoint "West" proximity 270))) + +;;@subheading Light Sources + +;;@noindent +;;In VRML97, lights shine only on objects within the same children node +;;and descendants of that node. Although it would have been convenient +;;to let light direction be rotated by @code{solid:rotation}, this +;;restricts a rotated light's visibility to objects rotated with it. + +;;@noindent +;;To workaround this limitation, these directional light source +;;procedures accept either Cartesian or spherical coordinates for +;;direction. A spherical coordinate is a list @code{(@var{theta} +;;@var{azimuth})}; where @var{theta} is the angle in degrees from the +;;zenith, and @var{azimuth} is the angle in degrees due west of south. + +;;@noindent +;;It is sometimes useful for light sources to be brighter than @samp{1}. +;;When @var{intensity} arguments are greater than 1, these functions +;;gang multiple sources to reach the desired strength. + +;;@args color intensity +;;@args color +;;Ambient light shines on all surfaces with which it is grouped. +;; +;;@1 is a an object of type @ref{Color Data-Type, color}, a 24-bit sRGB +;;integer, or a list of 3 numbers between 0.0 and 1.0. If @1 is #f, +;;then the default color will be used. @2 is a real non-negative number +;;defaulting to @samp{1}. +;; +;;@0 returns a light source or sources of @1 with total strength of @2 +;;(or 1 if omitted). +(define (light:ambient color . intensity) + (replicate-for-strength + (if (null? intensity) 1 (car intensity)) + (lambda (inten) + (sprintf #f ;;direction included for "lookat" bug. + "DirectionalLight {color %s ambientIntensity %g intensity 0 direction 0 1 0}\\n" + (or (color->vrml-field color) "1 1 1") + inten)))) + +;;@args color direction intensity +;;@args color direction +;;@args color +;;Directional light shines parallel rays with uniform intensity on all +;;objects with which it is grouped. +;; +;;@1 is a an object of type @ref{Color Data-Type, color}, a 24-bit sRGB +;;integer, or a list of 3 numbers between 0.0 and 1.0. If @1 is #f, +;;then the default color will be used. +;; +;;@2 must be a list or vector of 2 or 3 numbers specifying the direction +;;to this light. If @2 has 2 numbers, then these numbers are the angle +;;from zenith and the azimuth in degrees; if @2 has 3 numbers, then +;;these are taken as a Cartesian vector specifying the direction to the +;;light source. The default direction is upwards; thus its light will +;;shine down. +;; +;;@3 is a real non-negative number defaulting to @samp{1}. +;; +;;@0 returns a light source or sources of @1 with total strength of @3, +;;shining from @2. +(define (light:directional color . args) + (define nargs (length args)) + (let ((direction (and (>= nargs 1) (car args))) + (intensity (and (>= nargs 2) (cadr args)))) + (replicate-for-strength + (or intensity 1) + (lambda (inten) + (sprintf #f + "DirectionalLight {color %s direction %s intensity %g}\\n" + (or (color->vrml-field color) "1 1 1") + (direction->vrml-field direction) + inten))))) + +;;@args attenuation radius aperture peak +;;@args attenuation radius aperture +;;@args attenuation radius +;;@args attenuation +;; +;;@1 is a list or vector of three nonnegative real numbers specifying +;;the reduction of intensity, the reduction of intensity with distance, +;;and the reduction of intensity as the square of distance. @2 is the +;;distance beyond which the light does not shine. @2 defaults to +;;@samp{100}. +;; +;;@3 is a real number between 0 and 180, the angle centered on the +;;light's axis through which it sheds some light. @4 is a real number +;;between 0 and 90, the angle of greatest illumination. +(define (light:beam attenuation . args) + (define nargs (length args)) + (list (and (>= nargs 3) (caddr args)) + (and (>= nargs 2) (cadr args)) + (coordinates3string attenuation) + (and (>= nargs 1) (car args)))) + +;;@args location color intensity beam +;;@args location color intensity +;;@args location color +;;@args location +;; +;;Point light radiates from @1, intensity decreasing with distance, +;;towards all objects with which it is grouped. +;; +;;@2 is a an object of type @ref{Color Data-Type, color}, a 24-bit sRGB +;;integer, or a list of 3 numbers between 0.0 and 1.0. If @2 is #f, +;;then the default color will be used. @3 is a real non-negative number +;;defaulting to @samp{1}. @4 is a structure returned by +;;@code{light:beam} or #f. +;; +;;@0 returns a light source or sources at @1 of @2 with total strength +;;@3 and @4 properties. Note that the pointlight itself is not visible. +;;To make it so, place an object with emissive appearance at @1. +(define (light:point location . args) + (define nargs (length args)) + (let ((color (and (>= nargs 1) (color->vrml-field (car args)))) + (intensity (and (>= nargs 2) (cadr args))) + (attenuation (and (>= nargs 3) (cadr (caddr args)))) + (radius (and (>= nargs 3) (caddr (caddr args))))) + (replicate-for-strength + (or intensity 1) + (lambda (inten) + (sprintf #f + "PointLight {location %s color %s intensity %g attenuation %s radius %g}\\n" + (coordinates3string location) + color intensity attenuation radius))))) + +;;@args location direction color intensity beam +;;@args location direction color intensity +;;@args location direction color +;;@args location direction +;;@args location +;; +;;Spot light radiates from @1 towards @2, intensity decreasing with +;;distance, illuminating objects with which it is grouped. +;; +;;@2 must be a list or vector of 2 or 3 numbers specifying the direction +;;to this light. If @2 has 2 numbers, then these numbers are the angle +;;from zenith and the azimuth in degrees; if @2 has 3 numbers, then +;;these are taken as a Cartesian vector specifying the direction to the +;;light source. The default direction is upwards; thus its light will +;;shine down. +;; +;;@3 is a an object of type @ref{Color Data-Type, color}, a 24-bit sRGB +;;integer, or a list of 3 numbers between 0.0 and 1.0. If @3 is #f, +;;then the default color will be used. +;; +;;@4 is a real non-negative number defaulting to @samp{1}. +;; +;;@0 returns a light source or sources at @1 of @2 with total strength +;;@3. Note that the spotlight itself is not visible. To make it so, +;;place an object with emissive appearance at @1. +(define (light:spot location . args) + (define nargs (length args)) + (let ((direction (and (>= nargs 1) (coordinates3string (car args)))) + (color (and (>= nargs 2) (color->vrml-field (cadr args)))) + (intensity (and (>= nargs 3) (caddr args))) + (beamwidth (and (>= nargs 4) (car (cadddr args)))) + (cutoffangle (and (>= nargs 4) (cadr (cadddr args)))) + (attenuation (and (>= nargs 4) (caddr (cadddr args)))) + (radius (and (>= nargs 4) (cadddr (cadddr args))))) + (replicate-for-strength + (or intensity 1) + (lambda (inten) + (sprintf #f + "SpotLight {\\n + location %s direction %s beamWidth %g cutOffAngle %g\\n + color %s intensity %s attenuation %s radius %g}\\n" + (coordinates3string location) + direction + color + intensity + (and beamwidth (* pi/180 beamwidth)) + (and cutoffangle (* pi/180 cutoffangle)) + attenuation + radius))))) + +;;@subheading Object Primitives + +(define (solid:node . nodes) + (sprintf #f "%s { %s }" (car nodes) (apply string-append (cdr nodes)))) + +;;@args geometry appearance +;;@args geometry +;;@1 must be a number or a list or vector of three numbers. If @1 is a +;;number, the @0 returns a cube with sides of length @1 centered on the +;;origin. Otherwise, @0 returns a rectangular box with dimensions @1 +;;centered on the origin. @2 determines the surface properties of the +;;returned object. +(define (solid:box geometry . appearance) + (define geom + (cond ((number? geometry) (list geometry geometry geometry)) + ((vector? geometry) (vector->list geometry)) + (else geometry))) + (solid:node "Shape" + (if (null? appearance) "" (string-append (car appearance) " ")) + "geometry " + (solid:node "Box" (sprintf #f "size %s" + (coordinate3string geom))))) + +;;@args radius height appearance +;;@args radius height +;;Returns a right cylinder with dimensions @1 and @code{(abs @2)} +;;centered on the origin. If @2 is positive, then the cylinder ends +;;will be capped. @3 determines the surface properties of the returned +;;object. +(define (solid:cylinder radius height . appearance) + (solid:node "Shape" + (if (null? appearance) "" (string-append (car appearance) " ")) + "geometry " + (solid:node "Cylinder" + (sprintf #f "height %g radius %g%s" + (abs height) radius + (if (negative? height) + " bottom FALSE top FALSE" + ""))))) + +;;@args radius thickness appearance +;;@args radius thickness +;;@2 must be a positive real number. @0 returns a circular disk +;;with dimensions @1 and @2 centered on the origin. @3 determines the +;;surface properties of the returned object. +(define (solid:disk radius thickness . appearance) + (solid:node "Shape" + (if (null? appearance) "" (string-append (car appearance) " ")) + "geometry " + (solid:node "Cylinder" (sprintf #f "height %g radius %g" + thickness radius)))) + +;;@args radius height appearance +;;@args radius height +;;Returns an isosceles cone with dimensions @1 and @2 centered on +;;the origin. @3 determines the surface properties of the returned +;;object. +(define (solid:cone radius height . appearance) + (solid:node "Shape" + (if (null? appearance) "" (string-append (car appearance) " ")) + "geometry " + (solid:node "Cone" (sprintf #f "height %g bottomRadius %g" + height radius)))) + +;;@args side height appearance +;;@args side height +;;Returns an isosceles pyramid with dimensions @1 and @2 centered on +;;the origin. @3 determines the surface properties of the returned +;;object. +(define (solid:pyramid side height . appearance) + (define si (/ side 2)) + (define hi (/ height 2)) + (solid:node "Shape" + (if (null? appearance) "" (string-append (car appearance) " ")) + "geometry " + (solid:node "Extrusion" + (sprintf + #f "spine [0 -%g 0, 0 %g 0] scale [%g %g, 0 0]" + hi hi si si)))) + +;;@args radius appearance +;;@args radius +;;Returns a sphere of radius @1 centered on the origin. @2 determines +;;the surface properties of the returned object. +(define (solid:sphere radius . appearance) + (solid:node "Shape" + (if (null? appearance) "" (string-append (car appearance) " ")) + "geometry " + (solid:node "Sphere" (sprintf #f "radius %g" radius)))) + +;;@args geometry appearance +;;@args geometry +;;@1 must be a number or a list or vector of three numbers. If @1 is a +;;number, the @0 returns a sphere of diameter @1 centered on the origin. +;;Otherwise, @0 returns an ellipsoid with diameters @1 centered on the +;;origin. @2 determines the surface properties of the returned object. +(define (solid:ellipsoid geometry . appearance) + (cond ((number? geometry) (apply solid:sphere (* 2 geometry) appearance)) + ((or (list? geometry) (vector? geometry)) + (solid:scale + geometry + (apply solid:sphere .5 appearance))) + (else (slib:error 'solid:ellipsoid '? (cons geometry appearance))))) + +;;@args width height depth colorray appearance +;;@args width height depth appearance +;;@args width height depth +;;One of @1, @2, or @3 must be a 2-dimensional array; the others must +;;be real numbers giving the length of the basrelief in those +;;dimensions. The rest of this description assumes that @2 is an +;;array of heights. +;; +;;@0 returns a @1 by @3 basrelief solid with heights per array @2 with +;;the buttom surface centered on the origin. +;; +;;If present, @5 determines the surface properties of the returned +;;object. If present, @4 must be an array of objects of type +;;@ref{Color Data-Type, color}, 24-bit sRGB integers or lists of 3 +;;numbers between 0.0 and 1.0. +;; +;;If @4's dimensions match @2, then each element of @4 paints its +;;corresponding vertex of @2. If @4 has all dimensions one smaller +;;than @2, then each element of @4 paints the corresponding face of +;;@2. Other dimensions for @4 are in error. +(define (solid:basrelief width height depth . args) + (cond ((array? height) (solid:bry width height depth args)) + ((array? width) + (solid:rotation + '(0 0 -1) 90 (solid:bry height width depth args))) + ((array? depth) + (solid:rotation + '(-1 0 0) 90 (solid:bry width depth height args))))) + +(define (solid:bry width heights depth args) + (define shape (array-shape heights)) + (if (not (eqv? 2 (length shape))) + (slib:error 'solid:basrelief 'rank? shape)) + (let ((xdim (- (cadadr shape) (caadr shape) -1)) + (zdim (- (cadar shape) (caar shape) -1))) + (define elevs (solid:extract-elevations heights shape)) + (solid:translation + (list (* -1/2 width) 0 (* -1/2 depth)) + (solid:node + "Shape" + (case (length args) + ((2) (cadr args)) + ((1) (car args)) + ((0) "") + (else (slib:error 'solid:basrelief 'too-many-args))) + " geometry " + (solid:node + " ElevationGrid" + " solid FALSE" + (sprintf #f " xDimension %g xSpacing %g zDimension %g zSpacing %g\\n" + xdim (/ width xdim) zdim (/ depth zdim)) + (sprintf #f " height [%s]\\n" elevs) + (if (and (not (null? args)) (<= 2 (array-rank (car args)))) + (case (length args) + ((2) (solid:extract-colors heights (car args))) + ((1 0) "")) + "")))))) + +(define (solid:extract-elevations heights shape) + (define zdim (- (cadar shape) (caar shape) -1)) + (define cnt 0) + (define hts '()) + (define lns '()) + (array-for-each + (lambda (ht) + (set! hts (cons (sprintf #f " %g" ht) hts)) + (set! cnt (+ 1 cnt)) + (cond ((>= cnt zdim) + (set! cnt 0) + (set! lns (cons (sprintf #f " %s\\n" + (apply string-append (reverse hts))) + lns)) + (set! hts '())))) + heights) + (if (not (null? hts)) (slib:error 'solid:extract-elevations 'leftover hts)) + (apply string-append (reverse lns))) + +(define (solid:extract-colors heights colora) + (define hshape (array-shape heights)) + (define cshape (array-shape colora)) + (cond ((equal? hshape cshape)) + ((and (eqv? 2 (length cshape)) + (equal? '(0 1 0 1) (map - + (apply append hshape) + (apply append cshape))))) + (else (slib:error 'solid:basrelief 'mismatch 'shape hshape cshape))) + (let ((ldim (- (cadadr cshape) (caadr cshape) -1)) + (cnt 0) + (sts '()) + (lns '())) + (array-for-each + (lambda (clr) + (set! sts (cons (sprintf #f " %s," (color->vrml-field clr)) sts)) + (set! cnt (+ 1 cnt)) + (cond ((>= cnt ldim) + (set! cnt 0) + (set! lns (cons (sprintf #f "%s\\n " + (apply string-append (reverse sts))) + lns)) + (set! sts '())))) + colora) + (sprintf #f " colorPerVertex %s color Color {color [%s]}\\n" + (if (equal? hshape cshape) "TRUE" "FALSE") + (apply string-append (reverse lns))))) + +;;@subheading Surface Attributes + +;;@args diffuseColor ambientIntensity specularColor shininess emissiveColor transparency +;;@args diffuseColor ambientIntensity specularColor shininess emissiveColor +;;@args diffuseColor ambientIntensity specularColor shininess +;;@args diffuseColor ambientIntensity specularColor +;;@args diffuseColor ambientIntensity +;;@args diffuseColor +;; +;;Returns an @dfn{appearance}, the optical properties of the objects +;;with which it is associated. @2, @4, and @6 must be numbers between 0 +;;and 1. @1, @3, and @5 are objects of type @ref{Color Data-Type, color}, +;;24-bit sRGB integers or lists of 3 numbers between 0.0 and 1.0. +;;If a color argument is omitted or #f, then the default color will be used. +(define (solid:color dc . args) + (define nargs (length args)) + (set! dc (color->vrml-field dc)) + (let ((ai (and (>= nargs 1) (car args))) + (sc (and (>= nargs 2) (color->vrml-field (cadr args)))) + (si (and (>= nargs 3) (caddr args))) + (ec (and (>= nargs 4) (color->vrml-field (cadddr args)))) + (tp (and (>= nargs 5) (list-ref args 4)))) + (sprintf + #f "appearance Appearance {\\n material Material {\\n%s%s%s%s%s%s}}" + (if dc (sprintf #f " diffuseColor %s\\n" dc) "") + (if ai (sprintf #f " ambientIntensity %g\\n" ai) "") + (if sc (sprintf #f " specularColor %s\\n" sc) "") + (if si (sprintf #f " shininess %g\\n" si) "") + (if ec (sprintf #f " emissiveColor %s\\n" ec) "") + (if tp (sprintf #f " transparency %g\\n" tp) "")))) + +;;@args image color scale rotation center translation +;;@args image color scale rotation center +;;@args image color scale rotation +;;@args image color scale +;;@args image color +;;@args image +;; +;;Returns an @dfn{appearance}, the optical properties of the objects +;;with which it is associated. @1 is a string naming a JPEG or PNG +;;image resource. @2 is #f, a color, or the string returned by +;;@code{solid:color}. The rest of the optional arguments specify +;;2-dimensional transforms applying to the @1. +;; +;;@3 must be #f, a number, or list or vector of 2 numbers specifying the +;;scale to apply to @1. @4 must be #f or the number of degrees to +;;rotate @1. @5 must be #f or a list or vector of 2 numbers specifying +;;the center of @1 relative to the @1 dimensions. @6 must be #f or a +;;list or vector of 2 numbers specifying the translation to apply to @1. +(define (solid:texture image . args) + (define nargs (length args)) + (let ((color (and (>= nargs 1) (car args))) + (scale (and (>= nargs 2) (cadr args))) + (rotation (and (>= nargs 3) (caddr args))) + (center (and (>= nargs 4) (cadddr args))) + (translation (and (>= nargs 5) (list-ref args 5)))) + (cond ((not color)) + ((not (string? color)) + (set! color (solid:color color)))) + (cond ((not color)) + ((< (string-length color) 24)) + ((equal? "appearance Appearance {" (substring color 0 23)) + (set! color (substring color 23 (+ -1 (string-length color)))))) + (sprintf + #f "appearance Appearance {%s\\n texture ImageTexture { url %#a }%s}\\n" + (or color "") + image + (if (< nargs 2) + "" + (sprintf + #f + "\\n textureTransform TextureTransform {%s%s%s%s\\n }\\n" + (if (not scale) + "" + (sprintf #f "\\n scale %s" (coordinate2string scale))) + (if rotation (sprintf #f "\\n rotation %g" + (* pi/180 rotation)) + "") + (if center + (sprintf #f "\\n center %s" + (coordinates2string center)) + "") + (if translation + (sprintf #f "\\n translation %s" + (coordinates2string translation)) + "")))))) + +;;@subheading Aggregating Objects + +;;@body Returns a row of @1 @2 objects spaced evenly @3 apart. +(define (solid:center-row-of number solid spacing) + (define (scale-by lst scaler) (map (lambda (x) (* x scaler)) lst)) + (if (vector? spacing) (set! spacing (vector->list spacing))) + (do ((idx (quotient (+ 1 number) 2) (+ -1 idx)) + (center (if (odd? number) + '(0 0 0) + (scale-by spacing .5)) + (map + spacing center)) + (vrml (if (odd? number) + (sprintf #f "%s\\n" solid) + "") + (string-append (solid:translation (map - center) solid) + vrml + (solid:translation center solid)))) + ((not (positive? idx)) vrml))) + +;;@body Returns @2 rows, @5 apart, of @1 @3 objects @4 apart. +(define (solid:center-array-of number-a number-b solid spacing-a spacing-b) + (define (scale-by lst scaler) (map (lambda (x) (* x scaler)) lst)) + (define row (solid:center-row-of number-b solid spacing-b)) + (if (vector? spacing-a) (set! spacing-a (vector->list spacing-a))) + (do ((idx (quotient (+ 1 number-a) 2) (+ -1 idx)) + (center (if (odd? number-a) + '(0 0 0) + (scale-by spacing-a .5)) + (map + spacing-a center)) + (vrml (if (odd? number-b) + (sprintf #f "%s\\n" row) + "") + (string-append (solid:translation (map - center) row) + vrml + (solid:translation center row)))) + ((not (positive? idx)) vrml))) + +;;@body Returns @3 planes, @7 apart, of @2 rows, @6 apart, of @1 @4 objects @5 apart. +(define (solid:center-pile-of number-a number-b number-c solid spacing-a spacing-b spacing-c) + (define (scale-by lst scaler) (map (lambda (x) (* x scaler)) lst)) + (define plane (solid:center-array-of number-b number-c solid spacing-b spacing-c)) + (if (vector? spacing-a) (set! spacing-a (vector->list spacing-a))) + (do ((idx (quotient (+ 1 number-a) 2) (+ -1 idx)) + (center (if (odd? number-a) + '(0 0 0) + (scale-by spacing-a .5)) + (map + spacing-a center)) + (vrml (if (odd? number-b) + (sprintf #f "%s\\n" plane) + "") + (string-append (solid:translation (map - center) plane) + vrml + (solid:translation center plane)))) + ((not (positive? idx)) vrml))) + +;;@args center +;;@1 must be a list or vector of three numbers. Returns an upward +;;pointing metallic arrow centered at @1. +;; +;;@args +;;Returns an upward pointing metallic arrow centered at the origin. +(define (solid:arrow . location) + (solid:translation + (if (null? location) '#(0 0 0) (car location)) + (solid:translation + '#(0 .17 0) + (solid:cone .04 .06 (solid:color '#(1 0 0) .2 '#(1 1 1) .8))) + (solid:cylinder .006 .32 (solid:color #f #f '#(1 .5 .5) .8)) + (solid:sphere .014 (solid:color '#(0 0 1) #f '#(1 1 1) 1)))) + +;;@subheading Spatial Transformations + +;;@body @1 must be a list or vector of three numbers. @0 Returns an +;;aggregate of @2, @dots{} with their origin moved to @1. +(define (solid:translation center . solids) + (string-append + (sprintf #f "Transform {translation %s children [\\n" + (coordinates3string center)) + (apply string-append solids) + (sprintf #f " ]\\n}\\n"))) + +;;@body @1 must be a number or a list or vector of three numbers. @0 +;;Returns an aggregate of @2, @dots{} scaled per @1. +(define (solid:scale scale . solids) + (define scales + (cond ((number? scale) (list scale scale scale)) + (else scale))) + (string-append + (sprintf #f "Transform {scale %s children [\\n" (coordinate3string scales)) + (apply string-append solids) + (sprintf #f " ]\\n}\\n"))) + +;;@body @1 must be a list or vector of three numbers. @0 Returns an +;;aggregate of @3, @dots{} rotated @2 degrees around the axis @1. +(define (solid:rotation axis angle . solids) + (if (vector? axis) (set! axis (vector->list axis))) + (set! angle (* pi/180 angle)) + (string-append + (sprintf #f "Transform {rotation %s %g children [\\n" + (coordinates3string axis) angle solids) + (apply string-append solids) + (sprintf #f " ]\\n}\\n"))) diff --git a/solid.txi b/solid.txi new file mode 100644 index 0000000..102214f --- /dev/null +++ b/solid.txi @@ -0,0 +1,441 @@ +@ifset html +<A NAME="Solid"> +@end ifset +@code{(require 'solid)} +@ifset html +</A> +@end ifset +@ftindex solids +@ftindex solid +@ftindex solid-modeling + +@noindent +@uref{http://swissnet.ai.mit.edu/~jaffer/Solid/#Example} gives an +example use of this package. + + +@defun vrml node @dots{} +Returns the VRML97 string (including header) of the concatenation +of strings @var{nodes}, @dots{}. +@end defun + +@defun vrml-append node1 node2 @dots{} +Returns the concatenation with interdigitated newlines of +strings @var{node1}, @var{node2}, @dots{}. +@end defun + +@defun vrml-to-file file node @dots{} +Writes to file named @var{file} the VRML97 string (including header) of +the concatenation of strings @var{nodes}, @dots{}. +@end defun + +@defun world:info title info @dots{} +Returns a VRML97 string setting the title of the file in which +it appears to @var{title}. Additional strings @var{info}, @dots{} are comments. +@end defun +@noindent + +VRML97 strings passed to @code{vrml} and @code{vrml-to-file} as +arguments will appear in the resulting VRML code. This string turns +off the headlight at the viewpoint: +@example +" NavigationInfo @{headlight FALSE@}" +@end example + + +@defun scene:panorama front right back left top bottom +Specifies the distant images on the inside faces of the cube +enclosing the virtual world. +@end defun + +@defun scene:sphere colors angles + + +@var{colors} is a list of color objects. Each may be of type @ref{Color +Data-Type, color}, a 24-bit sRGB integer, or a list of 3 numbers +between 0.0 and 1.0. + +@var{angles} is a list of non-increasing angles the same length as +@var{colors}. Each angle is between 90 and -90 degrees. If 90 or -90 are not +elements of @var{angles}, then the color at the zenith and nadir are taken from +the colors paired with the angles nearest them. + +@code{scene:sphere} fills horizontal bands with interpolated colors on the backgroud +sphere encasing the world. +@end defun + +@defun scene:sky-and-dirt +Returns a blue and brown backgroud sphere encasing the world. +@end defun + +@defun scene:sky-and-grass +Returns a blue and green backgroud sphere encasing the world. +@end defun + +@defun scene:sun latitude julian-day hour turbidity strength + + +@defunx scene:sun latitude julian-day hour turbidity + +@var{latitude} is the virtual place's latitude in degrees. @var{julian-day} is an integer from +0 to 366, the day of the year. @var{hour} is a real number from 0 to 24 for +the time of day; 12 is noon. @var{turbidity} is the degree of fogginess described +in @xref{Daylight, turbidity}. + +@code{scene:sun} returns a bright yellow, distant sphere where the sun would be at +@var{hour} on @var{julian-day} at @var{latitude}. If @var{strength} is positive, included is a light source of @var{strength} +(default 1). +@end defun + +@defun scene:overcast latitude julian-day hour turbidity strength + + +@defunx scene:overcast latitude julian-day hour turbidity + +@var{latitude} is the virtual place's latitude in degrees. @var{julian-day} is an integer from +0 to 366, the day of the year. @var{hour} is a real number from 0 to 24 for +the time of day; 12 is noon. @var{turbidity} is the degree of cloudiness described +in @xref{Daylight, turbidity}. + +@code{scene:overcast} returns an overcast sky as it might look at @var{hour} on @var{julian-day} at @var{latitude}. If @var{strength} +is positive, included is an ambient light source of @var{strength} (default 1). +@end defun +@noindent +Viewpoints are objects in the virtual world, and can be transformed +individually or with solid objects. + + +@defun scene:viewpoint name distance compass pitch + + +@defunx scene:viewpoint name distance compass +Returns a viewpoint named @var{name} facing the origin and placed @var{distance} from it. +@var{compass} is a number from 0 to 360 giving the compass heading. @var{pitch} is a +number from -90 to 90, defaulting to 0, specifying the angle from the +horizontal. +@end defun + +@defun scene:viewpoints proximity +Returns 6 viewpoints, one at the center of each face of a cube +with sides 2 * @var{proximity}, centered on the origin. +@end defun +@subheading Light Sources + +@noindent +In VRML97, lights shine only on objects within the same children node +and descendants of that node. Although it would have been convenient +to let light direction be rotated by @code{solid:rotation}, this +restricts a rotated light's visibility to objects rotated with it. + +@noindent +To workaround this limitation, these directional light source +procedures accept either Cartesian or spherical coordinates for +direction. A spherical coordinate is a list @code{(@var{theta} +@var{azimuth})}; where @var{theta} is the angle in degrees from the +zenith, and @var{azimuth} is the angle in degrees due west of south. + +@noindent +It is sometimes useful for light sources to be brighter than @samp{1}. +When @var{intensity} arguments are greater than 1, these functions +gang multiple sources to reach the desired strength. + + +@defun light:ambient color intensity + + +@defunx light:ambient color +Ambient light shines on all surfaces with which it is grouped. + +@var{color} is a an object of type @ref{Color Data-Type, color}, a 24-bit sRGB +integer, or a list of 3 numbers between 0.0 and 1.0. If @var{color} is #f, +then the default color will be used. @var{intensity} is a real non-negative number +defaulting to @samp{1}. + +@code{light:ambient} returns a light source or sources of @var{color} with total strength of @var{intensity} +(or 1 if omitted). +@end defun + +@defun light:directional color direction intensity + + +@defunx light:directional color direction + +@defunx light:directional color +Directional light shines parallel rays with uniform intensity on all +objects with which it is grouped. + +@var{color} is a an object of type @ref{Color Data-Type, color}, a 24-bit sRGB +integer, or a list of 3 numbers between 0.0 and 1.0. If @var{color} is #f, +then the default color will be used. + +@var{direction} must be a list or vector of 2 or 3 numbers specifying the direction +to this light. If @var{direction} has 2 numbers, then these numbers are the angle +from zenith and the azimuth in degrees; if @var{direction} has 3 numbers, then +these are taken as a Cartesian vector specifying the direction to the +light source. The default direction is upwards; thus its light will +shine down. + +@var{intensity} is a real non-negative number defaulting to @samp{1}. + +@code{light:directional} returns a light source or sources of @var{color} with total strength of @var{intensity}, +shining from @var{direction}. +@end defun + +@defun light:beam attenuation radius aperture peak + + +@defunx light:beam attenuation radius aperture + +@defunx light:beam attenuation radius + +@defunx light:beam attenuation + +@var{attenuation} is a list or vector of three nonnegative real numbers specifying +the reduction of intensity, the reduction of intensity with distance, +and the reduction of intensity as the square of distance. @var{radius} is the +distance beyond which the light does not shine. @var{radius} defaults to +@samp{100}. + +@var{aperture} is a real number between 0 and 180, the angle centered on the +light's axis through which it sheds some light. @var{peak} is a real number +between 0 and 90, the angle of greatest illumination. +@end defun + +@defun light:point location color intensity beam + + +@defunx light:point location color intensity + +@defunx light:point location color + +@defunx light:point location + +Point light radiates from @var{location}, intensity decreasing with distance, +towards all objects with which it is grouped. + +@var{color} is a an object of type @ref{Color Data-Type, color}, a 24-bit sRGB +integer, or a list of 3 numbers between 0.0 and 1.0. If @var{color} is #f, +then the default color will be used. @var{intensity} is a real non-negative number +defaulting to @samp{1}. @var{beam} is a structure returned by +@code{light:beam} or #f. + +@code{light:point} returns a light source or sources at @var{location} of @var{color} with total strength +@var{intensity} and @var{beam} properties. Note that the pointlight itself is not visible. +To make it so, place an object with emissive appearance at @var{location}. +@end defun + +@defun light:spot location direction color intensity beam + + +@defunx light:spot location direction color intensity + +@defunx light:spot location direction color + +@defunx light:spot location direction + +@defunx light:spot location + +Spot light radiates from @var{location} towards @var{direction}, intensity decreasing with +distance, illuminating objects with which it is grouped. + +@var{direction} must be a list or vector of 2 or 3 numbers specifying the direction +to this light. If @var{direction} has 2 numbers, then these numbers are the angle +from zenith and the azimuth in degrees; if @var{direction} has 3 numbers, then +these are taken as a Cartesian vector specifying the direction to the +light source. The default direction is upwards; thus its light will +shine down. + +@var{color} is a an object of type @ref{Color Data-Type, color}, a 24-bit sRGB +integer, or a list of 3 numbers between 0.0 and 1.0. If @var{color} is #f, +then the default color will be used. + +@var{intensity} is a real non-negative number defaulting to @samp{1}. + +@code{light:spot} returns a light source or sources at @var{location} of @var{direction} with total strength +@var{color}. Note that the spotlight itself is not visible. To make it so, +place an object with emissive appearance at @var{location}. +@end defun +@subheading Object Primitives + + +@defun solid:box geometry appearance + + +@defunx solid:box geometry +@var{geometry} must be a number or a list or vector of three numbers. If @var{geometry} is a +number, the @code{solid:box} returns a cube with sides of length @var{geometry} centered on the +origin. Otherwise, @code{solid:box} returns a rectangular box with dimensions @var{geometry} +centered on the origin. @var{appearance} determines the surface properties of the +returned object. +@end defun + +@defun solid:cylinder radius height appearance + + +@defunx solid:cylinder radius height +Returns a right cylinder with dimensions @var{radius} and @code{(abs @var{height})} +centered on the origin. If @var{height} is positive, then the cylinder ends +will be capped. @var{appearance} determines the surface properties of the returned +object. +@end defun + +@defun solid:disk radius thickness appearance + + +@defunx solid:disk radius thickness +@var{thickness} must be a positive real number. @code{solid:disk} returns a circular disk +with dimensions @var{radius} and @var{thickness} centered on the origin. @var{appearance} determines the +surface properties of the returned object. +@end defun + +@defun solid:cone radius height appearance + + +@defunx solid:cone radius height +Returns an isosceles cone with dimensions @var{radius} and @var{height} centered on +the origin. @var{appearance} determines the surface properties of the returned +object. +@end defun + +@defun solid:pyramid side height appearance + + +@defunx solid:pyramid side height +Returns an isosceles pyramid with dimensions @var{side} and @var{height} centered on +the origin. @var{appearance} determines the surface properties of the returned +object. +@end defun + +@defun solid:sphere radius appearance + + +@defunx solid:sphere radius +Returns a sphere of radius @var{radius} centered on the origin. @var{appearance} determines +the surface properties of the returned object. +@end defun + +@defun solid:ellipsoid geometry appearance + + +@defunx solid:ellipsoid geometry +@var{geometry} must be a number or a list or vector of three numbers. If @var{geometry} is a +number, the @code{solid:ellipsoid} returns a sphere of diameter @var{geometry} centered on the origin. +Otherwise, @code{solid:ellipsoid} returns an ellipsoid with diameters @var{geometry} centered on the +origin. @var{appearance} determines the surface properties of the returned object. +@end defun + +@defun solid:basrelief width height depth colorray appearance + + +@defunx solid:basrelief width height depth appearance + +@defunx solid:basrelief width height depth +One of @var{width}, @var{height}, or @var{depth} must be a 2-dimensional array; the others must +be real numbers giving the length of the basrelief in those +dimensions. The rest of this description assumes that @var{height} is an +array of heights. + +@code{solid:basrelief} returns a @var{width} by @var{depth} basrelief solid with heights per array @var{height} with +the buttom surface centered on the origin. + +If present, @var{appearance} determines the surface properties of the returned +object. If present, @var{colorray} must be an array of objects of type +@ref{Color Data-Type, color}, 24-bit sRGB integers or lists of 3 +numbers between 0.0 and 1.0. + +If @var{colorray}'s dimensions match @var{height}, then each element of @var{colorray} paints its +corresponding vertex of @var{height}. If @var{colorray} has all dimensions one smaller +than @var{height}, then each element of @var{colorray} paints the corresponding face of +@var{height}. Other dimensions for @var{colorray} are in error. +@end defun +@subheading Surface Attributes + + +@defun solid:color diffuseColor ambientIntensity specularColor shininess emissiveColor transparency + + +@defunx solid:color diffuseColor ambientIntensity specularColor shininess emissiveColor + +@defunx solid:color diffuseColor ambientIntensity specularColor shininess + +@defunx solid:color diffuseColor ambientIntensity specularColor + +@defunx solid:color diffuseColor ambientIntensity + +@defunx solid:color diffuseColor + +Returns an @dfn{appearance}, the optical properties of the objects +@cindex appearance +with which it is associated. @var{ambientIntensity}, @var{shininess}, and @var{transparency} must be numbers between 0 +and 1. @var{diffuseColor}, @var{specularColor}, and @var{emissiveColor} are objects of type @ref{Color Data-Type, color}, +24-bit sRGB integers or lists of 3 numbers between 0.0 and 1.0. +If a color argument is omitted or #f, then the default color will be used. +@end defun + +@defun solid:texture image color scale rotation center translation + + +@defunx solid:texture image color scale rotation center + +@defunx solid:texture image color scale rotation + +@defunx solid:texture image color scale + +@defunx solid:texture image color + +@defunx solid:texture image + +Returns an @dfn{appearance}, the optical properties of the objects +@cindex appearance +with which it is associated. @var{image} is a string naming a JPEG or PNG +image resource. @var{color} is #f, a color, or the string returned by +@code{solid:color}. The rest of the optional arguments specify +2-dimensional transforms applying to the @var{image}. + +@var{scale} must be #f, a number, or list or vector of 2 numbers specifying the +scale to apply to @var{image}. @var{rotation} must be #f or the number of degrees to +rotate @var{image}. @var{center} must be #f or a list or vector of 2 numbers specifying +the center of @var{image} relative to the @var{image} dimensions. @var{translation} must be #f or a +list or vector of 2 numbers specifying the translation to apply to @var{image}. +@end defun +@subheading Aggregating Objects + + +@defun solid:center-row-of number solid spacing +Returns a row of @var{number} @var{solid} objects spaced evenly @var{spacing} apart. +@end defun + +@defun solid:center-array-of number-a number-b solid spacing-a spacing-b +Returns @var{number-b} rows, @var{spacing-b} apart, of @var{number-a} @var{solid} objects @var{spacing-a} apart. +@end defun + +@defun solid:center-pile-of number-a number-b number-c solid spacing-a spacing-b spacing-c +Returns @var{number-c} planes, @var{spacing-c} apart, of @var{number-b} rows, @var{spacing-b} apart, of @var{number-a} @var{solid} objects @var{spacing-a} apart. +@end defun + +@defun solid:arrow center + +@var{center} must be a list or vector of three numbers. Returns an upward +pointing metallic arrow centered at @var{center}. + + +@defunx solid:arrow +Returns an upward pointing metallic arrow centered at the origin. +@end defun +@subheading Spatial Transformations + + +@defun solid:translation center solid @dots{} +@var{center} must be a list or vector of three numbers. @code{solid:translation} Returns an +aggregate of @var{solids}, @dots{} with their origin moved to @var{center}. +@end defun + +@defun solid:scale scale solid @dots{} +@var{scale} must be a number or a list or vector of three numbers. @code{solid:scale} +Returns an aggregate of @var{solids}, @dots{} scaled per @var{scale}. +@end defun + +@defun solid:rotation axis angle solid @dots{} +@var{axis} must be a list or vector of three numbers. @code{solid:rotation} Returns an +aggregate of @var{solids}, @dots{} rotated @var{angle} degrees around the axis @var{axis}. +@end defun @@ -6,149 +6,154 @@ ;;; Updated: 11 June 1991 ;;; Modified for scheme library: Aubrey Jaffer 19 Sept. 1991 ;;; Updated: 19 June 1995 +;;; (sort, sort!, sorted?): Generalized to strings by jaffer: 2003-09-09 +;;; (sort, sort!, sorted?): Generalized to arrays by jaffer: 2003-10-04 + +(require 'array) ;;; (sorted? sequence less?) ;;; is true when sequence is a list (x0 x1 ... xm) or a vector #(x0 ... xm) ;;; such that for all 1 <= i <= m, ;;; (not (less? (list-ref list i) (list-ref list (- i 1)))). - -(define (sort:sorted? seq less?) - (cond - ((null? seq) - #t) - ((vector? seq) - (let ((n (vector-length seq))) - (if (<= n 1) - #t - (do ((i 1 (+ i 1))) - ((or (= i n) - (less? (vector-ref seq i) - (vector-ref seq (- i 1)))) - (= i n)) )) )) +;@ +(define (sorted? seq less?) + (cond ((null? seq) #t) + ((array? seq) + (let ((shape (array-shape seq))) + (or (<= (- (cadar shape) (caar shape)) 0) + (do ((i (+ 1 (caar shape)) (+ i 1))) + ((or (= i (cadar shape)) + (less? (array-ref seq i) + (array-ref seq (- i 1)))) + (= i (cadar shape))))))) (else - (let loop ((last (car seq)) (next (cdr seq))) - (or (null? next) - (and (not (less? (car next) last)) - (loop (car next) (cdr next)) )) )) )) - + (let loop ((last (car seq)) (next (cdr seq))) + (or (null? next) + (and (not (less? (car next) last)) + (loop (car next) (cdr next)))))))) ;;; (merge a b less?) ;;; takes two lists a and b such that (sorted? a less?) and (sorted? b less?) ;;; and returns a new list in which the elements of a and b have been stably ;;; interleaved so that (sorted? (merge a b less?) less?). -;;; Note: this does _not_ accept vectors. See below. - -(define (sort:merge a b less?) - (cond - ((null? a) b) +;;; Note: this does _not_ accept arrays. See below. +;@ +(define (merge a b less?) + (cond ((null? a) b) ((null? b) a) (else (let loop ((x (car a)) (a (cdr a)) (y (car b)) (b (cdr b))) - ;; The loop handles the merging of non-empty lists. It has - ;; been written this way to save testing and car/cdring. - (if (less? y x) - (if (null? b) - (cons y (cons x a)) - (cons y (loop x a (car b) (cdr b)) )) - ;; x <= y - (if (null? a) - (cons x (cons y b)) - (cons x (loop (car a) (cdr a) y b)) )) )) )) - + ;; The loop handles the merging of non-empty lists. It has + ;; been written this way to save testing and car/cdring. + (if (less? y x) + (if (null? b) + (cons y (cons x a)) + (cons y (loop x a (car b) (cdr b)))) + ;; x <= y + (if (null? a) + (cons x (cons y b)) + (cons x (loop (car a) (cdr a) y b)))))))) ;;; (merge! a b less?) ;;; takes two sorted lists a and b and smashes their cdr fields to form a ;;; single sorted list including the elements of both. -;;; Note: this does _not_ accept vectors. - -(define (sort:merge! a b less?) - (define (loop r a b) - (if (less? (car b) (car a)) - (begin - (set-cdr! r b) - (if (null? (cdr b)) - (set-cdr! b a) - (loop b a (cdr b)) )) - ;; (car a) <= (car b) - (begin - (set-cdr! r a) - (if (null? (cdr a)) - (set-cdr! a b) - (loop a (cdr a) b)) )) ) - (cond - ((null? a) b) +;;; Note: this does _not_ accept arrays. +;@ +(define (merge! a b less?) + (define (loop r a b) + (if (less? (car b) (car a)) + (begin + (set-cdr! r b) + (if (null? (cdr b)) + (set-cdr! b a) + (loop b a (cdr b)))) + ;; (car a) <= (car b) + (begin + (set-cdr! r a) + (if (null? (cdr a)) + (set-cdr! a b) + (loop a (cdr a) b))))) + (cond ((null? a) b) ((null? b) a) ((less? (car b) (car a)) - (if (null? (cdr b)) - (set-cdr! b a) - (loop b a (cdr b))) - b) - (else ; (car a) <= (car b) - (if (null? (cdr a)) - (set-cdr! a b) - (loop a (cdr a) b)) - a))) - - + (if (null? (cdr b)) + (set-cdr! b a) + (loop b a (cdr b))) + b) + (else ; (car a) <= (car b) + (if (null? (cdr a)) + (set-cdr! a b) + (loop a (cdr a) b)) + a))) ;;; (sort! sequence less?) -;;; sorts the list or vector sequence destructively. It uses a version -;;; of merge-sort invented, to the best of my knowledge, by David H. D. -;;; Warren, and first used in the DEC-10 Prolog system. R. A. O'Keefe -;;; adapted it to work destructively in Scheme. - -(define (sort:sort! seq less?) - (define (step n) - (cond - ((> n 2) - (let* ((j (quotient n 2)) - (a (step j)) - (k (- n j)) - (b (step k))) - (sort:merge! a b less?))) - ((= n 2) - (let ((x (car seq)) - (y (cadr seq)) - (p seq)) - (set! seq (cddr seq)) - (if (less? y x) (begin - (set-car! p y) - (set-car! (cdr p) x))) - (set-cdr! (cdr p) '()) - p)) - ((= n 1) - (let ((p seq)) - (set! seq (cdr seq)) - (set-cdr! p '()) - p)) - (else - '()) )) - (if (vector? seq) - (let ((n (vector-length seq)) - (vec seq)) - (set! seq (vector->list seq)) - (do ((p (step n) (cdr p)) - (i 0 (+ i 1))) - ((null? p) vec) - (vector-set! vec i (car p)) )) - ;; otherwise, assume it is a list - (step (length seq)) )) +;;; sorts the list, array, or string sequence destructively. It uses +;;; a version of merge-sort invented, to the best of my knowledge, by +;;; David H. D. Warren, and first used in the DEC-10 Prolog system. +;;; R. A. O'Keefe adapted it to work destructively in Scheme. +;@ +(define (sort! seq less?) + (define (step n) + (cond ((> n 2) + (let* ((j (quotient n 2)) + (a (step j)) + (k (- n j)) + (b (step k))) + (sort:merge! a b less?))) + ((= n 2) + (let ((x (car seq)) + (y (cadr seq)) + (p seq)) + (set! seq (cddr seq)) + (cond ((less? y x) + (set-car! p y) + (set-car! (cdr p) x))) + (set-cdr! (cdr p) '()) + p)) + ((= n 1) + (let ((p seq)) + (set! seq (cdr seq)) + (set-cdr! p '()) + p)) + (else + '()))) + (cond ((array? seq) + (let ((shape (array-shape seq)) + (vec seq)) + (set! seq (rank-1-array->list seq)) + (do ((p (step (+ 1 (cadar shape))) (cdr p)) + (i 0 (+ i 1))) + ((null? p) vec) + (array-set! vec (car p) i)))) + (else ;; otherwise, assume it is a list + (step (length seq))))) + +(define (rank-1-array->list array) + (define shape (array-shape array)) + (do ((idx (cadar shape) (+ -1 idx)) + (lst '() (cons (array-ref array idx) lst))) + ((< idx (caar shape)) lst))) ;;; (sort sequence less?) -;;; sorts a vector or list non-destructively. It does this by sorting a -;;; copy of the sequence. My understanding is that the Standard says -;;; that the result of append is always "newly allocated" except for -;;; sharing structure with "the last argument", so (append x '()) ought -;;; to be a standard way of copying a list x. - -(define (sort:sort seq less?) - (if (vector? seq) - (list->vector (sort:sort! (vector->list seq) less?)) - (sort:sort! (append seq '()) less?))) - -;;; eof - -(define sorted? sort:sorted?) -(define merge sort:merge) -(define merge! sort:merge!) -(define sort sort:sort) -(define sort! sort:sort!) +;;; sorts a array, string, or list non-destructively. It does this +;;; by sorting a copy of the sequence. My understanding is that the +;;; Standard says that the result of append is always "newly +;;; allocated" except for sharing structure with "the last argument", +;;; so (append x '()) ought to be a standard way of copying a list x. +;@ +(define (sort seq less?) + (cond ((vector? seq) + (list->vector (sort:sort! (vector->list seq) less?))) + ((string? seq) + (list->string (sort:sort! (string->list seq) less?))) + ((array? seq) + (let ((shape (array-shape seq))) + (define newra (apply create-array seq shape)) + (do ((sorted (sort:sort! (rank-1-array->list seq) less?) + (cdr sorted)) + (i 0 (+ i 1))) + ((null? sorted) newra) + (array-set! newra (car sorted) i)))) + (else (sort:sort! (append seq '()) less?)))) + +(define sort:merge! merge!) +(define sort:sort! sort!) diff --git a/soundex.scm b/soundex.scm index eb3a542..6d73341 100644 --- a/soundex.scm +++ b/soundex.scm @@ -8,16 +8,16 @@ ; Taken from Knuth, Vol. 3 "Sorting and searching", pp 391--2 (require 'common-list-functions) - +;@ (define SOUNDEX (let* ((letters-to-omit - (list #\A #\E #\H #\I #\O #\U #\W #\Y)) + (list #\A #\E #\H #\I #\O #\U #\W #\Y)) (codes (list (list #\B #\1) (list #\F #\1) (list #\P #\1) (list #\V #\1) - ; + ;; (list #\C #\2) (list #\G #\2) (list #\J #\2) @@ -26,19 +26,19 @@ (list #\S #\2) (list #\X #\2) (list #\Z #\2) - ; + ;; (list #\D #\3) (list #\T #\3) - ; + ;; (list #\L #\4) - ; + ;; (list #\M #\5) (list #\N #\5) - ; + ;; (list #\R #\6))) (xform (lambda (c) - (let ((code (assq c codes))) + (let ((code (assv c codes))) (if code (cadr code) c))))) @@ -50,10 +50,10 @@ (string->list name))))) (if (null? char-list) name - (let* (; Replace letters except first with codes: + (let* ( ;; Replace letters except first with codes: (n1 (cons (car char-list) (map xform char-list))) - ; If 2 or more letter with same code are adjacent - ; in the original name, omit all but the first: + ;; If 2 or more letter with same code are adjacent + ;; in the original name, omit all but the first: (n2 (let loop ((chars n1)) (cond ((null? (cdr chars)) chars) @@ -62,14 +62,14 @@ (cadr chars)) (loop (cdr chars)) (cons (car chars) (loop (cdr chars)))))))) - ; Omit vowels and similar letters, except first: + ;; Omit vowels and similar letters, except first: (n3 (cons (car char-list) (remove-if (lambda (c) - (memq c letters-to-omit)) + (memv c letters-to-omit)) (cdr n2))))) - ; - ; pad with 0's or drop rightmost digits until of form "annn": + ;; + ;; pad with 0's or drop rightmost digits until of form "annn": (let loop ((rev-chars (reverse n3))) (let ((len (length rev-chars))) (cond ((= 4 len) @@ -1,5 +1,6 @@ ;;; "srfi-1.scm" SRFI-1 list-processing library -*-scheme-*- -; Copyright 2001 Aubrey Jaffer +;; Copyright 2001 Aubrey Jaffer +;; Copyright 2003 Sven Hartrumpf ; ;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 +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. ; @@ -48,7 +49,10 @@ ((< i 0) ans))) ;;@args obj1 obj2 -(define cons* comlist:list*) +(define cons* list*) + +;;@args flist +(define list-copy copy-list) ;;@args count start step ;;@args count start @@ -112,9 +116,13 @@ ;;@args pair (define first car) +;;@args pair (define second cadr) +;;@args pair (define third caddr) +;;@args pair (define fourth cadddr) +;;@args pair (define (fifth obj) (car (cddddr obj))) (define (sixth obj) (cadr (cddddr obj))) (define (seventh obj) (caddr (cddddr obj))) @@ -126,17 +134,21 @@ (define (car+cdr pair) (values (car pair) (cdr pair))) ;;@body -(define (take lst k) (comlist:butnthcdr k lst)) +(define (drop lst k) (nthcdr k lst)) +(define (take lst k) (butnthcdr k lst)) +;;@args lst k (define take! take) -(define (drop lst k) (comlist:nthcdr k lst)) ;;@args lst k -(define take-right comlist:butlast) -(define drop-right comlist:last) +(define take-right last) +;;@args lst k +(define drop-right butlast) +;;@args lst k (define drop-right! drop-right) -;;@body +;;@args lst k (define (split-at lst k) (values (take lst k) (drop lst k))) +;;@args lst k (define split-at! split-at) ;;@args lst @@ -144,7 +156,7 @@ (define (last lst . k) (if (null? k) (car (last-pair lst)) - (apply comlist:last lst k))) + (apply take-right lst k))) ;;@subheading Miscellaneous @@ -159,7 +171,7 @@ ;;Reverse is provided by R4RS. ;;@args lst -(define reverse! comlist:nreverse) +(define reverse! nreverse) ;;@body (define (append-reverse rev-head tail) @@ -202,16 +214,159 @@ ;;@subheading Fold and Unfold + +;;; We stop when LIS1 runs out, not when any list runs out. +;;@args f list1 clist2 ... +(define (map! f lis1 . lists) + (if (pair? lists) + (let lp ((lis1 lis1) (lists lists)) + (if (not (null-list? lis1)) + (call-with-values ; expanded a receive call + (lambda () (%cars+cdrs/no-test lists)) + (lambda (heads tails) + (set-car! lis1 (apply f (car lis1) heads)) + (lp (cdr lis1) tails))))) + + ;; Fast path. + (pair-for-each (lambda (pair) (set-car! pair (f (car pair)))) lis1)) + lis1) + +;;@args f clist1 clist2 ... +(define (pair-for-each proc lis1 . lists) + (if (pair? lists) + (let lp ((lists (cons lis1 lists))) + (let ((tails (%cdrs lists))) + (if (pair? tails) + (begin (apply proc lists) + (lp tails))))) + ;; Fast path. + (let lp ((lis lis1)) + (if (not (null-list? lis)) + (let ((tail (cdr lis))) ; Grab the cdr now, + (proc lis) ; in case PROC SET-CDR!s LIS. + (lp tail)))))) + + ;;@subheading Filtering and Partitioning +;;@body +(define (filter pred lis) ; Sleazing with EQ? makes this one faster. + (let recur ((lis lis)) + (if (null-list? lis) lis ; Use NOT-PAIR? to handle dotted lists. + (let ((head (car lis)) + (tail (cdr lis))) + (if (pred head) + (let ((new-tail (recur tail))) ; Replicate the RECUR call so + (if (eq? tail new-tail) lis + (cons head new-tail))) + (recur tail)))))) ; this one can be a tail call. +;;@body +(define (filter! pred l) + (if (null? l) + l + (let ((l2 l) + (l3 (cdr l))) + (do ((end #f) + (result '())) + (end result) + (cond ((pred (car l2)) ; keep the first element of l2 + (cond ((null? result) + (set! result l2))) ; first pair of remaining elements + (cond ((pair? l3) + (set! l2 l3) + (set! l3 (cdr l2))) + (else + (set! end #t)))) + (else ; remove the first element of l2 + (cond ((pair? l3) + (set-car! l2 (car l3)) + (set! l3 (cdr l3)) + (set-cdr! l2 l3)) + (else + (cond ((pair? result) + (list-remove-last! result))) + (set! end #t))))))))) + +;;@args pred list +(define (partition pred lis) + (let recur ((lis lis)) + (if (null-list? lis) (values lis lis) ; Use NOT-PAIR? to handle dotted lists. + (let ((elt (car lis)) + (tail (cdr lis))) + (call-with-values ; expanded a receive call + (lambda () (recur tail)) + (lambda (in out) + (if (pred elt) + (values (if (pair? out) (cons elt in) lis) out) + (values in (if (pair? in) (cons elt out) lis))))))))) + ;;@subheading Searching ;;@args pred list -(define find comlist:find-if) +(define find find-if) ;;@args pred list -(define find-tail comlist:member-if) +(define find-tail member-if) +;;@body +(define remove + (let ((comlist:remove remove)) + (lambda (pred l) + (if (procedure? pred) + (filter (lambda (x) (not (pred x))) l) + (comlist:remove pred l))))) ; 'remove' has incompatible semantics in comlist of SLIB! +;;@body +(define (remove! pred l) (filter! (lambda (x) (not (pred x))) l)) + +;;@args pred clist1 clist2 ... +(define (any pred lis1 . lists) + (if (pair? lists) + ;; N-ary case + (call-with-values ; expanded a receive call + (lambda () (%cars+cdrs (cons lis1 lists))) + (lambda (heads tails) + (and (pair? heads) + (let lp ((heads heads) (tails tails)) + (call-with-values ; expanded a receive call + (lambda () (%cars+cdrs tails)) + (lambda (next-heads next-tails) + (if (pair? next-heads) + (or (apply pred heads) (lp next-heads next-tails)) + (apply pred heads)))))))) ; Last PRED app is tail call. + ;; Fast path + (and (not (null-list? lis1)) + (let lp ((head (car lis1)) (tail (cdr lis1))) + (if (null-list? tail) + (pred head) ; Last PRED app is tail call. + (or (pred head) (lp (car tail) (cdr tail)))))))) + +;;@args pred clist1 clist2 ... +(define (list-index pred lis1 . lists) + (if (pair? lists) + ;; N-ary case + (let lp ((lists (cons lis1 lists)) (n 0)) + (call-with-values ; expanded a receive call + (lambda () (%cars+cdrs lists)) + (lambda (heads tails) + (and (pair? heads) + (if (apply pred heads) n + (lp tails (+ n 1))))))) + ;; Fast path + (let lp ((lis lis1) (n 0)) + (and (not (null-list? lis)) + (if (pred (car lis)) n (lp (cdr lis) (+ n 1))))))) + +;;@args pred list +(define (span pred lis) + (let recur ((lis lis)) + (if (null-list? lis) (values '() '()) + (let ((x (car lis))) + (if (pred x) + (call-with-values ; eliminated a receive call + (lambda () (recur (cdr lis))) + (lambda (prefix suffix) + (values (cons x prefix) suffix))) + (values '() lis)))))) ;;@args obj list pred ;;@args obj list @@ -251,3 +406,54 @@ (find (lambda (pair) (pred obj (car pair))) alist)))))) ;;@subheading Set operations + + +;;;; helper functions from the reference implementation: + +;;; LISTS is a (not very long) non-empty list of lists. +;;; Return two lists: the cars & the cdrs of the lists. +;;; However, if any of the lists is empty, just abort and return [() ()]. + +(define (%cars+cdrs lists) + (call-with-current-continuation + (lambda (abort) + (let recur ((lists lists)) + (if (pair? lists) + (call-with-values ; expanded a receive call + (lambda () (car+cdr lists)) + (lambda (list other-lists) + (if (null-list? list) (abort '() '()) ; LIST is empty -- bail out + (call-with-values ; expanded a receive call + (lambda () (car+cdr list)) + (lambda (a d) + (call-with-values ; expanded a receive call + (lambda () (recur other-lists)) + (lambda (cars cdrs) + (values (cons a cars) (cons d cdrs))))))))) + (values '() '())))))) + +;;; Like %CARS+CDRS, but blow up if any list is empty. +(define (%cars+cdrs/no-test lists) + (let recur ((lists lists)) + (if (pair? lists) + (call-with-values ; expanded a receive call + (lambda () (car+cdr lists)) + (lambda (list other-lists) + (call-with-values ; expanded a receive call + (lambda () (car+cdr list)) + (lambda (a d) + (call-with-values ; expanded a receive call + (lambda () (recur other-lists)) + (lambda (cars cdrs) + (values (cons a cars) (cons d cdrs)))))))) + (values '() '())))) + +(define (%cdrs lists) + (call-with-current-continuation + (lambda (abort) + (let recur ((lists lists)) + (if (pair? lists) + (let ((lis (car lists))) + (if (null-list? lis) (abort '()) + (cons (cdr lis) (recur (cdr lists))))) + '()))))) diff --git a/srfi-1.txi b/srfi-1.txi new file mode 100644 index 0000000..4b2ed74 --- /dev/null +++ b/srfi-1.txi @@ -0,0 +1,254 @@ +@code{(require 'srfi-1)} +@ftindex srfi-1 + +@noindent +Implements the @dfn{SRFI-1} @dfn{list-processing library} as described +@cindex SRFI-1 +@cindex list-processing library +at @url{http://srfi.schemers.org/srfi-1/srfi-1.html} + +@subheading Constructors + + +@defun xcons d a +@code{(define (xcons d a) (cons a d))}. +@end defun + +@defun list-tabulate len proc +Returns a list of length @var{len}. Element @var{i} is @code{(@var{proc} +@var{i})} for 0 <= @var{i} < @var{len}. +@end defun + +@defun cons* obj1 obj2 + +@end defun + +@defun list-copy flist + +@end defun + +@defun iota count start step + + +@defunx iota count start + +@defunx iota count +Returns a list of @var{count} numbers: (@var{start}, @var{start}+@var{step}, @dots{}, @var{start}+(@var{count}-1)*@var{step}). +@end defun + +@defun circular-list obj1 obj2 @dots{} + +Returns a circular list of @var{obj1}, @var{obj2}, @dots{}. +@end defun +@subheading Predicates + + +@defun proper-list? obj + +@end defun + +@defun circular-list? x + +@end defun + +@defun dotted-list? obj + +@end defun + +@defun null-list? obj + +@end defun + +@defun not-pair? obj + +@end defun + +@defun list= =pred list @dots{} + +@end defun +@subheading Selectors + + +@defun first pair + +@end defun + +@defun second pair + +@end defun + +@defun third pair + +@end defun + +@defun fourth pair + +@end defun + +@defun fifth pair +@defunx sixth obj +@defunx seventh obj +@defunx eighth obj +@defunx ninth obj +@defunx tenth obj + +@end defun + +@defun car+cdr pair + +@end defun + +@defun drop lst k +@defunx take lst k + +@end defun + +@deffn {Procedure} take! lst k + +@end deffn + +@defun take-right lst k + +@end defun + +@defun drop-right lst k + +@end defun + +@deffn {Procedure} drop-right! lst k + +@end deffn + +@defun split-at lst k + +@end defun + +@deffn {Procedure} split-at! lst k + +@end deffn + +@defun last lst + +(car (last-pair lst)) +@end defun +@subheading Miscellaneous + + +@defun length+ obj + +@end defun + +@defun concatenate lists +@defunx concatenate! lists + +@end defun + +@deffn {Procedure} reverse! lst + +@end deffn + +@defun append-reverse rev-head tail +@defunx append-reverse! rev-head tail + +@end defun + +@defun zip list1 list2 @dots{} + +@end defun + +@defun unzip1 lst +@defunx unzip2 lst +@defunx unzip3 lst +@defunx unzip4 lst +@defunx unzip5 lst + +@end defun + +@defun count pred list1 list2 @dots{} + +@end defun +@subheading Fold and Unfold + + +@deffn {Procedure} map! f list1 clist2 @dots{} + +@end deffn + +@defun pair-for-each f clist1 clist2 @dots{} + +@end defun +@subheading Filtering and Partitioning + + +@defun filter pred lis + +@end defun + +@deffn {Procedure} filter! pred l + +@end deffn + +@defun partition pred list + +@end defun +@subheading Searching + + +@defun find pred list + +@end defun + +@defun find-tail pred list + +@end defun + +@defun remove pred l + +@end defun + +@deffn {Procedure} remove! pred l + +@end deffn + +@defun any pred clist1 clist2 @dots{} + +@end defun + +@defun list-index pred clist1 clist2 @dots{} + +@end defun + +@defun span pred list + +@end defun + +@defun member obj list pred + + +@defunx member obj list + +@code{member} returns the first sublist of @var{list} whose car is @var{obj}, where the sublists +of @var{list} are the non-empty lists returned by @t{(list-tail @var{list} @var{k})} +for @var{k} less than the length of @var{list}. If @var{obj} does not occur in @var{list}, +then @t{#f} (not the empty list) is returned. The procedure @var{pred} is +used for testing equality. If @var{pred} is not provided, @samp{equal?} is +used. +@end defun +@subheading Deleting + +@subheading Association lists + + +@defun assoc obj alist pred + + +@defunx assoc obj alist + +@var{alist} (for ``association list'') must be a list of pairs. These +procedures find the first pair in @var{alist} whose car field is @var{obj}, and +returns that pair. If no pair in @var{alist} has @var{obj} as its car, then @t{#f} +(not the empty list) is returned. The procedure @var{pred} is used for +testing equality. If @var{pred} is not provided, @samp{equal?} is used. +@end defun +@subheading Set operations + diff --git a/srfi-2.scm b/srfi-2.scm new file mode 100644 index 0000000..adb2530 --- /dev/null +++ b/srfi-2.scm @@ -0,0 +1,41 @@ +;;"srfi-2.scm": Guarded LET* special form +;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. + +;;@code{(require 'srfi-2)} +;;@ftindex srfi-2 + +;;@body +;;@url{http://srfi.schemers.org/srfi-2/srfi-2.html} +(defmacro and-let* (claws . body) + (define (andin claw ans) + (if (and (pair? ans) (eq? 'and (car ans))) + `(and ,claw ,@(cdr ans)) + `(and ,claw ,ans))) + (do ((claws (reverse claws) (cdr claws)) + (ans (cond ((null? body) '(and)) + ((null? (cdr body)) (car body)) + (else (cons 'begin body))) + (let ((claw (car claws))) + (cond ((symbol? claw) + (andin claw ans)) + ((and (pair? claw) (null? (cdr claw))) + (andin (car claw) ans)) + (else + `(let (,claw) ,(andin (car claw) ans))))))) + ((null? claws) ans))) diff --git a/srfi-2.txi b/srfi-2.txi new file mode 100644 index 0000000..b5d1b68 --- /dev/null +++ b/srfi-2.txi @@ -0,0 +1,8 @@ +@code{(require 'srfi-2)} +@ftindex srfi-2 + + +@defmac and-let* claws body @dots{} + +@url{http://srfi.schemers.org/srfi-2/srfi-2.html} +@end defmac diff --git a/srfi-8.scm b/srfi-8.scm new file mode 100644 index 0000000..049451f --- /dev/null +++ b/srfi-8.scm @@ -0,0 +1,14 @@ +;;"srfi-8.scm": RECEIVE: Binding to multiple values + +(require 'values) + +;;@code{(require 'srfi-8)} +;;@ftindex srfi-8 + +;;@body +;;@url{http://srfi.schemers.org/srfi-8/srfi-8.html} +(define-syntax receive + (syntax-rules () + ((receive formals expression body ...) + (call-with-values (lambda () expression) + (lambda formals body ...))))) diff --git a/srfi-8.txi b/srfi-8.txi new file mode 100644 index 0000000..bdf149b --- /dev/null +++ b/srfi-8.txi @@ -0,0 +1,8 @@ +@code{(require 'srfi-8)} +@ftindex srfi-8 + + +@defspec receive formals expression body @dots{} + +@url{http://srfi.schemers.org/srfi-8/srfi-8.html} +@end defspec diff --git a/srfi-9.scm b/srfi-9.scm new file mode 100644 index 0000000..e55b193 --- /dev/null +++ b/srfi-9.scm @@ -0,0 +1,16 @@ +(require 'record) +(define-syntax define-record-field + (syntax-rules () + ((define-record-field type field-tag accessor) + (define accessor (record-accessor type 'field-tag))) + ((define-record-field type field-tag accessor modifier) + (begin (define accessor (record-accessor type 'field-tag)) + (define modifier (record-modifier type 'field-tag)))))) +;@ +(define-syntax define-record-type + (syntax-rules () + ((define-record-type type (constructor constructor-tag ...) predicate (field-tag accessor . more) ...) + (begin (define type (make-record-type 'type '(field-tag ...))) + (define constructor (record-constructor type '(constructor-tag ...))) + (define predicate (record-predicate type)) + (define-record-field type field-tag accessor . more) ...)))) @@ -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/srfi.txi b/srfi.txi new file mode 100644 index 0000000..52d2dbb --- /dev/null +++ b/srfi.txi @@ -0,0 +1,42 @@ +@code{(require 'srfi)} +@ftindex srfi + +@noindent Implements @dfn{Scheme Request For Implementation} (SRFI) as +@cindex Scheme Request For Implementation +described at @url{http://srfi.schemers.org/} + +@noindent The Copyright terms of each SRFI states: +@quotation +"However, this document itself may not be modified in any way, ..." +@end quotation + +@noindent Therefore, the specification of SRFI constructs must not be +quoted without including the complete SRFI document containing +discussion and a sample implementation program. + + +@defmac cond-expand <clause1> <clause2> @dots{} + + +@emph{Syntax:} +Each @r{<clause>} should be of the form + +@format +@t{(@r{<feature>} @r{<expression1>} @dots{})} +@end format + +where @r{<feature>} is a boolean expression composed of symbols and +`and', `or', and `not' of boolean expressions. The last @r{<clause>} +may be an ``else clause,'' which has the form + +@format +@t{(else @r{<expression1>} @r{<expression2>} @dots{})@r{.}} +@end format + +The first clause whose feature expression is satisfied is expanded. +If no feature expression is satisfied and there is no else clause, an +error is signaled. + +SLIB @code{cond-expand} is an extension of SRFI-0, +@url{http://srfi.schemers.org/srfi-0/srfi-0.html}. +@end defmac @@ -1,8 +1,5 @@ ;; "stdio.scm" compatability stub - -(require 'scanf) -(require 'printf) - +;@ (define stdin (current-input-port)) (define stdout (current-output-port)) (define stderr (current-error-port)) diff --git a/strcase.scm b/strcase.scm index 30b58ad..71daba4 100644 --- a/strcase.scm +++ b/strcase.scm @@ -4,30 +4,30 @@ ; This code is in the public domain. ; Modified by Aubrey Jaffer Nov 1992. -; SYMBOL-APPEND added by A. Jaffer 2001. +; SYMBOL-APPEND and StudlyCapsExpand added by A. Jaffer 2001. ; Authors of the original version were Ken Dickey and Aubrey Jaffer. ;string-upcase, string-downcase, string-capitalize ; are obvious string conversion procedures and are non destructive. ;string-upcase!, string-downcase!, string-capitalize! ; are destructive versions. - +;@ (define (string-upcase! str) (do ((i (- (string-length str) 1) (- i 1))) ((< i 0) str) (string-set! str i (char-upcase (string-ref str i))))) - +;@ (define (string-upcase str) (string-upcase! (string-copy str))) - +;@ (define (string-downcase! str) (do ((i (- (string-length str) 1) (- i 1))) ((< i 0) str) (string-set! str i (char-downcase (string-ref str i))))) - +;@ (define (string-downcase str) (string-downcase! (string-copy str))) - +;@ (define (string-capitalize! str) ; "hello" -> "Hello" (let ((non-first-alpha #f) ; "hELLO" -> "Hello" (str-len (string-length str))) ; "*hello" -> "*Hello" @@ -41,15 +41,15 @@ (set! non-first-alpha #t) (string-set! str i (char-upcase c)))) (set! non-first-alpha #f)))))) - +;@ (define (string-capitalize str) (string-capitalize! (string-copy str))) - +;@ (define string-ci->symbol (let ((s2cis (if (equal? "x" (symbol->string 'x)) string-downcase string-upcase))) (lambda (str) (string->symbol (s2cis str))))) - +;@ (define symbol-append (let ((s2cis (if (equal? "x" (symbol->string 'x)) string-downcase string-upcase))) @@ -64,3 +64,26 @@ ((not obj) "") (else (slib:error 'wrong-type-to 'symbol-append obj)))) args)))))) +;@ +(define (StudlyCapsExpand nstr . delimitr) + (set! delimitr + (cond ((null? delimitr) "-") + ((char? (car delimitr)) (string (car delimitr))) + (else (car delimitr)))) + (do ((idx (+ -1 (string-length nstr)) (+ -1 idx))) + ((> 1 idx) nstr) + (cond ((and (> idx 1) + (char-upper-case? (string-ref nstr (+ -1 idx))) + (char-lower-case? (string-ref nstr idx))) + (set! nstr + (string-append (substring nstr 0 (+ -1 idx)) + delimitr + (substring nstr (+ -1 idx) + (string-length nstr))))) + ((and (char-lower-case? (string-ref nstr (+ -1 idx))) + (char-upper-case? (string-ref nstr idx))) + (set! nstr + (string-append (substring nstr 0 idx) + delimitr + (substring nstr idx + (string-length nstr)))))))) diff --git a/strport.scm b/strport.scm index 197d9a0..9d33363 100644 --- a/strport.scm +++ b/strport.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. ; @@ -21,7 +21,7 @@ ;delete-file defined in your .init file. tmpnam generates ;temp file names. delete-file may be defined to be a dummy ;procedure that does nothing. - +;@ (define (call-with-output-string f) (let ((tmpf (tmpnam))) (call-with-output-file tmpf f) @@ -40,7 +40,7 @@ (loop (+ i 1)))))))) (delete-file tmpf) s))) - +;@ (define (call-with-input-string s f) (let ((tmpf (tmpnam))) (call-with-output-file tmpf diff --git a/strsrch.scm b/strsrch.scm index 71c69df..13edb65 100644 --- a/strsrch.scm +++ b/strsrch.scm @@ -1,67 +1,109 @@ ;;; "MISCIO" Search for string from port. -; Written 1995, 1996 by Oleg Kiselyov (oleg@ponder.csci.unt.edu) -; Modified 1996, 1997, 1998 by A. Jaffer (jaffer@ai.mit.edu) +; Written 1995, 1996 by Oleg Kiselyov (oleg@acm.org) +; Modified 1996, 1997, 1998, 2001 by A. Jaffer (agj@alum.mit.edu) +; Modified 2003 by Steve VanDevender (stevev@hexadecimal.uoregon.edu) ; ; This code is in the public domain. -;;; Return the index of the first occurence of a-char in str, or #f -(define (string-index str a-char) - (let loop ((pos 0)) - (cond - ;; whole string has been searched, in vain - ((>= pos (string-length str)) #f) - ((char=? a-char (string-ref str pos)) pos) - (else (loop (+ 1 pos)))))) - -(define (string-index-ci str a-char) - (let loop ((pos 0)) - (cond - ;; whole string has been searched, in vain - ((>= pos (string-length str)) #f) - ((char-ci=? a-char (string-ref str pos)) pos) - (else (loop (+ 1 pos)))))) - -(define (string-reverse-index str a-char) - (let loop ((pos (- (string-length str) 1))) - (cond ((< pos 0) #f) - ((char=? (string-ref str pos) a-char) pos) - (else (loop (- pos 1)))))) +;;;@ Return the index of the first occurence of chr in str, or #f +(define (string-index str chr) + (define len (string-length str)) + (do ((pos 0 (+ 1 pos))) + ((or (>= pos len) (char=? chr (string-ref str pos))) + (and (< pos len) pos)))) +;@ +(define (string-index-ci str chr) + (define len (string-length str)) + (do ((pos 0 (+ 1 pos))) + ((or (>= pos len) (char-ci=? chr (string-ref str pos))) + (and (< pos len) pos)))) +;@ +(define (string-reverse-index str chr) + (do ((pos (+ -1 (string-length str)) (+ -1 pos))) + ((or (negative? pos) (char=? (string-ref str pos) chr)) + (and (not (negative? pos)) pos)))) +;@ +(define (string-reverse-index-ci str chr) + (do ((pos (+ -1 (string-length str)) (+ -1 pos))) + ((or (negative? pos) (char-ci=? (string-ref str pos) chr)) + (and (not (negative? pos)) pos)))) +;@ +(define (substring? pat str) + (define patlen (string-length pat)) + (define strlen (string-length str)) + (cond ((zero? patlen) 0) ; trivial match + ((>= patlen strlen) (and (= patlen strlen) (string=? pat str) 0)) + ;; use faster string-index to match a single-character pattern + ((= 1 patlen) (string-index str (string-ref pat 0))) + ((or (<= strlen (+ patlen patlen (quotient char-code-limit 2))) + (<= patlen 4)) + (subloop pat patlen str strlen char=?)) + (else + ;; compute skip values for search pattern characters + ;; for all c not in pat, skip[c] = patlen + 1 + ;; for c in pat, skip[c] is distance of rightmost occurrence + ;; of c from end of str + (let ((skip (make-vector char-code-limit (+ patlen 1)))) + (do ((i 0 (+ i 1))) + ((= i patlen)) + (vector-set! skip (char->integer (string-ref pat i)) + (- patlen i))) + (subskip skip pat patlen str strlen char=?))))) +;@ +(define (substring-ci? pat str) + (define patlen (string-length pat)) + (define strlen (string-length str)) + (cond ((zero? patlen) 0) ; trivial match + ((>= patlen strlen) (and (= patlen strlen) (string-ci=? pat str) 0)) + ((= 1 patlen) (string-index-ci str (string-ref pat 0))) + ((or (<= strlen (+ patlen patlen (quotient char-code-limit 2))) + (<= patlen 4)) + (subloop pat patlen str strlen char-ci=?)) + (else + (let ((skip (make-vector char-code-limit (+ patlen 1)))) + (do ((i 0 (+ i 1))) + ((= i patlen)) + (let ((c (string-ref pat i)) + (d (- patlen i))) + ;; use same skip value for both upper- and lowercase characters + (vector-set! skip (char->integer (char-upcase c)) d) + (vector-set! skip (char->integer (char-downcase c)) d))) + (subskip skip pat patlen str strlen char-ci=?))))) -(define (string-reverse-index-ci str a-char) - (let loop ((pos (- (string-length str) 1))) - (cond ((< pos 0) #f) - ((char-ci=? (string-ref str pos) a-char) pos) - (else (loop (- pos 1)))))) +(define (subskip skip pat patlen str strlen char=) + (do ((k patlen (if (< k strlen) + (+ k (vector-ref skip (char->integer (string-ref str k)))) + (+ strlen 1)))) + ((or (> k strlen) + (do ((i 0 (+ i 1)) + (j (- k patlen) (+ j 1))) + ((or (= i patlen) + (not (char= (string-ref pat i) (string-ref str j)))) + (= i patlen)))) + (and (<= k strlen) (- k patlen))))) -(define (miscio:substring? pattern str char=?) - (let* ((pat-len (string-length pattern)) - (search-span (- (string-length str) pat-len)) - (c1 (if (zero? pat-len) #f (string-ref pattern 0))) - (c2 (if (<= pat-len 1) #f (string-ref pattern 1)))) +;;; Assumes that PATLEN > 1 +(define (subloop pat patlen str strlen char=) + (define span (- strlen patlen)) + (define c1 (string-ref pat 0)) + (define c2 (string-ref pat 1)) + (let outer ((pos 0)) (cond - ((not c1) 0) ; empty pattern, matches upfront - ((not c2) (string-index str c1)) ; one-char pattern - (else ; matching pattern of > two chars - (let outer ((pos 0)) - (cond - ((> pos search-span) #f) ; nothing was found thru the whole str - ((not (char=? c1 (string-ref str pos))) - (outer (+ 1 pos))) ; keep looking for the right beginning - ((not (char=? c2 (string-ref str (+ 1 pos)))) - (outer (+ 1 pos))) ; could've done pos+2 if c1 == c2.... - (else ; two char matched: high probability + ((> pos span) #f) ; nothing was found thru the whole str + ((not (char= c1 (string-ref str pos))) + (outer (+ 1 pos))) ; keep looking for the right beginning + ((not (char= c2 (string-ref str (+ 1 pos)))) + (outer (+ 1 pos))) ; could've done pos+2 if c1 == c2.... + (else ; two char matched: high probability ; the rest will match too - (let inner ((i-pat 2) (i-str (+ 2 pos))) - (if (>= i-pat pat-len) pos ; the whole pattern matched - (if (char=? (string-ref pattern i-pat) - (string-ref str i-str)) - (inner (+ 1 i-pat) (+ 1 i-str)) - ;; mismatch after partial match - (outer (+ 1 pos)))))))))))) - -(define (substring? pattern str) (miscio:substring? pattern str char=?)) -(define (substring-ci? pattern str) (miscio:substring? pattern str char-ci=?)) - + (let inner ((pdx 2) (sdx (+ 2 pos))) + (if (>= pdx patlen) pos ; the whole pat matched + (if (char= (string-ref pat pdx) + (string-ref str sdx)) + (inner (+ 1 pdx) (+ 1 sdx)) + ;; mismatch after partial match + (outer (+ 1 pos))))))))) +;@ (define (find-string-from-port? str <input-port> . max-no-char) (set! max-no-char (if (null? max-no-char) #f (car max-no-char))) (letrec @@ -94,7 +136,7 @@ (match-other-chars (lambda (pos-to-match) (if (>= pos-to-match (string-length str)) - no-chars-read ; the entire string has matched + no-chars-read ; the entire string has matched (let ((c (my-peek-char))) (and c (if (not (char=? c (string-ref str pos-to-match))) @@ -124,7 +166,7 @@ (backtrack (+ 1 i) matched-substr-len)))))))) ) (match-1st-char))) - +;@ (define (string-subst text old new . rest) (define sub (lambda (text) @@ -143,4 +185,8 @@ text (apply string-subst text rest)))) (sub text)) - +;@ +(define (count-newlines str) + (do ((idx (+ -1 (string-length str)) (+ -1 idx)) + (cnt 0 (+ (if (eqv? #\newline (string-ref str idx)) 1 0) cnt))) + ((<= idx 0) cnt))) diff --git a/structure.scm b/structure.scm index 0d379b9..5cb6f40 100644 --- a/structure.scm +++ b/structure.scm @@ -19,7 +19,7 @@ ;;; structure.ss ;;; Robert Hieb & Kent Dybvig ;;; 92/06/18 - +;@ A syntax-case macro: (define-syntax define-structure (lambda (x) (define construct-name diff --git a/subarray.scm b/subarray.scm new file mode 100644 index 0000000..69b18c4 --- /dev/null +++ b/subarray.scm @@ -0,0 +1,172 @@ +;;;;"subarray.scm" Scheme array accessory procedures. +; Copyright (C) 2002 Aubrey Jaffer and Radey Shouman +; +;Permission to copy this software, to modify it, to redistribute it, +;to distribute modified versions, and to use it for any purpose is +;granted, subject to the following restrictions and understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warranty or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +(require 'array) + +;;@code{(require 'subarray)} +;;@ftindex subarray + +;;@body +;;selects a subset of an array. For @1 of rank n, there must be at least +;;n @2 arguments. For 0 <= @i{j} < n, @2@i{j} is either an integer, a +;;list of two integers within the range for the @i{j}th index, or #f. +;; +;;When @2@i{j} is a list of two integers, then the @i{j}th index is +;;restricted to that subrange in the returned array. +;; +;;When @2@i{j} is #f, then the full range of the @i{j}th index is +;;accessible in the returned array. An elided argument is equivalent to #f. +;; +;;When @2@i{j} is an integer, then the rank of the returned array is +;;less than @1, and only elements whose @i{j}th index equals @2@i{j} are +;;shared. +;; +;;@example +;;> (define ra '#2A((a b c) (d e f))) +;;#<unspecified> +;;> (subarray ra 0 #f) +;;#1A(a b c) +;;> (subarray ra 1 #f) +;;#1A(d e f) +;;> (subarray ra #f 1) +;;#1A(b e) +;;> (subarray ra '(0 1) #f) +;;#2A((a b c) (d e f)) +;;> (subarray ra #f '(0 1)) +;;#2A((a b) (d e)) +;;> (subarray ra #f '(1 2)) +;;#2A((b c) (e f)) +;;@end example +(define (subarray array . selects) + (apply make-shared-array array + (lambda args + (let loop ((sels selects) + (args args) + (lst '())) + (cond ((null? sels) + (if (null? args) + (reverse lst) + (loop sels (cdr args) (cons (car args) lst)))) + ((number? (car sels)) + (loop (cdr sels) args (cons (car sels) lst))) + (else + (loop (cdr sels) (cdr args) (cons (car args) lst)))))) + (let loop ((sels selects) + (shp (array-shape array)) + (nshp '())) + (cond ((null? shp) + (if (null? sels) + (reverse nshp) + (slib:error 'subarray 'rank (array-rank array) 'mismatch selects))) + ((null? sels) + (loop sels (cdr shp) (cons (car shp) nshp))) + ((not (car sels)) + (loop (cdr sels) (cdr shp) (cons (car shp) nshp))) + ((integer? (car sels)) + (loop (cdr sels) (cdr shp) nshp)) + (else + (loop (cdr sels) (cdr shp) (cons (car sels) nshp))))))) + +;;@body +;;Behaves like @r{subarray}, but @r{align}s the returned array origin to +;;0 @dots{}. +(define (subarray0 array . selects) + (define ra (apply subarray array selects)) + (apply array-align ra (map (lambda (x) 0) (array-shape ra)))) + +;;@body +;; +;;Returns an array shared with @1 but with a different origin. The @2 +;;are the exact integer coordinates of the new origin. Indexes +;;corresponding to missing or #f coordinates are not realigned. +;; +;;For example: +;;@example +;;(define ra2 (create-array '#(5) '(5 9) '(-4 0))) +;;(array-shape ra2) @result{} ((5 9) (-4 0)) +;;(array-shape (array-align ra2 0 0)) @result{} ((0 4) (0 4)) +;;(array-shape (array-align ra2 0)) @result{} ((0 4) (-4 0)) +;;(array-shape (array-align ra2)) @result{} ((5 9) (-4 0)) +;;(array-shape (array-align ra2 0 #f)) @result{} ((0 4) (-4 0)) +;;(array-shape (array-align ra2 #f 0)) @result{} ((5 9) (0 4)) +;;@end example +(define (array-align array . coords) + (let* ((shape (array-shape array)) + (offs (let recur ((shp shape) + (crd coords)) + (cond ((null? shp) '()) + ((null? crd) (map (lambda (x) 0) shp)) + ((not (car crd)) (cons 0 (recur (cdr shp) (cdr crd)))) + (else (cons (- (car crd) (caar shp)) + (recur (cdr shp) (cdr crd)))))))) + (apply make-shared-array + array (lambda inds (map - inds offs)) + (map (lambda (spec off) + (list (+ (car spec) off) (+ (cadr spec) off))) + shape offs)))) + +;;@body +;; +;;Returns a subarray sharing contents with @1 except for slices removed +;;from either side of each dimension. Each of the @2 is an exact +;;integer indicating how much to trim. A positive @var{s} trims the +;;data from the lower end and reduces the upper bound of the result; a +;;negative @var{s} trims from the upper end and increases the lower +;;bound. +;; +;;For example: +;;@example +;;(array-trim '#(0 1 2 3 4) 1) @result{} #1A(1 2 3 4) ;; shape is ((0 3)) +;;(array-trim '#(0 1 2 3 4) -1) @result{} #1A(0 1 2 3) ;; shape is ((1 4)) +;; +;;(require 'array-for-each) +;;(define (centered-difference ra) +;; (array-map - (array-trim ra 1) (array-trim ra -1))) +;;(define (forward-difference ra) +;; (array-map - (array-trim ra 1) ra)) +;;(define (backward-difference ra) +;; (array-map - ra (array-trim ra -1))) +;; +;;(centered-difference '#(0 1 3 5 9 22)) +;; @result{} #1A(3 4 6 17) ;;shape is ((1 4)) +;;(backward-difference '#(0 1 3 5 9 22)) +;; @result{} #1A(1 2 2 4 13) ;; shape is ((1 5)) +;;(forward-difference '#(0 1 3 5 9 22)) +;; @result{} #(1 2 2 4 13) ;; shape is ((0 4)) +;;@end example +(define (array-trim array . trims) + (let* ((shape (array-shape array)) + (trims (let recur ((shp shape) + (ss trims)) + (cond ((null? shp) '()) + ((null? ss) (map (lambda (x) 0) shp)) + ((integer? (car ss)) + (cons (car ss) (recur (cdr shp) (cdr ss)))) + (else + (slib:error 'array-trim 'bad 'trim (car ss))))))) + (apply make-shared-array + array + (lambda inds (map + inds trims)) + (map (lambda (spec trim) + (cond ((negative? trim) + (cons (- (car spec) trim) (cdr spec))) + ((positive? trim) + (list (car spec) (- (cadr spec) trim))) + (else spec))) + shape trims)))) diff --git a/subarray.txi b/subarray.txi new file mode 100644 index 0000000..7d62ed6 --- /dev/null +++ b/subarray.txi @@ -0,0 +1,94 @@ +@code{(require 'subarray)} +@ftindex subarray + + +@defun subarray array select @dots{} + +selects a subset of an array. For @var{array} of rank n, there must be at least +n @var{selects} arguments. For 0 <= @i{j} < n, @var{selects}@i{j} is either an integer, a +list of two integers within the range for the @i{j}th index, or #f. + +When @var{selects}@i{j} is a list of two integers, then the @i{j}th index is +restricted to that subrange in the returned array. + +When @var{selects}@i{j} is #f, then the full range of the @i{j}th index is +accessible in the returned array. An elided argument is equivalent to #f. + +When @var{selects}@i{j} is an integer, then the rank of the returned array is +less than @var{array}, and only elements whose @i{j}th index equals @var{selects}@i{j} are +shared. + +@example +> (define ra '#2A((a b c) (d e f))) +#<unspecified> +> (subarray ra 0 #f) +#1A(a b c) +> (subarray ra 1 #f) +#1A(d e f) +> (subarray ra #f 1) +#1A(b e) +> (subarray ra '(0 1) #f) +#2A((a b c) (d e f)) +> (subarray ra #f '(0 1)) +#2A((a b) (d e)) +> (subarray ra #f '(1 2)) +#2A((b c) (e f)) +@end example +@end defun + +@defun subarray0 array select @dots{} + +Behaves like @r{subarray}, but @r{align}s the returned array origin to +0 @dots{}. +@end defun + +@defun array-align array coord @dots{} + + +Returns an array shared with @var{array} but with a different origin. The @var{coords} +are the exact integer coordinates of the new origin. Indexes +corresponding to missing or #f coordinates are not realigned. + +For example: +@example +(define ra2 (create-array '#(5) '(5 9) '(-4 0))) +(array-shape ra2) @result{} ((5 9) (-4 0)) +(array-shape (array-align ra2 0 0)) @result{} ((0 4) (0 4)) +(array-shape (array-align ra2 0)) @result{} ((0 4) (-4 0)) +(array-shape (array-align ra2)) @result{} ((5 9) (-4 0)) +(array-shape (array-align ra2 0 #f)) @result{} ((0 4) (-4 0)) +(array-shape (array-align ra2 #f 0)) @result{} ((5 9) (0 4)) +@end example +@end defun + +@defun array-trim array trim @dots{} + + +Returns a subarray sharing contents with @var{array} except for slices removed +from either side of each dimension. Each of the @var{trims} is an exact +integer indicating how much to trim. A positive @var{s} trims the +data from the lower end and reduces the upper bound of the result; a +negative @var{s} trims from the upper end and increases the lower +bound. + +For example: +@example +(array-trim '#(0 1 2 3 4) 1) @result{} #1A(1 2 3 4) ;; shape is ((0 3)) +(array-trim '#(0 1 2 3 4) -1) @result{} #1A(0 1 2 3) ;; shape is ((1 4)) + +(require 'array-for-each) +(define (centered-difference ra) + (array-map - (array-trim ra 1) (array-trim ra -1))) +(define (forward-difference ra) + (array-map - (array-trim ra 1) ra)) +(define (backward-difference ra) + (array-map - ra (array-trim ra -1))) + +(centered-difference '#(0 1 3 5 9 22)) + @result{} #1A(3 4 6 17) ;;shape is ((1 4)) +(backward-difference '#(0 1 3 5 9 22)) + @result{} #1A(1 2 2 4 13) ;; shape is ((1 5)) +(forward-difference '#(0 1 3 5 9 22)) + @result{} #(1 2 2 4 13) ;; shape is ((0 4)) +@end example +@end defun @@ -20,7 +20,7 @@ ;;; software shall duly acknowledge such use, in accordance with the ;;; usual standards of acknowledging credit in academic research. ;;; -;;; 4. MIT has made no warrantee or representation that the operation +;;; 4. MIT has made no warranty or representation that the operation ;;; of this software will be error-free, and MIT is under no ;;; obligation to provide any services, by way of maintenance, update, ;;; or otherwise. @@ -20,7 +20,7 @@ ;;; software shall duly acknowledge such use, in accordance with the ;;; usual standards of acknowledging credit in academic research. ;;; -;;; 4. MIT has made no warrantee or representation that the operation +;;; 4. MIT has made no warranty or representation that the operation ;;; of this software will be error-free, and MIT is under no ;;; obligation to provide any services, by way of maintenance, update, ;;; or otherwise. @@ -194,7 +194,7 @@ (define syntactic-closure-type (make-record-type "syntactic-closure" '(ENVIRONMENT FREE-NAMES FORM))) - +;@ (define make-syntactic-closure (record-constructor syntactic-closure-type '(ENVIRONMENT FREE-NAMES FORM))) @@ -230,7 +230,7 @@ result))) (else object))) - +;@ (define (identifier? object) (or (symbol? object) (synthetic-identifier? object))) @@ -246,7 +246,7 @@ (identifier->symbol (syntactic-closure/form identifier))) (else (impl-error "not an identifier" identifier)))) - +;@ (define (identifier=? environment-1 identifier-1 environment-2 identifier-2) (let ((item-1 (syntactic-environment/lookup environment-1 identifier-1)) (item-2 (syntactic-environment/lookup environment-2 identifier-2))) @@ -541,7 +541,7 @@ ((definition-item/binding-theory item) environment (definition-item/name item) - (promise:force (definition-item/value item)))) + (force (definition-item/value item)))) (define (syntactic-binding-theory environment name item) (if (or (keyword-item? item) @@ -684,7 +684,7 @@ (for-each (lambda (name) (syntactic-environment/define! environment name item)) names))) - +;@ (define (capture-syntactic-environment expander) (classifier->form (lambda (form environment definition-environment) @@ -20,7 +20,7 @@ ;;; software shall duly acknowledge such use, in accordance with the ;;; usual standards of acknowledging credit in academic research. ;;; -;;; 4. MIT has made no warrantee or representation that the operation +;;; 4. MIT has made no warranty or representation that the operation ;;; of this software will be error-free, and MIT is under no ;;; obligation to provide any services, by way of maintenance, update, ;;; or otherwise. @@ -19,14 +19,12 @@ ;;; (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) "ftp://ftp.cs.indiana.edu:21/pub/scheme-repository/imp/t/README") ;;; (implementation-vicinity) should be defined to be the pathname of ;;; the directory where any auxillary files to your Scheme ;;; implementation reside. It is settable. - (define implementation-vicinity (make-simple-switch 'implementation-vicinity (lambda (x) (or (string? x) (false? x))) @@ -35,7 +33,6 @@ ;;; (library-vicinity) should be defined to be the pathname of the ;;; directory where files of Scheme library functions reside. It is settable. - (define library-vicinity (make-simple-switch 'library-vicinity (lambda (x) (or (string? x) (false? x))) @@ -46,13 +43,11 @@ ;;; (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) ;;; *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 @@ -62,7 +57,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 @@ -76,11 +71,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!, @@ -91,7 +86,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,14 +127,12 @@ ; Modify substring as T's substring takes (start,count) instead of ; (start,end) - (set (syntax-table-entry (env-syntax-table scheme-env) 'require) '#f) ; Turn off the macro REQUIRE so that it can be rebound as a function ; later. ; extend <, >, <= and >= so that they take more than two arguments. - (define < (let ((primitive< (*value standard-env '<))) (labels ((v (lambda (a b . rest) @@ -298,7 +291,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) @@ -311,7 +304,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+ n) (+ n -1)) @@ -367,7 +359,6 @@ ;;; FORCE-OUTPUT flushes any pending output on optional arg output port ;;; use this definition if your system doesn't have such a procedure. ;;; T already has it, but requires 1 argument. - (define force-output (let ((t:force-output (*value standard-env 'force-output))) (lambda x @@ -383,6 +374,33 @@ (define (call-with-input-string string proc) (with-input-from-string (variable string) (proc variable))) +(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 t3.init")) + (define (string->number s . x) (let ((base (if x (car x) 10)) (s (string-upcase s))) @@ -454,17 +472,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 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:load (in-vicinity (library-vicinity) "require") scheme-env) diff --git a/tek40.scm b/tek40.scm deleted file mode 100644 index b2be1ca..0000000 --- a/tek40.scm +++ /dev/null @@ -1,92 +0,0 @@ -;"tek40.scm", Tektronix 4000 series graphics support in Scheme. -;Copyright (C) 1992, 1994 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 warrantee 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 FILE NEEDS MORE WORK. - -;The Tektronix 4000 series graphics protocol gives the user a 1024 by -;1024 square drawing area. The origin is in the lower left corner of -;the screen. Increasing y is up and increasing x is to the right. - -;The graphics control codes are sent over the current-output-port and -;can be mixed with regular text and ANSI or other terminal control -;sequences. - -; (tek40:init) procedure - -(define (tek40:init) 'noop) - -(define esc-string (string (integer->char #o33))) - -(define tek40:graphics-str - (string-append - (string slib:form-feed) - esc-string (string (integer->char #o14)) - ;; clear the screen - )) - -(define (tek40:graphics) (display tek40:graphics-str) (force-output)) - -(define (tek40:text) - (tek40:move 0 12) - (write-char (integer->char #o37))) - -(define (tek40:linetype linetype) - (cond ((or (negative? linetype) (> linetype 15)) - (slib:error "bad linetype" linetype)) - (else - (display esc-string) - (write-char (integer->char (+ (char->integer #\`) linetype)))))) - -(define (tek40:move x y) - (write-char (integer->char #o35)) - (tek40:draw x y)) - -(define (tek40:draw x y) - (display (string - (integer->char (+ #x20 (quotient y 32))) - (integer->char (+ #x60 (remainder y 32))) - (integer->char (+ #x20 (quotient x 32))) - (integer->char (+ #x40 (remainder x 32)))))) - -(define (tek40:put-text x y str) - (tek40:move x (+ y -11)) - (write-char (integer->char #o37)) - (display str)) - -(define (tek40:reset) (display tek40:graphics-str) (force-output)) - -(define (tek40:test) - (tek40:init) -; (tek40:reset) - (tek40:graphics) - (tek40:linetype 0) - (tek40:move 100 100) - (tek40:draw 200 100) - (tek40:draw 200 200) - (tek40:draw 100 200) - (tek40:draw 100 100) - (do ((i 0 (+ 1 i))) - ((> i 15)) - (tek40:linetype i) - (tek40:move (+ (* 50 i) 100) 100) - (tek40:put-text (+ (* 50 i) 100) 100 (number->string i)) - (tek40:move (+ (* 50 i) 100) 100) - (tek40:draw (+ (* 50 i) 200) 200)) - (tek40:linetype 0) - (tek40:text)) diff --git a/tek41.scm b/tek41.scm deleted file mode 100644 index 7d4c6b6..0000000 --- a/tek41.scm +++ /dev/null @@ -1,147 +0,0 @@ -;"tek41.scm", Tektronix 4100 series graphics support in Scheme. -;Copyright (C) 1992, 1994 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 warrantee 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 FILE NEEDS MORE WORK. Let me know if you test or fix it. - -;The graphics control codes are sent over the current-output-port and -;can be mixed with regular text and ANSI or other terminal control -;sequences. - -(define esc-string (string (integer->char #o33))) - -(define tek41:init - (string-append - esc-string "%!0" - ;;1. set tek mode - esc-string "MN0" - ;;2. set character path to 0 (characters placed equal to rotation) - esc-string "MCB7C;" - ;;3. set character size to 59 height - esc-string "MQ1" - ;;4. set character precision to string - esc-string "MT1" - ;;5. set character text index to 1 - esc-string "MG1" - ;;6. set character write mode to overstrike - esc-string "RK!" - ;;7. clear the view - esc-string "SK!" - ;;8. clear the segments - esc-string "LZ" - ;;9. clear the dialog buffer - esc-string "%!1" - ;;10. set ansi mode - )) - -(define (tek41:init) (display tek41:init-str) (force-output)) - -(define (tek41:reset) - (string-append - esc-string "%!0" - ;;1. set tek mode - esc-string "LZ" - ;;2. clear the dialog buffer - esc-string "%!1" - ;;3. set ansi mode - )) - -(define (tek41:reset) (display tek41:reset-str) (force-output)) - -(define tek41:graphics-str - (string-append - esc-string "%!0" - ;;1. set tek mode - esc-string (string (integer->char #o14)) - ;;2. clear the screen - esc-string "LV0" - ;;3. set dialog area invisible - )) - -(define (tek41:graphics) (display tek41:graphics-str) (force-output)) - -(define tek41:text-str - (string-append - esc-string "LV1" - ;;1. set dialog area visible - esc-string "%!1" - ;;2. set ansi mode - )) - -(define (tek41:text) (display tek41:text-str) (force-output)) - -(define tek41:move-str - (string-append esc-string "LF")) - -(define (tek41:move x y) - (display tek41:move-str) - (tek41:encode-x-y x y) - (force-output)) - -(define tek41:draw-str - (string-append esc-string "LG")) - -(define (tek41:draw x y) - (display tek41:draw-str) - (tek41:encode-x-y x y) - (force-output)) - -(define tek41:set-marker-str (string-append esc-string "MM")) -(define tek41:draw-marker-str (string-append esc-string "LH")) - -(define (tek41:point x y number) - (display tek41:set-marker-str) - (tek41:encode-int (remainder (max number 0) 11)) - (display tek41:draw-marker-str) - (tek41:encode-x-y x y) - (force-output)) - -(define (tek41:encode-x-y x y) - (let ((hix (+ (quotient x 128) 32)) - (lox (+ (modulo (quotient x 4) 32) 64)) - (hiy (+ (quotient y 128) 32)) - (loy (+ (modulo (quotient y 4) 32) 96)) - (eb (+ (* (modulo y 4) 4) (modulo x 4) 96))) - (if (positive? hiy) (write-char (integer->char hiy))) - (if (positive? eb) (write-char (integer->char eb))) - (if (positive? (+ loy eb hix)) (write-char (integer->char loy))) - (if (positive? hix) (write-char (integer->char hix))) - (write-char (integer->char lox)))) - -(define (tek41:encode-int number) - (let* ((mag (abs number)) - (hi1 (+ (quotient mag 1024) 64)) - (hi2 (+ (modulo (quotient mag 16) 64) 64)) - (lo (+ (modulo mag 16) 32))) - (if (>= number 0) (set! lo (+ lo 16))) - (if (not (= hi1 64)) (write-char (integer->char hi1))) - (if (or (not (= hi2 64)) - (not (= hi1 64))) - (write-char (integer->char hi2))) - (write-char (integer->char lo)))) - -(define (test) - (tek41:init) - (tek41:reset) - (tek41:graphics) - (do ((i 0 (+ 1 i))) - ((> i 15)) - (tek41:linetype i) - (tek41:move (+ (* 200 i) 1000) 1000) - (tek41:draw (+ (* 200 i) 2000) 2000)) - (tek41:text)) diff --git a/timezone.scm b/timezone.scm index d592478..89f85c8 100644 --- a/timezone.scm +++ b/timezone.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. ; @@ -46,11 +46,11 @@ ;; Writing this was a long, tedious, and unenlightening process. I hope it ;; is useful. ;; -;; Sat Nov 15 00:15:33 1997 Aubrey Jaffer <jaffer@martigny.ai.mit.edu> +;; Sat Nov 15 00:15:33 1997 Aubrey Jaffer -(provide 'time-zone) (require 'scanf) - +(require-if 'compiling 'tzfile) +;@ (define daylight? #f) (define *timezone* 0) (define tzname '#("UTC" "???")) @@ -146,7 +146,7 @@ start end (vector 'tz:rule tz tzname dtzname offset doffset start end)))) (else #f)))) - +;@ (define (time-zone tz) (cond ((not tz) (read-tzfile #f)) ((vector? tz) tz) @@ -182,7 +182,7 @@ (+ tr-day (if (and (not tr-week) (>= tr-day 60) (leap-year? year)) 1 0))))))) - +;@ (define (tz:params caltime tz) (case (vector-ref tz 0) ((tz:fixed) (list 0 (vector-ref tz 3) (vector-ref tz 2))) @@ -203,7 +203,7 @@ (- (vector-ref zone-spec 1)) (vector-ref zone-spec 0)))) (else (slib:error 'tz:params "unknown timezone type" tz)))) - +;@ (define (tz:std-offset zone) (case (vector-ref zone 0) ((tz:fixed) (vector-ref zone 3)) @@ -218,7 +218,7 @@ (- (vector-ref (vector-ref mode-table type-idx) 1))))))) (else (slib:error 'tz:std-offset "unknown timezone type" tz)))) -;;; Interpret the TZ envariable. +;;;@ Interpret the TZ envariable. (define (tzset . opt-tz) (define tz (if (null? opt-tz) (getenv "TZ") diff --git a/top-refs.scm b/top-refs.scm new file mode 100644 index 0000000..29e25dc --- /dev/null +++ b/top-refs.scm @@ -0,0 +1,285 @@ +;"top-refs.scm" List Scheme code's top-level variable references. +;Copyright (C) 1995, 2003 Aubrey Jaffer +; +;Permission to copy this software, to modify it, to redistribute it, +;to distribute modified versions, and to use it for any purpose is +;granted, subject to the following restrictions and understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warranty or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +(require 'fluid-let) +(require 'line-i/o) ; exports<-info-index uses +(require 'string-case) ; exports<-info-index uses +(require 'string-search) ; exports<-info-index uses +(require 'manifest) ; load->path + +;;@code{(require 'top-refs)} +;;@ftindex top-refs +;;@cindex top-level variable references +;;@cindex variable references +;; +;;@noindent +;;These procedures complement those in @ref{Module Manifests} by +;;finding the top-level variable references in Scheme source code. +;;They work by traversing expressions and definitions, keeping track +;;of bindings encountered. It is certainly possible to foil these +;;functions, but they return useful information about SLIB source +;;code. + +(define *references* '()) +(define *bindings* '()) + +(define (top-refs:warn proc msg . more) + (for-each display (list "WARN:" proc ": " msg " ")) + (for-each (lambda (x) (write x) (display #\ )) + more) + (newline)) +;;@body +;;Returns a list of the top-level variables referenced by the Scheme +;;expression @1. +(define (top-refs obj) + (fluid-let ((*references* '())) + (if (string? obj) + (top-refs:include obj) + (top-refs:top-level obj)) + *references*)) +;;@body +;;@1 should be a string naming an existing file containing Scheme +;;source code. @0 returns a list of the top-level variable references +;;made by expressions in the file named by @1. +;; +;;Code in modules which @1 @code{require}s is not traversed. Code in +;;files loaded from top-level @emph{is} traversed if the expression +;;argument to @code{load}, @code{slib:load}, @code{slib:load-source}, +;;@code{macro:load}, @code{defmacro:load}, @code{synclo:load}, +;;@code{syncase:load}, or @code{macwork:load} is a literal string +;;constant or composed of combinations of vicinity functions and +;;string literal constants; and the resulting file exists (possibly +;;with ".scm" appended). +(define (top-refs<-file filename) + (fluid-let ((*references* '())) + (top-refs:include filename) + *references*)) + +(define (top-refs:include filename) + (cond ((not (and (string? filename) (file-exists? filename))) + (top-refs:warn 'top-refs:include 'skipping filename)) + (else (fluid-let ((*load-pathname* filename)) + (call-with-input-file filename + (lambda (port) + (do ((exp (read port) (read port))) + ((eof-object? exp)) + (top-refs:top-level exp)))))))) + +(define (top-refs:top-level exp) + (cond ((not (and (pair? exp) (list? exp))) + (top-refs:warn 'top-refs "non-list at top level?" exp)) + ((not (symbol? (car exp))) (top-refs:expression exp)) + (else + (case (car exp) + ((begin) (for-each top-refs:top-level (cdr exp))) + ((cond) (for-each (lambda (clause) + (for-each top-refs:top-level clause)) + (cdr exp))) + ((if) (for-each top-refs:top-level + (if (list? (cadr exp)) (cdr exp) (cddr exp)))) + ((define define-operation) + ;;(display "; walking ") (write (cadr exp)) (newline) + (top-refs:binding (cadr exp) (cddr exp))) + ((define-syntax) + (top-refs:binding (cadr exp) (cddr exp))) + ((defmacro) + ;;(display "; malking ") (write (cadr exp)) (newline) + (if (pair? (cadr exp)) + (top-refs:binding (cdadr exp) (cddr exp)) + (top-refs:binding (caddr exp) (cdddr exp)))) + ((load slib:load slib:load-source macro:load defmacro:load + syncase:load synclo:load macwork:load) + (top-refs:include (load->path (cadr exp)))) + ;;((require) (top-refs:require ''compiling (cadr exp))) + ;;((require-if) (top-refs:require (cadr exp) (caddr exp))) + (else (top-refs:expression exp)))))) + +(define (arglist:flatten b) + (cond ((symbol? b) (list b)) + ((pair? b) + (if (pair? (car b)) + (append (arglist:flatten (car b)) (arglist:flatten (cdr b))) + (cons (car b) (arglist:flatten (cdr b))))) + ((list? b) b) + (else (slib:error 'arglist:flatten 'bad b)))) + +(define (top-refs:binding binding body) + (fluid-let ((*bindings* (append (arglist:flatten binding) + *bindings*))) + (for-each (lambda (exp) + (cond ((and (pair? exp) (eq? 'define (car exp))) + (set! *bindings* (cons (if (symbol? (cadr exp)) + (cadr exp) + (caadr exp)) + *bindings*))))) + body) + (for-each top-refs:expression body))) + +(define (top-refs:expression exp) + (define (cwq exp) + (cond ((vector? exp) (for-each cwq (vector->list exp))) + ((not (pair? exp))) + ((not (list? exp)) (top-refs:warn " dotted list? " exp)) + ((memq (car exp) '(unquote unquote-splicing)) + (top-refs:expression (cadr exp))) + (else (for-each cwq exp)))) + (define (cwe exp) + (cond ((symbol? exp) + (if (and (not (memq exp *bindings*)) + (not (memq exp *references*))) + (set! *references* (cons exp *references*)))) + ((not (pair? exp))) + ((not (list? exp)) + (for-each top-refs:expression (arglist:flatten exp))) + ((not (symbol? (car exp))) (for-each top-refs:expression exp)) + (else + (case (car exp) + ((quote) #f) + ((quasiquote) (cwq (cadr exp))) + ((begin) (for-each cwe (cdr exp))) + ((define) + (cond ((pair? (cadr exp)) ; (define (foo ...) ...) + (top-refs:binding (cadr exp) (cddr exp))) + (else + (top-refs:binding (cadr exp) (list (cddr exp)))))) + ((lambda) (top-refs:binding (cadr exp) (cddr exp))) + ((case) + (top-refs:expression (cadr exp)) + (for-each (lambda (exp) + (for-each top-refs:expression (cdr exp))) + (cddr exp))) + ((cond) + (for-each (lambda (exp) + (for-each top-refs:expression exp)) + (cdr exp))) + ((let) + (cond ((symbol? (cadr exp)) + (for-each top-refs:expression (map cadr (caddr exp))) + (top-refs:binding (cons (cadr exp) (map car (caddr exp))) + (cdddr exp))) + (else + (for-each top-refs:expression (map cadr (cadr exp))) + (top-refs:binding (map car (cadr exp)) (cddr exp))))) + ((letrec with-syntax) + (top-refs:binding + (map car (cadr exp)) (append (map cadr (cadr exp)) (cddr exp)))) + ((let*) + (cond ((null? (cadr exp)) + (top-refs:binding '() (cddr exp))) + ((pair? (caadr exp)) + (top-refs:expression (cadr (caadr exp))) + (top-refs:binding (caaadr exp) + `((let* ,(cdadr exp) ,@(cddr exp))))) + (else + (top-refs:binding (list (caadr exp)) + `((let* ,(cdadr exp) ,@(cddr exp))))))) + ((do) + (for-each top-refs:expression (map cadr (cadr exp))) + (top-refs:binding + (map car (cadr exp)) + (append + (map (lambda (binding) + (case (length binding) + ((2) (car binding)) + ((3) (caddr binding)) + (else (top-refs:warn + 'top-refs:expression 'bad 'do-binding exp)))) + (cadr exp)) + (caddr exp) + (cddr exp)))) + ((syntax-rules) + (fluid-let ((*bindings* (append (arglist:flatten (cadr exp)) + *bindings*))) + (for-each (lambda (exp) + (top-refs:binding (car exp) (cdr exp))) + (cddr exp)))) + ((syntax-case) + (fluid-let ((*bindings* + (cons (cadr exp) + (append (arglist:flatten (caddr exp)) + *bindings*)))) + (for-each (lambda (exp) + (top-refs:binding (car exp) (cdr exp))) + (cdddr exp)))) + (else (for-each top-refs:expression exp)))))) + (cwe exp)) + +;;@noindent +;;The following function parses an @dfn{Info} Index. +;;@footnote{Although it will +;;work on large info files, feeding it an excerpt is much faster; and +;;has less chance of being confused by unusual text in the info file. +;;This command excerpts the SLIB index into @file{slib-index.info}: +;; +;;@example +;;info -f slib2d6.info -n "Index" -o slib-index.info +;;@end example +;;} + +;;@body +;;@2 @dots{} must be an increasing series of positive integers. +;;@0 returns a list of all the identifiers appearing in the @var{n}th +;;@dots{} (info) indexes of @1. The identifiers have the case that +;;the implementation's @code{read} uses for symbols. Identifiers +;;containing spaces (eg. @code{close-base on base-table}) are +;;@emph{not} included. +;; +;;Each info index is headed by a @samp{* Menu:} line. To list the +;;symbols in the first and third info indexes do: +;; +;;@example +;;(exports<-info-index "slib.info" 1 3) +;;@end example +(define (exports<-info-index file . n) + (call-with-input-file file + (lambda (port) + (define exports '()) + (and + (find-string-from-port? " Node: Index," port) + (let loop ((line (read-line port)) + (iidx 1) + (ndxs n)) + (cond ((null? ndxs) (reverse exports)) + ((eof-object? line) #f) + ((not (string-ci=? "* Menu:" line)) + (loop (read-line port) iidx ndxs)) + ((>= iidx (car ndxs)) + (let ((blank (read-line port))) + (if (not (equal? "" blank)) + (slib:error 'funny 'blank blank))) + (do ((line (read-line port) (read-line port))) + ((or (eof-object? line) + (not (and (> (string-length line) 5) + (string=? "* " (substring line 0 2))))) + (loop (read-line port) (+ 1 iidx) (cdr ndxs))) + (let ((<n> (substring? " <" line))) + (define csi (or (and <n> + (> (string-length line) (+ 3 <n>)) + (string-index + "0123456789" + (string-ref line (+ 2 <n>))) + <n>) + (substring? ": " line))) + (and + csi + (let ((str (substring line 2 csi))) + (if (and (not (substring? " " str)) + (not (memq (string-ci->symbol str) exports))) + (set! exports (cons (string-ci->symbol str) exports)))))))) + (else (loop (read-line port) (+ 1 iidx) ndxs)))))))) diff --git a/top-refs.txi b/top-refs.txi new file mode 100644 index 0000000..11944bb --- /dev/null +++ b/top-refs.txi @@ -0,0 +1,65 @@ +@code{(require 'top-refs)} +@ftindex top-refs +@cindex top-level variable references +@cindex variable references + +@noindent +These procedures complement those in @ref{Module Manifests} by +finding the top-level variable references in Scheme source code. +They work by traversing expressions and definitions, keeping track +of bindings encountered. It is certainly possible to foil these +functions, but they return useful information about SLIB source +code. + + +@defun top-refs obj + +Returns a list of the top-level variables referenced by the Scheme +expression @var{obj}. +@end defun + +@defun top-refs<-file filename + +@var{filename} should be a string naming an existing file containing Scheme +source code. @code{top-refs<-file} returns a list of the top-level variable references +made by expressions in the file named by @var{filename}. + +Code in modules which @var{filename} @code{require}s is not traversed. Code in +files loaded from top-level @emph{is} traversed if the expression +argument to @code{load}, @code{slib:load}, @code{slib:load-source}, +@code{macro:load}, @code{defmacro:load}, @code{synclo:load}, +@code{syncase:load}, or @code{macwork:load} is a literal string +constant or composed of combinations of vicinity functions and +string literal constants; and the resulting file exists (possibly +with ".scm" appended). +@end defun +@noindent +The following function parses an @dfn{Info} Index. +@cindex Info +@footnote{Although it will +work on large info files, feeding it an excerpt is much faster; and +has less chance of being confused by unusual text in the info file. +This command excerpts the SLIB index into @file{slib-index.info}: + +@example +info -f slib2d6.info -n "Index" -o slib-index.info +@end example +} + + +@defun exports<-info-index file n @dots{} + +@var{n} @dots{} must be an increasing series of positive integers. +@code{exports<-info-index} returns a list of all the identifiers appearing in the @var{n}th +@dots{} (info) indexes of @var{file}. The identifiers have the case that +the implementation's @code{read} uses for symbols. Identifiers +containing spaces (eg. @code{close-base on base-table}) are +@emph{not} included. + +Each info index is headed by a @samp{* Menu:} line. To list the +symbols in the first and third info indexes do: + +@example +(exports<-info-index "slib.info" 1 3) +@end example +@end defun @@ -1,5 +1,5 @@ -;;;; "trace.scm" Utility macros for tracing in Scheme. -;;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1999, 2000 Aubrey Jaffer +;;;; "trace.scm" Utility functions and macros for tracing in Scheme. +;;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1999, 2000, 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,8 +18,11 @@ ;each case. (require 'qp) ;for the qp printer. +(require 'alist) + (define trace:indent 0) (define debug:call-stack '()) ;keeps track of call stack. +;@ (define debug:max-count 5) ;;Formats for call-stack elements: @@ -27,6 +30,7 @@ ;; (procedure-count name) ;for debug:stack procedure ;;Traced functions also stack. +;@ (define print-call-stack (let ((car car) (null? null?) (current-error-port current-error-port) (qpn qpn) (for-each for-each)) @@ -121,7 +125,7 @@ ;;; The reason I use a symbol for debug:untrace-object is so that ;;; functions can still be untraced if this file is read in twice. - +;@ (define (untracef function) (set! trace:indent 0) (function 'debug:untrace-object)) @@ -130,7 +134,6 @@ ;;; niceties like keeping track of traced functions and dealing with ;;; redefinition. -(require 'alist) (define trace:adder (alist-associator eq?)) (define trace:deler (alist-remover eq?)) @@ -190,13 +193,14 @@ (set! *stacked-procedures* (trace:deler *stacked-procedures* sym)) (finish p))) (else fun))) - +;@ (define (tracef . args) (apply debug:trace-procedure 'trace args)) +;@ (define (trackf . args) (apply debug:trace-procedure 'track args)) +;@ (define (stackf . args) (apply debug:trace-procedure 'stack args)) - ;;;; Finally, the macros trace and untrace - +;@ (defmacro trace xs (if (null? xs) `(begin (set! trace:indent 0) @@ -222,7 +226,7 @@ (map car *stacked-procedures*)) `(begin ,@(map (lambda (x) `(set! ,x (trace:trace-procedure 'stack ,x ',x))) xs)))) - +;@ (defmacro untrace xs (if (null? xs) (slib:eval @@ -232,7 +236,6 @@ '',(map car *traced-procedures*))) `(begin ,@(map (lambda (x) `(set! ,x (trace:untrace-procedure ,x ',x))) xs)))) - (defmacro untrack xs (if (null? xs) (slib:eval @@ -242,7 +245,6 @@ '',(map car *tracked-procedures*))) `(begin ,@(map (lambda (x) `(set! ,x (track:untrack-procedure ,x ',x))) xs)))) - (defmacro unstack xs (if (null? xs) (slib:eval diff --git a/transact.scm b/transact.scm new file mode 100644 index 0000000..59a06fe --- /dev/null +++ b/transact.scm @@ -0,0 +1,486 @@ +;;; "transact.scm" Interface to programs. +; Copyright 1997, 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 'string-search) +(require 'filename) +(require 'line-i/o) +(require 'system) +(require 'printf) +(require 'scanf) +(require 'byte) +(require-if 'compiling 'directory) + +;;@subsubheading File Locking +;; +;;@noindent +;;Unix file-locking is focussed on write permissions for segments of a +;;existing file. While this might be employed for (binary) database +;;access, it is not used for everyday contention (between users) for +;;text files. +;; +;;@noindent +;;Microsoft has several file-locking protocols. Their model denies +;;write access to a file if any reader has it open. This is too +;;restrictive. Write access is denied even when the reader has +;;reached end-of-file. And tracking read access (which is much more +;;common than write access) causes havoc when remote hosts crash or +;;disconnect. +;; +;;@noindent +;;It is bizarre that the concept of multi-user contention for +;;modifying files has not been adequately addressed by either of the +;;large operating system development efforts. There is further irony +;;that both camps support contention detection and resolution only +;;through weak conventions of some their document editing programs. +;; +;;@noindent +;;@cindex file-lock +;;The @dfn{file-lock} procedures implement a transaction method for file +;;replacement compatible with the methods used by the GNU @dfn{emacs} +;;text editor on Unix systems and the Microsoft @dfn{Word} editor. +;;@cindex emacs +;; +;;@noindent +;;@cindex certificate +;;Both protocols employ what I term a @dfn{certificate} containing the +;;user, hostname, time, and (on Unix) process-id. +;;Intent to replace @var{file} is indicated by adding to @var{file}'s +;;directory a certificate object whose name is derived from +;;@var{file}. +;; +;;@noindent +;;The Microsoft Word certificate is contained in a 162 byte file named +;;for the visited @var{file} with a @samp{~$} prefix. +;;Emacs/Unix creates a symbolic link to a certificate named for the +;;visited @var{file} prefixed with @samp{.#}. +;;Because Unix systems can import Microsoft file systems, these +;;routines maintain and check both Emacs and Word certificates. + +;;Returns a string naming the path of the emacs-style file-lock symbolic +;;link associated with @1. +(define (emacs-lock:path path) + (let* ((dir (pathname->vicinity path)) + (file (substring path (string-length dir) (string-length path)))) + (in-vicinity dir (string-append ".#" file)))) + +;;Returns a string naming the path of the ms-word style lock file +;;associated with @1. +(define (word-lock:path path) + (let* ((dir (pathname->vicinity path)) + (file (substring path (string-length dir) (string-length path))) + (filen (string-length file))) + (in-vicinity + dir (string-append + "~$" (substring file (min 2 (max 0 (- filen 10))) filen))))) + +(define (word-lock:certificate lockpath) + (define iport (open-file lockpath "rb")) + (and + iport + (call-with-open-ports + (lambda (iport) + (define len (read-byte iport)) + (define pos 1) + (and (number? len) + (let ((name (make-string len))) + (define (discard cnt) + (do ((cnt (+ -1 cnt) (+ -1 cnt))) + ((or (eof-object? (peek-char iport)) (negative? cnt)) + (negative? cnt)) + (or (eof-object? (read-byte iport)) (set! pos (+ 1 pos))))) + (define (read-field) + (define len (read-byte iport)) + (set! pos (+ 1 pos)) + (or (eof-object? (read-byte iport)) (set! pos (+ 1 pos))) + (and (number? len) + (let ((str (make-string len))) + (do ((idx 0 (+ 1 idx))) + ((or (eof-object? (peek-char iport)) (>= idx len)) + (and (>= idx len) str)) + (string-set! str idx (read-char iport)) + (or (eof-object? (read-char iport)) (set! pos (+ 2 pos))))))) +;;; read compact name + (do ((idx 0 (+ 1 idx))) + ((or (eof-object? (peek-char iport)) (>= idx len))) + (string-set! name idx (read-char iport)) + (set! pos (+ 1 pos))) +;;; read expanded names (interleaved with nul) + (let* ((name2 (and (discard (- 54 pos)) (read-field))) + (company (and (discard 6) (read-field))) + (name3 (and (discard 8) (read-field)))) + (define (check field fieldname) + (cond ((not field) (slib:warn 'missing fieldname)) + ((equal? name field)) + (else (slib:warn fieldname 'mismatch name field)))) + (check name2 'name2) + (check name3 'name3) + (or (and (eof-object? (peek-char iport)) (= pos 162)) + (and (not (and (discard (- 162 pos)) + (eof-object? (peek-char iport)))) + (slib:error lockpath 'length pos '(not = 162)))) + (and name company (sprintf #f "%s@%s" name company)))))) + iport))) + +(define (emacs-lock:certificate lockpath) + (define conflict + (system->line (sprintf #f "ls -ld %#a 2>/dev/null" lockpath))) + (cond ((and conflict (substring? "-> " conflict)) + => (lambda (idx) + (substring conflict (+ 3 idx) (string-length conflict)))) + (conflict (slib:error 'bad 'emacs 'lock lockpath conflict)) + (else #f))) + +(define (file-lock:certificate path) + (or (case (software-type) + ((UNIX COHERENT PLAN9) + (emacs-lock:certificate (emacs-lock:path path))) + (else #f)) + (word-lock:certificate (word-lock:path path)))) + +;;@body +;;Returns the string @samp{@var{user}@@@var{hostname}} associated with +;;the lock owner of file @1 if locked; and #f otherwise. +(define (file-lock-owner path) + (or (emacs-lock:certificate (emacs-lock:path path)) + (word-lock:certificate (word-lock:path path)))) + +(define (word:lock! path email) + (define lockpath (word-lock:path path)) + (define at (substring? "@" email)) + (let ((user (substring email 0 at)) + (hostname (substring email (+ 1 at) (string-length email))) + (oport (open-file lockpath "wb"))) + (define userlen (string-length user)) + (and oport (call-with-open-ports + oport (lambda (oport) + (define pos 1) + (define (nulls cnt) + (display (make-bytes cnt 0) oport) + (set! pos (+ cnt pos))) + (define (write-field field) + (define len (string-length field)) + (write-byte len oport) + (write-byte 0 oport) + (set! pos (+ 2 pos)) + (do ((idx 0 (+ 1 idx))) + ((>= idx len)) + (write-char (string-ref field idx) oport) + (write-byte 0 oport) + (set! pos (+ 2 pos)))) + (write-byte userlen oport) + (display user oport) (set! pos (+ userlen pos)) +;;; write expanded names (interleaved with nul) + (nulls (- 54 pos)) + (write-field user) + (nulls 6) + (write-field hostname) + (nulls 8) + (write-field user) + (nulls (- 162 pos)) + (and (not (eqv? 162 pos)) + (slib:error lockpath 'length pos '(not = 162))) + (let ((certificate (word-lock:certificate lockpath))) + (and (equal? email certificate) email))))))) + +(define (emacs:lock! path email) + (define lockpath (emacs-lock:path path)) + (define certificate (sprintf #f "%s.%s:%d" + email + (or (system->line "echo $PPID") "") + (current-time))) + (and (eqv? 0 (system (sprintf #f "ln -s %#a %#a" certificate lockpath))) + (let ((e-cert (emacs-lock:certificate lockpath))) + (and (equal? certificate e-cert) + certificate)))) + +;;@args path email +;;@args path +;; +;;@1 must be a string naming the file to be locked. If supplied, @2 +;;must be a string formatted as @samp{@var{user}@@@var{hostname}}. If +;;absent, @2 defaults to the value returned by @code{user-email-address}. +;; +;;If @1 is already locked, then @0 returns @samp{#f}. If @1 is +;;unlocked, then @0 returns the certificate string associated with the +;;new lock for file @1. +(define (file-lock! path . email) + (set! email (if (null? email) (user-email-address) (car email))) + (and (string? email) + (not (file-lock:certificate path)) + (let ((wl (word:lock! path email))) + (case (software-type) + ((UNIX COHERENT PLAN9) + ;; file-system may not support symbolic links. + (or (emacs:lock! path email) wl)) + (else wl))))) + +;;@body +;;@1 must be a string naming the file to be unlocked. @2 must be the +;;string returned by @code{file-lock!} for @1. +;; +;;If @1 is locked with @2, then @0 removes the locks and returns +;;@samp{#t}. Otherwise, @0 leaves the file system unaltered and returns +;;@samp{#f}. +(define (file-unlock! path certificate) + (define w-path (word-lock:path path)) + (let ((w-cert (word-lock:certificate w-path))) + (cond ((not w-cert) #f) + ((not certificate) #f) + ((equal? w-cert certificate) ; my word certificate + (delete-file w-path)) + ((not (eqv? 0 (substring? w-cert certificate))) + ;; word certificate doesn't match emacs certificate + (slib:warn 'file-unlock! w-path 'mismatch certificate) #f) + (else + (let ((e-path (emacs-lock:path path))) + (define e-cert (emacs-lock:certificate e-path)) + (case (software-type) + ((UNIX COHERENT PLAN9) + (cond ((not (equal? e-cert certificate)) + (slib:warn 'file-unlock! e-path 'mismatch certificate) + #f) + (else (and (delete-file e-path) + (delete-file w-path))))) + (else (delete-file w-path)))))))) + +;;;@subsubheading File Transactions + +(define (emacs:backup-number path) + (let* ((dir (pathname->vicinity path)) + (file (substring path (string-length dir) (string-length path))) + (largest #f)) + (require 'directory) + (if (equal? "" dir) (set! dir "./")) + (directory-for-each + (lambda (str) + (define left.~ (substring? ".~" str)) + (cond ((not left.~)) + ((not (equal? file (substring str 0 left.~)))) + ((string->number (substring str + (+ 2 left.~) + (string-reverse-index str #\~))) + => (lambda (number) + (set! largest (max number (or largest number))))))) + dir (string-append file "*~*[0-9]~")) + largest)) + +;;@body +;;@1 must be a string. @2 must be a symbol. Depending on @2, @0 +;;returns: +;;@table @r +;;@item none +;;#f +;;@item simple +;;the string "@1~" +;;@item numbered +;;the string "@1.~@var{n}~", where @var{n} is one greater than the +;;highest number appearing in a filename matching "@1.~*~". @var{n} +;;defauls to 1 when no filename matches. +;;@item existing +;;the string "@1.~@var{n}~" if a numbered backup already exists in +;;this directory; otherwise. "@1~" +;;@item orig +;;the string "@1.orig" +;;@item bak +;;the string "@1.bak" +;;@end table +(define (emacs:backup-name path backup-style) + (define (numbered bn) (sprintf #f "%s.~%d~" path (+ 1 (or bn 0)))) + (define (simple) (string-append path "~")) + (case backup-style + ((none #f) #f) + ((simple) (simple)) + ((numbered) (numbered (emacs:backup-number path))) + ((existing) (let ((bn (emacs:backup-number path))) + (if bn (numbered bn) (simple)))) + ((orig bak) (sprintf #f "%s.%s" path backup-style)) + (else + (slib:error 'emacs:backup-name 'unknown 'backup-style backup-style)))) + +;;@args proc path backup-style certificate +;;@args proc path backup-style +;;@args proc path +;; +;;@2 must be a string naming an existing file. @3 is one of the +;;symbols @r{none}, @r{simple}, @r{numbered}, @r{existing}, @r{orig}, +;;@r{bak} or @r{#f}; with meanings described above; or a string naming +;;the location of a backup file. @3 defaults to @r{#f}. If supplied, +;;@4 is the certificate with which @2 is locked. +;; +;;@1 must be a procedure taking two string arguments: +;;@itemize @bullet +;;@item +;;@2, the original filename (to be read); and +;;@item +;;a temporary file-name. +;;@end itemize +;; +;;If @2 is locked by other than @4, or if @4 is supplied and @2 is not +;;locked, then @0 returns #f. If @4 is not supplied, then, @0 creates +;;temporary (Emacs and Word) locks for @2 during the transaction. The +;;lock status of @2 will be restored before @0 returns. +;; +;;@0 calls @1 with @2 (which should not be modified) and a temporary +;;file path to be written. +;;If @1 returns any value other than @r{#t}, then the file named by @2 +;;is not altered and @0 returns @r{#f}. +;;Otherwise, @code{emacs:backup-name} is called with @2 and @3. If it +;;returns a string, then @2 is renamed to it. +;; +;;Finally, the temporary file is renamed @2. +;;@0 returns #t if @2 was successfully replaced; and #f otherwise. +(define (transact-file-replacement proc path . args) + (define certificate (case (length args) + ((2) (cadr args)) + ((1 0) #f) + (else (slib:error 'transact-file-replacement + (+ 2 (length args)) 'args)))) + (define backup-style (if (null? args) #f (car args))) + (define move (case (software-type) + ((UNIX COHERENT PLAN9) "mv -f") + ((MS-DOS WINDOWS OS/2 ATARIST) "MOVE /Y") + (else (slib:error (software-type) 'move?)))) + (define (move? tmpfn path) + (eqv? 0 (system (sprintf #f "%s %#a %#a" move tmpfn path)))) + (let* ((dir (pathname->vicinity path)) + (file (substring path (string-length dir) (string-length path))) + (tmpfn (in-vicinity dir (string-append "#" file "#")))) + (cond ((not (file-exists? path)) (slib:warn 'file path 'missing) #f) + (else + (let ((f-cert (file-lock:certificate path))) + (cond ((and f-cert (not (equal? certificate f-cert))) + (slib:warn 'file path 'locked 'by f-cert) #f) + ((and (file-exists? tmpfn) + (slib:warn 'file tmpfn 'exists) + (not (delete-file tmpfn))) + #f) + ((or certificate (file-lock! path)) + => (lambda (cert) + (define result (proc path tmpfn)) + (cond + ((not (eqv? #t result)) + (delete-file tmpfn) + (or f-cert (file-unlock! path cert)) #f) + (else + (let ((bakf + (if (symbol? backup-style) + (emacs:backup-name path backup-style) + backup-style))) + (cond + ((and bakf (not (move? path bakf))) + (or f-cert (file-unlock! path cert)) #f) + ((not (move? tmpfn path)) + (or f-cert (file-unlock! path cert)) #f) + (else + (or f-cert (file-unlock! path cert)) #t))))))) + (else (slib:warn 'could 'not 'lock path) #f))))))) + +(define (windows:user-email-address user hostname) + (define compname (getenv "COMPUTERNAME")) ;without domain + (define workgroup #f) + (define netdir + (or (getenv "windir") + (getenv "winbootdir") + (and (getenv "SYSTEMROOT") + (string-append (getenv "SYSTEMROOT") "\\system32")) + "C:\\windows")) + (call-with-tmpnam + (lambda (tmp) + (define (net . cmd) + (zero? (system (apply string-append + (or netdir "") + (if netdir "\\" "") + "NET " cmd)))) + (and (zero? (system (string-append + (or netdir "") + (if netdir "\\" "") + "IPCONFIG /ALL > " tmp " "))) + (file-exists? tmp) ;(print tmp '=) (display-file tmp) + (call-with-input-file tmp + (lambda (port) + (find-string-from-port? "Host Name" port) + (fscanf port " %*[. ]: %s" hostname))) + (delete-file tmp)) + (and (net "START /LIST >" tmp) + (file-exists? tmp) + (not (eof-object? (call-with-input-file tmp read-char))) + (cond ((call-with-input-file tmp + (lambda (port) + (find-string-from-port? "o network servic" port))) + (and (net "CONFIG /YES >" tmp) (net "STOP /YES"))) + (else (net "CONFIG /YES >" tmp))) + (call-with-input-file tmp + (lambda (port) + (do ((line (read-line port) (read-line port))) + ((eof-object? line)) + (sscanf line " Workstation root directory %s" netdir) + (sscanf line " Computer name \\\\%s" compname) + (sscanf line " Workstation Domain %s" workgroup) + (sscanf line " Workgroup %s" workgroup) + (sscanf line " User name %s" user))))))) + + (and netdir (not (and user hostname)) + (set! netdir (string-append netdir "\\system.ini")) + (file-exists? netdir) + (call-with-input-file netdir + (lambda (port) (and (find-string-from-port? "[DNS]" port) + (read-line port) ;past newline + (do ((line (read-line port) (read-line port))) + ((not (and (string? line) + (string-index line #\=)))) + (sscanf line "HostName=%s" compname) + (sscanf line "DomainName=%s" workgroup))))) + (not user) + (call-with-input-file netdir + (lambda (port) (and (find-string-from-port? "[Network]" port) + (read-line port) ;past newline + (do ((line (read-line port) (read-line port))) + ((not (and (string? line) + (string-index line #\=)))) + (sscanf line "UserName=%s" user)))))) + + (string-append (or user "John_Doe") "@" + (if (and compname (not hostname)) + (string-append compname "." (or workgroup "localnet")) + (or hostname "localhost")))) + +;;@subsubheading Identification + +;;@args +;;@0 returns a string of the form @samp{username@r{@@}hostname}. If +;;this e-mail address cannot be obtained, #f is returned. +(define (user-email-address) + (define user (or (getenv "USER") (getenv "USERNAME"))) + (define hostname (getenv "HOSTNAME")) ;with domain + (cond ((and user hostname) (string-append user "@" hostname)) + (else (case (software-type) + ;;((AMIGA) ) + ;;((MACOS THINKC) ) + ((MS-DOS WINDOWS OS/2 ATARIST) + (windows:user-email-address user hostname)) + ;;((NOSVE) ) + ;;((VMS) ) + ((UNIX COHERENT PLAN9) + (call-with-tmpnam + (lambda (tmp) + (if (not user) (set! user (system->line "whoami" tmp))) + (if (not hostname) (set! hostname (system->line "hostname" tmp))) + (if (not user) (set! user "John_Doe")) + (if (not hostname) (set! hostname "localhost")))) + (string-append user "@" hostname)))))) diff --git a/transact.txi b/transact.txi new file mode 100644 index 0000000..5e3ff8f --- /dev/null +++ b/transact.txi @@ -0,0 +1,150 @@ +@subsubheading File Locking + +@noindent +Unix file-locking is focussed on write permissions for segments of a +existing file. While this might be employed for (binary) database +access, it is not used for everyday contention (between users) for +text files. + +@noindent +Microsoft has several file-locking protocols. Their model denies +write access to a file if any reader has it open. This is too +restrictive. Write access is denied even when the reader has +reached end-of-file. And tracking read access (which is much more +common than write access) causes havoc when remote hosts crash or +disconnect. + +@noindent +It is bizarre that the concept of multi-user contention for +modifying files has not been adequately addressed by either of the +large operating system development efforts. There is further irony +that both camps support contention detection and resolution only +through weak conventions of some their document editing programs. + +@noindent +@cindex file-lock +The @dfn{file-lock} procedures implement a transaction method for file +@cindex file-lock +replacement compatible with the methods used by the GNU @dfn{emacs} +@cindex emacs +text editor on Unix systems and the Microsoft @dfn{Word} editor. +@cindex Word +@cindex emacs + +@noindent +@cindex certificate +Both protocols employ what I term a @dfn{certificate} containing the +@cindex certificate +user, hostname, time, and (on Unix) process-id. +Intent to replace @var{file} is indicated by adding to @var{file}'s +directory a certificate object whose name is derived from +@var{file}. + +@noindent +The Microsoft Word certificate is contained in a 162 byte file named +for the visited @var{file} with a @samp{~$} prefix. +Emacs/Unix creates a symbolic link to a certificate named for the +visited @var{file} prefixed with @samp{.#}. +Because Unix systems can import Microsoft file systems, these +routines maintain and check both Emacs and Word certificates. + + +@defun file-lock-owner path + +Returns the string @samp{@var{user}@@@var{hostname}} associated with +the lock owner of file @var{path} if locked; and #f otherwise. +@end defun + +@deffn {Procedure} file-lock! path email + + +@deffnx {Procedure} file-lock! path + +@var{path} must be a string naming the file to be locked. If supplied, @var{email} +must be a string formatted as @samp{@var{user}@@@var{hostname}}. If +absent, @var{email} defaults to the value returned by @code{user-email-address}. + +If @var{path} is already locked, then @code{file-lock!} returns @samp{#f}. If @var{path} is +unlocked, then @code{file-lock!} returns the certificate string associated with the +new lock for file @var{path}. +@end deffn + +@deffn {Procedure} file-unlock! path certificate + +@var{path} must be a string naming the file to be unlocked. @var{certificate} must be the +string returned by @code{file-lock!} for @var{path}. + +If @var{path} is locked with @var{certificate}, then @code{file-unlock!} removes the locks and returns +@samp{#t}. Otherwise, @code{file-unlock!} leaves the file system unaltered and returns +@samp{#f}. +@end deffn +@subsubheading File Transactions + + +@defun emacs:backup-name path backup-style + +@var{path} must be a string. @var{backup-style} must be a symbol. Depending on @var{backup-style}, @code{emacs:backup-name} +returns: +@table @r +@item none +#f +@item simple +the string "@var{path}~" +@item numbered +the string "@var{path}.~@var{n}~", where @var{n} is one greater than the +highest number appearing in a filename matching "@var{path}.~*~". @var{n} +defauls to 1 when no filename matches. +@item existing +the string "@var{path}.~@var{n}~" if a numbered backup already exists in +this directory; otherwise. "@var{path}~" +@item orig +the string "@var{path}.orig" +@item bak +the string "@var{path}.bak" +@end table +@end defun + +@defun transact-file-replacement proc path backup-style certificate + + +@defunx transact-file-replacement proc path backup-style + +@defunx transact-file-replacement proc path + +@var{path} must be a string naming an existing file. @var{backup-style} is one of the +symbols @r{none}, @r{simple}, @r{numbered}, @r{existing}, @r{orig}, +@r{bak} or @r{#f}; with meanings described above; or a string naming +the location of a backup file. @var{backup-style} defaults to @r{#f}. If supplied, +@var{certificate} is the certificate with which @var{path} is locked. + +@var{proc} must be a procedure taking two string arguments: +@itemize @bullet +@item +@var{path}, the original filename (to be read); and +@item +a temporary file-name. +@end itemize + +If @var{path} is locked by other than @var{certificate}, or if @var{certificate} is supplied and @var{path} is not +locked, then @code{transact-file-replacement} returns #f. If @var{certificate} is not supplied, then, @code{transact-file-replacement} creates +temporary (Emacs and Word) locks for @var{path} during the transaction. The +lock status of @var{path} will be restored before @code{transact-file-replacement} returns. + +@code{transact-file-replacement} calls @var{proc} with @var{path} (which should not be modified) and a temporary +file path to be written. +If @var{proc} returns any value other than @r{#t}, then the file named by @var{path} +is not altered and @code{transact-file-replacement} returns @r{#f}. +Otherwise, @code{emacs:backup-name} is called with @var{path} and @var{backup-style}. If it +returns a string, then @var{path} is renamed to it. + +Finally, the temporary file is renamed @var{path}. +@code{transact-file-replacement} returns #t if @var{path} was successfully replaced; and #f otherwise. +@end defun +@subsubheading Identification + + +@defun user-email-address + +@code{user-email-address} returns a string of the form @samp{username@r{@@}hostname}. If +this e-mail address cannot be obtained, #f is returned. +@end defun @@ -5,15 +5,39 @@ ;; Deep copy of the tree -- new one has all new pairs. (Called ;; tree-copy in Dybvig.) -(define (tree:copy-tree tree) - (if (pair? tree) - (cons (tree:copy-tree (car tree)) - (tree:copy-tree (cdr tree))) - tree)) + +;;@code{(require 'tree)} +;;@ftindex tree +;; +;;These are operations that treat lists a representations of trees. ;; Substitute occurrences of old equal? to new in tree. ;; Similar to tree walks in SICP without the internal define. -(define (tree:subst new old tree . equ?) + +;; substq and substv aren't in CL. (Names from Dybvig) + +;;@args new old tree +;;@args new old tree equ? +;;@code{subst} makes a copy of @3, substituting @1 for +;;every subtree or leaf of @3 which is @code{equal?} to @2 +;;and returns a modified tree. The original @3 is unchanged, but +;;may share parts with the result. +;; +;;@code{substq} and @code{substv} are similar, but test against @2 +;;using @code{eq?} and @code{eqv?} respectively. If @code{subst} is +;;called with a fourth argument, @var{equ?} is the equality predicate. +;; +;;Examples: +;;@lisp +;;(substq 'tempest 'hurricane '(shakespeare wrote (the hurricane))) +;; @result{} (shakespeare wrote (the tempest)) +;;(substq 'foo '() '(shakespeare wrote (twelfth night))) +;; @result{} (shakespeare wrote (twelfth night . foo) . foo) +;;(subst '(a . cons) '(old . pair) +;; '((old . spice) ((old . shoes) old . pair) (old . pair))) +;; @result{} ((old . spice) ((old . shoes) a . cons) (a . cons)) +;;@end lisp +(define (subst new old tree . equ?) (set! equ? (if (null? equ?) equal? (car equ?))) (letrec ((walk (lambda (tree) (cond ((equ? old tree) new) @@ -22,16 +46,29 @@ (walk (cdr tree)))) (else tree))))) (walk tree))) - -;; The next 2 aren't in CL. (Names from Dybvig) - -(define (tree:substq new old tree) +(define (substq new old tree) (tree:subst new old tree eq?)) - -(define (tree:substv new old tree) +(define (substv new old tree) (tree:subst new old tree eqv?)) -(define copy-tree tree:copy-tree) -(define subst tree:subst) -(define substq tree:substq) -(define substv tree:substv) +;;@body +;;Makes a copy of the nested list structure @1 using new pairs and +;;returns it. All levels are copied, so that none of the pairs in the +;;tree are @code{eq?} to the original ones -- only the leaves are. +;; +;;Example: +;;@lisp +;;(define bar '(bar)) +;;(copy-tree (list bar 'foo)) +;; @result{} ((bar) foo) +;;(eq? bar (car (copy-tree (list bar 'foo)))) +;; @result{} #f +;;@end lisp +(define (copy-tree tree) + (if (pair? tree) + (cons (tree:copy-tree (car tree)) + (tree:copy-tree (cdr tree))) + tree)) + +(define tree:copy-tree copy-tree) +(define tree:subst subst) diff --git a/tree.txi b/tree.txi new file mode 100644 index 0000000..3164ae5 --- /dev/null +++ b/tree.txi @@ -0,0 +1,48 @@ +@code{(require 'tree)} +@ftindex tree + +These are operations that treat lists a representations of trees. + + +@defun subst new old tree +@defunx substq new old tree +@defunx substv new old tree + + +@defunx subst new old tree equ? +@code{subst} makes a copy of @var{tree}, substituting @var{new} for +every subtree or leaf of @var{tree} which is @code{equal?} to @var{old} +and returns a modified tree. The original @var{tree} is unchanged, but +may share parts with the result. + +@code{substq} and @code{substv} are similar, but test against @var{old} +using @code{eq?} and @code{eqv?} respectively. If @code{subst} is +called with a fourth argument, @var{equ?} is the equality predicate. + +Examples: +@lisp +(substq 'tempest 'hurricane '(shakespeare wrote (the hurricane))) + @result{} (shakespeare wrote (the tempest)) +(substq 'foo '() '(shakespeare wrote (twelfth night))) + @result{} (shakespeare wrote (twelfth night . foo) . foo) +(subst '(a . cons) '(old . pair) + '((old . spice) ((old . shoes) old . pair) (old . pair))) + @result{} ((old . spice) ((old . shoes) a . cons) (a . cons)) +@end lisp +@end defun + +@defun copy-tree tree + +Makes a copy of the nested list structure @var{tree} using new pairs and +returns it. All levels are copied, so that none of the pairs in the +tree are @code{eq?} to the original ones -- only the leaves are. + +Example: +@lisp +(define bar '(bar)) +(copy-tree (list bar 'foo)) + @result{} ((bar) foo) +(eq? bar (car (copy-tree (list bar 'foo)))) + @result{} #f +@end lisp +@end defun diff --git a/trnscrpt.scm b/trnscrpt.scm index 3f2c8a1..aaec7cb 100644 --- a/trnscrpt.scm +++ b/trnscrpt.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,15 +18,15 @@ ;each case. (define transcript:port #f) - +;@ (define (transcript-on filename) (set! transcript:port (open-output-file filename))) - +;@ (define (transcript-off) (if (output-port? transcript:port) (close-output-port transcript:port)) (set! transcript:port #f)) - +;@ (define read-char (let ((read-char read-char) (write-char write-char)) (lambda opt @@ -35,7 +35,7 @@ ((output-port? transcript:port) (write-char ans transcript:port))) ans)))) - +;@ (define read (let ((read read) (write write) (newline newline)) (lambda opt @@ -46,28 +46,28 @@ (if (eqv? #\newline (apply peek-char opt)) (newline transcript:port)))) ans)))) - +;@ (define write-char (let ((write-char write-char)) (lambda (obj . opt) (apply write-char obj opt) (if (output-port? transcript:port) (write-char obj transcript:port))))) - +;@ (define write (let ((write write)) (lambda (obj . opt) (apply write obj opt) (if (output-port? transcript:port) (write obj transcript:port))))) - +;@ (define display (let ((display display)) (lambda (obj . opt) (apply display obj opt) (if (output-port? transcript:port) (display obj transcript:port))))) - +;@ (define newline (let ((newline newline)) (lambda opt @@ -1,7 +1,6 @@ ;;; "tsort.scm" Topological sort ;;; Copyright (C) 1995 Mikael Djurfeldt -; -; This code is in the public domain. +;;; This code is in the public domain. ;;; The algorithm is inspired by Cormen, Leiserson and Rivest (1990) ;;; "Introduction to Algorithms", chapter 23 @@ -9,7 +8,57 @@ (require 'hash-table) (require 'primes) -(define (topological-sort dag pred) +;;@code{(require 'topological-sort)} or @code{(require 'tsort)} +;;@ftindex topological-sort +;;@ftindex tsort + +;;@noindent +;;The algorithm is inspired by Cormen, Leiserson and Rivest (1990) +;;@cite{Introduction to Algorithms}, chapter 23. + +;;@body +;;@defunx topological-sort dag pred +;;where +;;@table @var +;;@item dag +;;is a list of sublists. The car of each sublist is a vertex. The cdr is +;;the adjacency list of that vertex, i.e. a list of all vertices to which +;;there exists an edge from the car vertex. +;;@item pred +;;is one of @code{eq?}, @code{eqv?}, @code{equal?}, @code{=}, +;;@code{char=?}, @code{char-ci=?}, @code{string=?}, or @code{string-ci=?}. +;;@end table +;; +;;Sort the directed acyclic graph @1 so that for every edge from +;;vertex @var{u} to @var{v}, @var{u} will come before @var{v} in the +;;resulting list of vertices. +;; +;;Time complexity: O (|V| + |E|) +;; +;;Example (from Cormen): +;;@quotation +;;Prof. Bumstead topologically sorts his clothing when getting +;;dressed. The first argument to @0 describes which +;;garments he needs to put on before others. (For example, +;;Prof Bumstead needs to put on his shirt before he puts on his +;;tie or his belt.) @0 gives the correct order of dressing: +;;@end quotation +;; +;;@example +;;(require 'tsort) +;;@ftindex tsort +;;(tsort '((shirt tie belt) +;; (tie jacket) +;; (belt jacket) +;; (watch) +;; (pants shoes belt) +;; (undershorts pants shoes) +;; (socks shoes)) +;; eq?) +;;@result{} +;;(socks undershorts pants shoes watch shirt belt tie jacket) +;;@end example +(define (tsort dag pred) (if (null? dag) '() (let* ((adj-table (make-hash-table @@ -42,5 +91,4 @@ (visit (car def) (cdr def))))) (cdr dag))) sorted))) - -(define tsort topological-sort) +(define topological-sort tsort) diff --git a/tsort.txi b/tsort.txi new file mode 100644 index 0000000..559c092 --- /dev/null +++ b/tsort.txi @@ -0,0 +1,53 @@ +@code{(require 'topological-sort)} or @code{(require 'tsort)} +@ftindex topological-sort +@ftindex tsort + +@noindent +The algorithm is inspired by Cormen, Leiserson and Rivest (1990) +@cite{Introduction to Algorithms}, chapter 23. + + +@defun tsort dag pred + +@defunx topological-sort dag pred +where +@table @var +@item dag +is a list of sublists. The car of each sublist is a vertex. The cdr is +the adjacency list of that vertex, i.e. a list of all vertices to which +there exists an edge from the car vertex. +@item pred +is one of @code{eq?}, @code{eqv?}, @code{equal?}, @code{=}, +@code{char=?}, @code{char-ci=?}, @code{string=?}, or @code{string-ci=?}. +@end table + +Sort the directed acyclic graph @var{dag} so that for every edge from +vertex @var{u} to @var{v}, @var{u} will come before @var{v} in the +resulting list of vertices. + +Time complexity: O (|V| + |E|) + +Example (from Cormen): +@quotation +Prof. Bumstead topologically sorts his clothing when getting +dressed. The first argument to @code{tsort} describes which +garments he needs to put on before others. (For example, +Prof Bumstead needs to put on his shirt before he puts on his +tie or his belt.) @code{tsort} gives the correct order of dressing: +@end quotation + +@example +(require 'tsort) +@ftindex tsort +(tsort '((shirt tie belt) + (tie jacket) + (belt jacket) + (watch) + (pants shoes belt) + (undershorts pants shoes) + (socks shoes)) + eq?) +@result{} +(socks undershorts pants shoes watch shirt belt tie jacket) +@end example +@end defun @@ -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,7 @@ (let ((hibyte (read-byte port))) (do ((idx 3 (+ -1 idx)) (val (if (> hibyte 127) (+ #x-100 hibyte) hibyte) - (+ (ash val 8) (read-byte port)))) + (+ (* val 256) (read-byte port)))) ((zero? idx) val)))) (define (tzfile:read-longs len port) (define ra (make-vector len 0)) @@ -34,68 +34,68 @@ (define (tzfile:read-bool port) (let ((c (read-char port))) (if (eof-object? c) c (if (zero? (char->integer c)) #f #t)))) - +;@ (define (tzfile:read path) (define null (integer->char 0)) - (call-with-input-file path - (lambda (port) - (do ((idx 0 (+ 1 idx))) ;reserved. - ((>= idx 20)) - (read-char port)) - (let* ((ttisgmtcnt (tzfile:read-long port)) - (ttisstdcnt (tzfile:read-long port)) - (leapcnt (tzfile:read-long port)) - (timecnt (tzfile:read-long port)) - (typecnt (tzfile:read-long port)) - (charcnt (tzfile:read-long port)) - (transition-times (tzfile:read-longs timecnt port)) - (transition-types - (do ((ra (make-vector timecnt 0)) - (idx 0 (+ 1 idx))) - ((>= idx timecnt) ra) - (vector-set! ra idx (read-byte port)))) - ;;(printf " typecnt = %d\n" typecnt) - (mode-table (do ((tt (make-vector typecnt #f)) - (idx 0 (+ 1 idx))) - ((>= idx typecnt) tt) - (let* ((gmt-offset (tzfile:read-long port)) - (isdst (tzfile:read-bool port)) - (abbrev-index (read-byte port))) - (vector-set! tt idx - (vector abbrev-index gmt-offset - isdst #f #f))))) - ;;(printf " %d bytes of abbreviations:\n" charcnt) - (abbrevs (do ((ra (make-bytes charcnt 0)) - (idx 0 (+ 1 idx))) - ((>= idx charcnt) ra) - (string-set! ra idx (read-char port)))) - (leap-seconds (tzfile:read-longs (* 2 leapcnt) port))) - (cond ((not (or (eqv? 0 ttisstdcnt) (eqv? typecnt ttisstdcnt))) - (slib:warn 'tzfile:read "format error" ttisstdcnt typecnt))) - (cond ((not (or (eqv? 0 ttisgmtcnt) (eqv? typecnt ttisgmtcnt))) - (slib:warn 'tzfile:read "format error" ttisgmtcnt typecnt))) - ;;(printf " reading %d transition attributes\n" ttisstdcnt) - (do ((idx 0 (+ 1 idx))) - ((>= idx ttisstdcnt)) - (vector-set! (vector-ref mode-table idx) 3 (tzfile:read-bool port))) - ;;(printf " reading %d transition attributes\n" ttisgmtcnt) - (do ((idx 0 (+ 1 idx))) - ((>= idx ttisgmtcnt)) - (vector-set! (vector-ref mode-table idx) 4 (tzfile:read-bool port))) - (cond ((not (eof-object? (peek-char port))) - (slib:warn 'tzfile:read "bytes left at end"))) - (do ((idx 0 (+ 1 idx))) - ((>= idx ttisstdcnt)) - (let ((rec (vector-ref mode-table idx))) - (vector-set! - rec 0 (let loop ((pos (vector-ref rec 0))) - (cond ((>= pos (string-length abbrevs)) - (slib:warn 'tzfile:read "format error" abbrevs) #f) - ((char=? null (string-ref abbrevs pos)) - (substring abbrevs (vector-ref rec 0) pos)) - (else (loop (+ 1 pos)))))))) - (list path mode-table leap-seconds transition-times transition-types) - )))) + (call-with-open-ports + (open-file path 'rb) + (lambda (port) + (do ((idx 0 (+ 1 idx))) ;reserved. + ((>= idx 20)) + (read-char port)) + (let* ((ttisgmtcnt (tzfile:read-long port)) + (ttisstdcnt (tzfile:read-long port)) + (leapcnt (tzfile:read-long port)) + (timecnt (tzfile:read-long port)) + (typecnt (tzfile:read-long port)) + (charcnt (tzfile:read-long port)) + (transition-times (tzfile:read-longs timecnt port)) + (transition-types + (do ((ra (make-vector timecnt 0)) + (idx 0 (+ 1 idx))) + ((>= idx timecnt) ra) + (vector-set! ra idx (read-byte port)))) + ;;(printf " typecnt = %d\\n" typecnt) + (mode-table (do ((tt (make-vector typecnt #f)) + (idx 0 (+ 1 idx))) + ((>= idx typecnt) tt) + (let* ((gmt-offset (tzfile:read-long port)) + (isdst (tzfile:read-bool port)) + (abbrev-index (read-byte port))) + (vector-set! tt idx + (vector abbrev-index gmt-offset + isdst #f #f))))) + ;;(printf " %d bytes of abbreviations:\\n" charcnt) + (abbrevs (do ((ra (make-bytes charcnt 0)) + (idx 0 (+ 1 idx))) + ((>= idx charcnt) ra) + (string-set! ra idx (read-char port)))) + (leap-seconds (tzfile:read-longs (* 2 leapcnt) port))) + (cond ((not (or (eqv? 0 ttisstdcnt) (eqv? typecnt ttisstdcnt))) + (slib:warn 'tzfile:read "format error" ttisstdcnt typecnt))) + (cond ((not (or (eqv? 0 ttisgmtcnt) (eqv? typecnt ttisgmtcnt))) + (slib:warn 'tzfile:read "format error" ttisgmtcnt typecnt))) + ;;(printf " reading %d transition attributes\\n" ttisstdcnt) + (do ((idx 0 (+ 1 idx))) + ((>= idx ttisstdcnt)) + (vector-set! (vector-ref mode-table idx) 3 (tzfile:read-bool port))) + ;;(printf " reading %d transition attributes\\n" ttisgmtcnt) + (do ((idx 0 (+ 1 idx))) + ((>= idx ttisgmtcnt)) + (vector-set! (vector-ref mode-table idx) 4 (tzfile:read-bool port))) + (cond ((not (eof-object? (peek-char port))) + (slib:warn 'tzfile:read "bytes left at end"))) + (do ((idx 0 (+ 1 idx))) + ((>= idx ttisstdcnt)) + (let ((rec (vector-ref mode-table idx))) + (vector-set! + rec 0 (let loop ((pos (vector-ref rec 0))) + (cond ((>= pos (string-length abbrevs)) + (slib:warn 'tzfile:read "format error" abbrevs) #f) + ((char=? null (string-ref abbrevs pos)) + (substring abbrevs (vector-ref rec 0) pos)) + (else (loop (+ 1 pos)))))))) + (list path mode-table leap-seconds transition-times transition-types))))) (define (tzfile:transition-index time zone) (and zone @@ -103,8 +103,8 @@ (lambda (path mode-table leap-seconds transition-times transition-types) (let ((ntrns (vector-length transition-times))) (if (zero? ntrns) -1 - (let loop ((lidx (ash (+ 1 ntrns) -1)) - (jmp (ash (+ 1 ntrns) -2))) + (let loop ((lidx (quotient (+ 1 ntrns) 2)) + (jmp (quotient (+ 1 ntrns) 4))) (let* ((idx (max 0 (min lidx (+ -1 ntrns)))) (idx-time (vector-ref transition-times idx))) (cond ((<= jmp 0) @@ -113,8 +113,8 @@ ((and (zero? idx) (< time idx-time)) -1) ((and (not (= idx lidx)) (not (< time idx-time))) idx) (else - (loop ((if (< time idx-time) - +) idx jmp) - (if (= 1 jmp) 0 (ash (+ 1 jmp) -1)))))))))) + (loop ((if (< time idx-time) - +) idx jmp) + (if (= 1 jmp) 0 (quotient (+ 1 jmp) 2)))))))))) (cdr (vector->list zone))))) (define (tzfile:get-std-spec mode-table) @@ -124,7 +124,7 @@ (if (>= type-idx (vector-length mode-table)) (vector-ref mode-table 0) (vector-ref mode-table type-idx))))) - +;@ (define (tzfile:get-zone-spec time zone) (apply (lambda (path mode-table leap-seconds transition-times transition-types) diff --git a/umbscheme.init b/umbscheme.init index 87c1638..605878c 100644 --- a/umbscheme.init +++ b/umbscheme.init @@ -9,30 +9,25 @@ ;;; (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) 'umb-scheme) ;;; (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) "ftp://ftp.cs.umb.edu:/pub/scheme/") ;;; (scheme-implementation-version) should return a string describing ;;; the version the scheme implementation loading this file. - (define (scheme-implementation-version) "3.2") ;;; (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/lib/umb-scheme/") @@ -41,7 +36,6 @@ ;;; (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 @@ -59,20 +53,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) "") ;;; *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 @@ -92,7 +84,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 @@ -164,6 +156,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 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))) @@ -215,7 +238,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) @@ -253,17 +276,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) (slib:load (in-vicinity (library-vicinity) "require")) @@ -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,13 @@ ;promotional, or sales literature without prior written consent in ;each case. -(require 'coerce) +(require 'scanf) (require 'printf) +(require 'coerce) (require 'string-case) (require 'string-search) (require 'common-list-functions) +(require-if 'compiling 'directory) ; path->uri uses current-directory ;;@code{(require 'uri)} ;;@ftindex uri @@ -67,10 +69,12 @@ (cond ((string? path) (uric:encode path "/$,;:@&=+")) ((null? path) "") ((list? path) (uri:make-path path)) - (else path)) + (else (or path ""))) (if query (sprintf #f "?%s" (uric:encode query "?/$,;:@&=+")) "") (if fragment (sprintf #f "#%s" (uric:encode fragment "?/$,;:@&=+")) "")))) +;;@body +;;Returns a URI string combining the components of list @1. (define (uri:make-path path) (apply string-append (uric:encode (car path) "$,;:@&=+") @@ -108,12 +112,23 @@ (define (html:isindex prompt) (sprintf #f "<ISINDEX PROMPT=\"%s\">" prompt)) -;;@body Returns a list of 5 elements corresponding to the parts +(define (uri:scheme? str) + (let ((lst (scanf-read-list "%[-+.a-zA-Z0-9] %s" str))) + (and (list? lst) + (eqv? 1 (length lst)) + (char-alphabetic? (string-ref str 0))))) + +;;@args uri-reference base-tree +;;@args uri-reference +;; +;;Returns a list of 5 elements corresponding to the parts ;;(@var{scheme} @var{authority} @var{path} @var{query} @var{fragment}) ;;of string @1. Elements corresponding to absent parts are #f. ;; ;;The @var{path} is a list of strings. If the first string is empty, -;;then the path is absolute; otherwise relative. +;;then the path is absolute; otherwise relative. The optional @2 is a +;;tree as returned by @0; and is used as the base address for relative +;;URIs. ;; ;;If the @var{authority} component is a ;;@dfn{Server-based Naming Authority}, then it is a list of the @@ -133,9 +148,11 @@ (lambda (scheme authority path query fragment) (define uri-empty? (and (equal? "" path) (not scheme) (not authority) (not query))) - (list (if scheme + (list (if (and scheme (uri:scheme? scheme)) (string-ci->symbol scheme) - b-scheme) + (cond ((not scheme) b-scheme) + (else (slib:warn 'uri->tree 'bad 'scheme scheme) + b-scheme))) (if authority (uri:decode-authority authority) b-authority) @@ -150,7 +167,7 @@ (or (and fragment (uric:decode fragment)) (and uri-empty? b-fragment)))) split)) - (if (or (car split) (null? base-tree) (car split)) + (if (or (car split) (null? base-tree)) '(#f #f #f #f #f) (car base-tree)))) @@ -197,7 +214,9 @@ (if (or userinfo port) (list userinfo host (or (string->number port) port)) host))) - +;;@args txt chr +;;Returns a list of @1 split at each occurrence of @2. @2 does not +;;appear in the returned list of strings. (define uri:split-fields (let ((cr (integer->char #xd))) (lambda (txt chr) @@ -212,7 +231,7 @@ chr)) (list txt))))) -;; @body Converts a @dfn{URI} encoded @1 to a query-alist. +;;@body Converts a @dfn{URI} encoded @1 to a query-alist. (define (uri:decode-query query-string) (set! query-string (string-subst query-string " " "" "+" " ")) (do ((lst '()) @@ -311,9 +330,109 @@ (else uri))) (sub uri-component)) +;;@body @1 is a path-list as returned by @code{uri:split-fields}. @0 +;;returns a list of items returned by @code{uri:decode-path}, coerced +;;to types @2. (define (uri:path->keys path-list ptypes) (and (not (null? path-list)) (not (equal? '("") path-list)) (let ((path (uri:decode-path (map uric:decode path-list) #f))) (and (= (length path) (length ptypes)) (map coerce path ptypes))))) + +;;@subheading File-system Locators and Predicates + +;;@body Returns a URI-string for @1 on the local host. +(define (path->uri path) + (require 'directory) + (if (absolute-path? path) + (sprintf #f "file:%s" path) + (sprintf #f "file:%s/%s" (current-directory) path))) + +;;@body Returns #t if @1 is an absolute-URI as indicated by a +;;syntactically valid (per RFC 2396) @dfn{scheme}; otherwise returns +;;#f. +(define (absolute-uri? str) + (let ((lst (scanf-read-list "%[-+.a-zA-Z0-9]:%s" str))) + (and (list? lst) + (eqv? 2 (length lst)) + (char-alphabetic? (string-ref str 0))))) + +;;@body Returns #t if @1 is a fully specified pathname (does not +;;depend on the current working directory); otherwise returns #f. +(define (absolute-path? file-name) + (and (string? file-name) + (positive? (string-length file-name)) + (memv (string-ref file-name 0) '(#\\ #\/)))) + +;;@body Returns #t if changing directory to @1 would leave the current +;;directory unchanged; otherwise returns #f. +(define (null-directory? str) + (member str '("" "." "./" ".\\"))) + +;;@body Returns #t if the string @1 contains characters used for +;;specifying glob patterns, namely @samp{*}, @samp{?}, or @samp{[}. +(define (glob-pattern? str) + (let loop ((idx (+ -1 (string-length str)))) + (if (negative? idx) + #f + (case (string-ref str idx) + ((#\* #\[ #\?) #t) + (else (loop (+ -1 idx))))))) + +;;@noindent +;;Before RFC 2396, the @dfn{File Transfer Protocol} (FTP) served a +;;similar purpose. + +;;@body +;;Returns a list of the decoded FTP @1; or #f if indecipherable. FTP +;;@dfn{Uniform Resource Locator}, @dfn{ange-ftp}, and @dfn{getit} +;;formats are handled. The returned list has four elements which are +;;strings or #f: +;; +;;@enumerate 0 +;;@item +;;username +;;@item +;;password +;;@item +;;remote-site +;;@item +;;remote-directory +;;@end enumerate +(define (parse-ftp-address uri) + (let ((length? (lambda (len lst) (and (eqv? len (length lst)) lst)))) + (cond + ((not uri) #f) + ((length? 1 (scanf-read-list " ftp://%s %s" uri)) + => (lambda (host) + (let ((login #f) (path #f) (dross #f)) + (sscanf (car host) "%[^/]/%[^@]%s" login path dross) + (and login + (append (cond + ((length? 2 (scanf-read-list "%[^@]@%[^@]%s" login)) + => (lambda (userpass@hostport) + (append + (cond ((length? 2 (scanf-read-list + "%[^:]:%[^@/]%s" + (car userpass@hostport)))) + (else (list (car userpass@hostport) #f))) + (cdr userpass@hostport)))) + (else (list "anonymous" #f login))) + (list path)))))) + (else + (let ((user@site #f) (colon #f) (path #f) (dross #f)) + (case (sscanf uri " %[^:]%[:]%[^@] %s" user@site colon path dross) + ((2 3) + (let ((user #f) (site #f)) + (cond ((or (eqv? 2 (sscanf user@site "/%[^@/]@%[^@]%s" + user site dross)) + (eqv? 2 (sscanf user@site "%[^@/]@%[^@]%s" + user site dross))) + (list user #f site path)) + ((eqv? 1 (sscanf user@site "@%[^@]%s" site dross)) + (list #f #f site path)) + (else (list #f #f user@site path))))) + (else + (let ((site (scanf-read-list " %[^@/] %s" uri))) + (and (length? 1 site) (list #f #f (car site) #f)))))))))) @@ -22,6 +22,11 @@ described in RFC 2396. Returns a Uniform Resource Identifier string from component arguments. @end defun +@defun uri:make-path path + +Returns a URI string combining the components of list @var{path}. +@end defun + @defun html:anchor name Returns a string which defines this location in the (HTML) file as @var{name}. The hypertext @samp{<A HREF="#@var{name}">} will link to this point. @@ -54,13 +59,19 @@ Returns a string specifying the search @var{prompt} of a document, for inclusion in the HEAD of the document (@pxref{HTML, head}). @end defun -@defun uri->tree uri-reference base-tree @dots{} +@defun uri->tree uri-reference base-tree + + +@defunx uri->tree uri-reference + Returns a list of 5 elements corresponding to the parts (@var{scheme} @var{authority} @var{path} @var{query} @var{fragment}) of string @var{uri-reference}. Elements corresponding to absent parts are #f. The @var{path} is a list of strings. If the first string is empty, -then the path is absolute; otherwise relative. +then the path is absolute; otherwise relative. The optional @var{base-tree} is a +tree as returned by @code{uri->tree}; and is used as the base address for relative +URIs. If the @var{authority} component is a @dfn{Server-based Naming Authority}, then it is a list of the @@ -76,6 +87,17 @@ string. @end example @end defun +@defun uri:split-fields txt chr + +Returns a list of @var{txt} split at each occurrence of @var{chr}. @var{chr} does not +appear in the returned list of strings. +@end defun + +@defun uri:decode-query query-string +Converts a @dfn{URI} encoded @var{query-string} to a query-alist. +@cindex URI +@end defun + @noindent @code{uric:} prefixes indicate procedures dealing with URI-components. @@ -93,3 +115,64 @@ Returns a copy of the string @var{uri-component} in which each @samp{%} escaped characters in @var{uri-component} is replaced with the character it encodes. This routine is useful for showing URI contents on error pages. @end defun + +@defun uri:path->keys path-list ptypes +@var{path-list} is a path-list as returned by @code{uri:split-fields}. @code{uri:path->keys} +returns a list of items returned by @code{uri:decode-path}, coerced +to types @var{ptypes}. +@end defun +@subheading File-system Locators and Predicates + + +@defun path->uri path +Returns a URI-string for @var{path} on the local host. +@end defun + +@defun absolute-uri? str +Returns #t if @var{str} is an absolute-URI as indicated by a +syntactically valid (per RFC 2396) @dfn{scheme}; otherwise returns +@cindex scheme +#f. +@end defun + +@defun absolute-path? file-name +Returns #t if @var{file-name} is a fully specified pathname (does not +depend on the current working directory); otherwise returns #f. +@end defun + +@defun null-directory? str +Returns #t if changing directory to @var{str} would leave the current +directory unchanged; otherwise returns #f. +@end defun + +@defun glob-pattern? str +Returns #t if the string @var{str} contains characters used for +specifying glob patterns, namely @samp{*}, @samp{?}, or @samp{[}. +@end defun +@noindent +Before RFC 2396, the @dfn{File Transfer Protocol} (FTP) served a +@cindex File Transfer Protocol +similar purpose. + + +@defun parse-ftp-address uri + +Returns a list of the decoded FTP @var{uri}; or #f if indecipherable. FTP +@dfn{Uniform Resource Locator}, @dfn{ange-ftp}, and @dfn{getit} +@cindex Uniform Resource Locator +@cindex ange-ftp +@cindex getit +formats are handled. The returned list has four elements which are +strings or #f: + +@enumerate 0 +@item +username +@item +password +@item +remote-site +@item +remote-directory +@end enumerate +@end defun @@ -8,7 +8,7 @@ (define values:*values-rtd* (make-record-type "values" '(values))) - +;@ (define values (let ((make-values (record-constructor values:*values-rtd*))) (lambda x @@ -16,7 +16,7 @@ (null? (cdr x))) (car x) (make-values x))))) - +;@ (define call-with-values (let ((access-values (record-accessor values:*values-rtd* 'values)) (values-predicate? (record-predicate values:*values-rtd*))) diff --git a/version.txi b/version.txi index 0341eab..647e5b6 100644 --- a/version.txi +++ b/version.txi @@ -1,2 +1,2 @@ -@set SLIBVERSION 2d2 -@set SLIBDATE July 2001 +@set SLIBVERSION 3a1 +@set SLIBDATE November 2003 @@ -0,0 +1,218 @@ +;"vet.scm" Check exports, references, and documentation of library modules. +;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. + +;;@code{(require 'vet)} +;;@ftindex vet + +(require 'common-list-functions) +(require 'top-refs) +(require 'manifest) + +(define r4rs-symbols + '(* + - -> / < <= = => > >= ... abs acos and angle append apply asin + assoc assq assv atan begin boolean? caaaar caaadr caaar caadar caaddr + caadr caar cadaar cadadr cadar caddar cadddr caddr cadr + call-with-current-continuation call-with-input-file + call-with-output-file car case cdaaar cdaadr cdaar cdadar cdaddr cdadr + cdar cddaar cddadr cddar cdddar cddddr cdddr cddr cdr ceiling + char->integer char-alphabetic? char-ci<=? char-ci<? char-ci=? + char-ci>=? char-ci>? char-downcase char-lower-case? char-numeric? + char-ready? char-upcase char-upper-case? char-whitespace? char<=? + char<? char=? char>=? char>? char? close-input-port + close-output-port complex? cond cons cos current-input-port + current-output-port define denominator display do else eof-object? + eq? equal? eqv? even? exact->inexact exact? exp expt floor + for-each force gcd if imag-part implementation-vicinity in-vicinity + inexact->exact inexact? input-port? integer->char integer? lambda + lcm length let let* letrec library-vicinity list list->string + list->vector list-ref list-tail list? load log magnitude make-polar + make-rectangular make-string make-vector make-vicinity map max member + memq memv min modulo negative? newline not null? number->string + number? numerator odd? open-input-file open-output-file or + output-port? pair? peek-char positive? procedure? quasiquote + quotient rational? rationalize read read-char real-part real? + remainder reverse round set! set-car! set-cdr! sin sqrt string + string->list string->number string->symbol string-append string-ci<=? + string-ci<? string-ci=? string-ci>=? string-ci>? string-copy + string-fill! string-length string-ref string-set! string<=? + string<? string=? string>=? string>? string? sub-vicinity + substring symbol->string symbol? tan transcript-off transcript-on + truncate unquote unquote-splicing user-vicinity vector vector->list + vector-fill! vector-length vector-ref vector-set! vector? + with-input-from-file with-output-to-file write write-char zero? )) + +(define (path<-entry entry) + (define (findit path) + (cond ((not (string? path)) #f) + ((file-exists? path) path) + ((file-exists? (string-append path ".scm")) + (string-append path ".scm")) + (else #f))) + (cond ((string? (cdr entry)) (findit (cdr entry))) + ((not (pair? (cdr entry))) #f) + (else (case (cadr entry) + ((source defmacro macro syntactic-closures + syntax-case macros-that-work) + (let ((lp (last-pair entry))) + (or (and (string? (car lp)) (findit (car lp))) + (and (string? (cdr lp)) (findit (cdr lp)))))) + (else #f))))) + +(define slib:catalog (cdr (member (assq 'null *catalog*) *catalog*))) + +(define (top-refs<-files filenames) + (remove-duplicates (apply append (map top-refs<-file filenames)))) + +(define (provided+? . features) + (lambda (feature) + (or (memq feature features) (provided? feature)))) + +(define (requires<-file filename) + (file->requires filename (provided+? 'compiling) slib:catalog)) + +(define (requires<-files filenames) + (remove-duplicates (apply append (map requires<-file filenames)))) + +(define (definitions<-files filenames) + (remove-duplicates (apply append (map file->definitions filenames)))) + +(define (exports<-files filenames) + (remove-duplicates (apply append (map file->exports filenames)))) + +(define (code-walk-justify lst . margins) + (define left-margin (case (length margins) + ((1 2 3) (car margins)) + ((0) 0) + (else (slib:error 'code-walk-justify 'wna margins)))) + (define right-margin (case (length margins) + ((2 3) (cadr margins)) + (else (output-port-width)))) + (define spacer (case (length margins) + ((3) (caddr margins)) + (else #\ ))) + (cond ((>= left-margin right-margin) + (slib:error 'code-walk-justify + " left margin must be smaller than right: " + margins))) + (let ((cur left-margin) + (lms (make-string left-margin #\ ))) + (display lms) + (for-each + (lambda (obj) + (if (symbol? obj) (set! obj (symbol->string obj))) + (let ((objl (string-length obj))) + (cond ((= left-margin cur) + (display obj) + (set! cur (+ objl cur))) + ((<= right-margin (+ 1 objl cur)) + (newline) + (set! cur (+ objl left-margin)) + (display lms) (display obj)) + (else + (display #\ ) + (display obj) + (set! cur (+ 1 objl cur)))))) + lst))) + +;;@body +;;Using the procedures in the @code{top-refs} and @code{manifest} +;;modules, @0 analyzes each SLIB module, reporting about any +;;procedure or macro defined whether it is: +;; +;;@table @asis +;; +;;@item orphaned +;;defined, not called, not exported; +;;@item missing +;;called, not defined, and not exported by its @code{require}d modules; +;;@item undocumented-export +;;Exported by module, but no index entry in @file{slib.info}; +;; +;;@end table +;; +;;And for the library as a whole: +;; +;;@table @asis +;; +;;@item documented-unexport +;;Index entry in @file{slib.info}, but no module exports it. +;; +;;@end table +;; +;;This straightforward analysis caught three full days worth of +;;never-executed branches, transitive require assumptions, spelling +;;errors, undocumented procedures, missing procedures, and cyclic +;;dependencies in SLIB. +(define (vet-slib) + (define infos + (exports<-info-index (in-vicinity (library-vicinity) "slib.info") 1 2)) + (define r4rs+slib #f) + (define export-alist '()) + (define all-exports '()) + (define slib-exports + (union '(system getenv current-time difftime offset-time) + (union (file->exports + (in-vicinity (library-vicinity) "Template.scm")) + (file->exports + (in-vicinity (library-vicinity) "require.scm"))))) + (define (show lst name) + (cond ((not (null? lst)) + (display " ") (display name) (display ":") (newline) + (code-walk-justify lst 10) + (newline)))) + (define (dopath path) + (define paths (cons path (file->loads path))) + (let ((requires (requires<-files paths)) + (defines (definitions<-files paths)) + (exports (exports<-files paths)) + (top-refs (top-refs<-files paths))) + (define orphans (set-difference (set-difference defines exports) + top-refs)) + (define missings (set-difference + (set-difference top-refs defines) + r4rs+slib)) + (set! all-exports (union exports all-exports)) + (for-each (lambda (req) + (define pr (assq req export-alist)) + (and pr (set! missings (set-difference missings (cdr pr))))) + requires) + (let ((undocs (set-difference exports (union r4rs-symbols infos)))) + (cond ((not (every null? (list undocs orphans missings))) + (write paths) (newline) + ;;(show requires 'requires) + ;;(show defines 'defines) + ;;(show exports 'exports) + (show undocs 'undocumented-exports) + (show orphans 'orphans) + (show missings 'missing) + ))))) + (set! r4rs+slib (union r4rs-symbols slib-exports)) + (for-each (lambda (entry) + (set! export-alist + (cons (cons (car entry) + (feature->exports (car entry) slib:catalog)) + export-alist))) + slib:catalog) + (for-each (lambda (entry) + (define path (path<-entry entry)) + (and path (dopath path))) + slib:catalog) + (write '("SLIB")) + (show (set-difference infos (union r4rs+slib all-exports)) + 'documented-unexports)) @@ -0,0 +1,35 @@ +@code{(require 'vet)} +@ftindex vet + + +@defun vet-slib + +Using the procedures in the @code{top-refs} and @code{manifest} +modules, @code{vet-slib} analyzes each SLIB module, reporting about any +procedure or macro defined whether it is: + +@table @asis + +@item orphaned +defined, not called, not exported; +@item missing +called, not defined, and not exported by its @code{require}d modules; +@item undocumented-export +Exported by module, but no index entry in @file{slib.info}; + +@end table + +And for the library as a whole: + +@table @asis + +@item documented-unexport +Index entry in @file{slib.info}, but no module exports it. + +@end table + +This straightforward analysis caught three full days worth of +never-executed branches, transitive require assumptions, spelling +errors, undocumented procedures, missing procedures, and cyclic +dependencies in SLIB. +@end defun @@ -36,30 +36,25 @@ ;;; (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) 'Vscm) ;;; (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.princeton.edu/~blume/vscm/vscm.html") ;;; (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 ;;; the directory where any auxillary files to your Scheme ;;; implementation reside. - (define (implementation-vicinity) (case (software-type) ((UNIX) "/usr/local/src/scheme/") @@ -68,7 +63,6 @@ ;;; (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") @@ -83,14 +77,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 @@ -100,7 +98,7 @@ ;; Scheme report features -; rev5-report ;conforms to +; r5rs ;conforms to ; eval ;R5RS 2-argument eval values ;R5RS multiple values ; dynamic-wind ;R5RS dynamic-wind @@ -114,11 +112,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!, @@ -129,7 +127,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 @@ -191,7 +189,6 @@ ;;; CALL-WITH-INPUT-STRING and CALL-WITH-OUTPUT-STRING are the string ;;; port versions of CALL-WITH-*PUT-FILE. - (define (call-with-output-string proc) (let ((outsp (open-output-string))) (proc outsp) @@ -203,6 +200,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) (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'"))) + ;;; Implementation of string ports using generic ports (define (open-input-string s) @@ -339,7 +367,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 . argl) @@ -357,7 +385,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+) @@ -382,17 +409,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 (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 load) ;;; 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/withfile.scm b/withfile.scm index 43e9300..f9e7226 100644 --- a/withfile.scm +++ b/withfile.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. ; @@ -21,10 +21,10 @@ (define withfile:current-input (current-input-port)) (define withfile:current-output (current-output-port)) - +;@ (define (current-input-port) withfile:current-input) (define (current-output-port) withfile:current-output) - +;@ (define (with-input-from-file file thunk) (define oport withfile:current-input) (define port (open-input-file file)) @@ -32,50 +32,50 @@ (set! withfile:current-input port)) (lambda() (let ((ans (thunk))) (close-input-port port) ans)) (lambda() (set! withfile:current-input oport)))) - -(define (with-output-from-file file thunk) +;@ +(define (with-output-to-file file thunk) (define oport withfile:current-output) (define port (open-output-file file)) (dynamic-wind (lambda() (set! oport withfile:current-output) (set! withfile:current-output port)) (lambda() (let ((ans (thunk))) (close-output-port port) ans)) (lambda() (set! withfile:current-output oport)))) - +;@ (define peek-char (let ((peek-char peek-char)) (lambda opt (peek-char (if (null? opt) withfile:current-input (car opt)))))) - +;@ (define read-char (let ((read-char read-char)) (lambda opt (read-char (if (null? opt) withfile:current-input (car opt)))))) - +;@ (define read (let ((read read)) (lambda opt (read (if (null? opt) withfile:current-input (car opt)))))) - +;@ (define write-char (let ((write-char write-char)) (lambda (obj . opt) (write-char obj (if (null? opt) withfile:current-output (car opt)))))) - +;@ (define write (let ((write write)) (lambda (obj . opt) (write obj (if (null? opt) withfile:current-output (car opt)))))) - +;@ (define display (let ((display display)) (lambda (obj . opt) (display obj (if (null? opt) withfile:current-output (car opt)))))) - +;@ (define newline (let ((newline newline)) (lambda opt (newline (if (null? opt) withfile:current-output (car opt)))))) - +;@ (define force-output (let ((force-output force-output)) (lambda opt @@ -22,7 +22,7 @@ ;;; software shall duly acknowledge such use, in accordance with the ;;; usual standards of acknowledging credit in academic research. ;;; -;;; 4. MIT has made no warrantee or representation that the operation +;;; 4. MIT has made no warranty or representation that the operation ;;; of this software will be error-free, and MIT is under no ;;; obligation to provide any services, by way of maintenance, update, ;;; or otherwise. @@ -29,7 +29,7 @@ ;;; software shall duly acknowledge such use, in accordance with the ;;; usual standards of acknowledging credit in academic research. ;;; -;;; 4. MIT has made no warrantee or representation that the operation +;;; 4. MIT has made no warranty or representation that the operation ;;; of this software will be error-free, and MIT is under no ;;; obligation to provide any services, by way of maintenance, update, ;;; or otherwise. @@ -84,11 +84,11 @@ ;;; ONLY these procedures (and TEST at the end of the file) will be ;;; (re)defined in your system. ;;; - +;@ (define make-wt-tree-type #f) (define number-wt-type #f) (define string-wt-type #f) - +;@ (define make-wt-tree #f) (define singleton-wt-tree #f) (define alist->wt-tree #f) @@ -4,91 +4,23 @@ ;;; This code is in the public domain. (require 'object) +(require 'object->string) +;; (define yasos:make-instance 'bogus) (define yasos:instance? object?) -;; Removed (define yasos:make-instance 'bogus) ;; -;; Removed (define-syntax YASOS:INSTANCE-DISPATCHER ;; alias so compiler can inline for speed -;; (syntax-rules () ((yasos:instance-dispatcher inst) (cdr inst)))) -;; DEFINE-OPERATION - -(define-syntax define-operation - (syntax-rules () - ((define-operation (<name> <inst> <arg> ...) <exp1> <exp2> ...) - ;;=> - (define <name> (make-generic-method - (lambda (<inst> <arg> ...) <exp1> <exp2> ...)))) - - ((define-operation (<name> <inst> <arg> ...) ) ;; no body - ;;=> - (define-operation (<name> <inst> <arg> ...) - (slib:error "Operation not handled" - '<name> - (format #f (if (yasos:instance? <inst>) "#<INSTANCE>" "~s") - <inst>)))))) - -;; DEFINE-PREDICATE -(define-syntax define-predicate - (syntax-rules () - ((define-predicate <name>) - ;;=> - (define <name> (make-generic-predicate))))) - -;; OBJECT - -(define-syntax object - (syntax-rules () - ((object ((<name> <self> <arg> ...) <exp1> <exp2> ...) ...) - ;;=> - (let ((self (make-object))) - (make-method! self <name> (lambda (<self> <arg> ...) <exp1> <exp2> ...)) - ... - self)))) - -;; OBJECT with MULTIPLE INHERITANCE {First Found Rule} - -(define-syntax object-with-ancestors - (syntax-rules () - ((object-with-ancestors ( (<ancestor1> <init1>) ... ) - ((<name> <self> <arg> ...) <exp1> <exp2> ...) ...) - ;;=> - (let* ((<ancestor1> <init1>) - ... - (self (make-object <ancestor1> ...))) - (make-method! self <name> (lambda (<self> <arg> ...) <exp1> <exp2> ...)) - ... - self)))) - -;; OPERATE-AS {a.k.a. send-to-super} - -; used in operations/methods - -(define-syntax operate-as - (syntax-rules () - ((operate-as <component> <op> <composit> <arg> ...) ;; What is <composit> ??? - ;;=> - ((get-method <component> <op>) <composit> <arg> ...)))) - - - -;; SET & SETTER - - -(define-syntax set - (syntax-rules () - ((set (<access> <index> ...) <newval>) - ((yasos:setter <access>) <index> ... <newval>) - ) - ((set <var> <newval>) - (set! <var> <newval>) - ) -) ) - - -(define yasos:add-setter 'bogus) -(define yasos:remove-setter-for 'bogus) - -(define yasos:setter +(define (pormat dest arg) + (define obj (if (yasos:instance? arg) "#<INSTANCE>" arg)) + (cond ((eqv? dest #t) (display obj)) + (dest (display obj dest)) + ((yasos:instance? arg) obj) + (else (object->string arg)))) + +;@ +(define add-setter 'bogus) +(define remove-setter-for 'bogus) +;@ +(define setter (let ( (known-setters (list (cons car set-car!) (cons cdr set-cdr!) (cons vector-ref vector-set!) @@ -97,15 +29,15 @@ (added-setters '()) ) - (set! yasos:add-setter + (set! add-setter (lambda (getter setter) (set! added-setters (cons (cons getter setter) added-setters))) ) - (set! yasos:remove-setter-for + (set! remove-setter-for (lambda (getter) (cond ((null? added-setters) - (slib:error "REMOVE-SETTER-FOR: Unknown getter" getter) + (slib:error 'remove-setter-for 'unknown-getter getter) ) ((eq? getter (caar added-setters)) (set! added-setters (cdr added-setters)) @@ -113,7 +45,7 @@ (else (let loop ((x added-setters) (y (cdr added-setters))) (cond - ((null? y) (slib:error "REMOVE-SETTER-FOR: Unknown getter" + ((null? y) (slib:error 'remove-setter-for 'unknown-getter getter)) ((eq? getter (caar y)) (set-cdr! x (cdr y))) (else (loop (cdr x) (cdr y))) @@ -129,8 +61,6 @@ self) ) ) - - (define (yasos:make-access-operation <name>) (letrec ( (setter-dispatch (lambda (inst . args) @@ -149,7 +79,7 @@ (get-method inst self)) => (lambda (method) (apply method (cons inst args))) ) - (else (slib:error "Operation not handled" <name> inst)) + (else (slib:error 'operation-not-handled <name> inst)) ) ) ) ) @@ -157,47 +87,124 @@ self ) ) -(define-syntax define-access-operation +;;--------------------- +;; general operations +;;--------------------- + +;;; if an instance does not have a PRINT operation.. + +;;(define-operation (yasos:print obj port) (pormat port obj) ) +;@ +(define print + (make-generic-method + (lambda (obj!2 port!2) + (pormat port!2 obj!2)))) + +;;; default behavior + +;;(define-operation (yasos:size obj) +;; (cond ((vector? obj) (vector-length obj)) +;; ((list? obj) (length obj)) +;; ((pair? obj) 2) +;; ((string? obj) (string-length obj)) +;; ((char? obj) 1) +;; (else (slib:error "Operation not supported: size" obj)))) +;@ +(define size + (make-generic-method + (lambda (obj!2) + (cond ((vector? obj!2) (vector-length obj!2)) + ((list? obj!2) (length obj!2)) + ((pair? obj!2) 2) + ((string? obj!2) (string-length obj!2)) + ((char? obj!2) 1) + (else (slib:error 'size "Operation not supported" obj!2)))))) + +;;; internal aliases: +;;(define yasos:size size) +(define yasos:setter setter) + +;; (define-syntax YASOS:INSTANCE-DISPATCHER +;; ;; alias so compiler can inline for speed +;; (syntax-rules () ((yasos:instance-dispatcher inst) (cdr inst)))) + +;; DEFINE-OPERATION +;@ +(define-syntax define-operation (syntax-rules () - ((define-access-operation <name>) - ;=> - (define <name> (yasos:make-access-operation '<name>)) -) ) ) + ((define-operation (<name> <inst> <arg> ...) <exp1> <exp2> ...) + ;;=> + (define <name> (make-generic-method + (lambda (<inst> <arg> ...) <exp1> <exp2> ...)))) + ((define-operation (<name> <inst> <arg> ...) ) ;; no body + ;;=> + (define-operation (<name> <inst> <arg> ...) + (slib:error 'operation-not-handled + '<name> + (if (yasos:instance? <inst>) "#<INSTANCE>" <inst>)))))) +;; DEFINE-PREDICATE +;@ +(define-syntax define-predicate + (syntax-rules () + ((define-predicate <name>) + ;;=> + (define <name> (make-generic-predicate))))) -;;--------------------- -;; general operations -;;--------------------- +;; OBJECT +;@ +(define-syntax object + (syntax-rules () + ((object ((<name> <self> <arg> ...) <exp1> <exp2> ...) ...) + ;;=> + (let ((self (make-object))) + (make-method! self <name> (lambda (<self> <arg> ...) <exp1> <exp2> ...)) + ... + self)))) -(define-operation (yasos:print obj port) - (format port - ;; if an instance does not have a PRINT operation.. - (if (yasos:instance? obj) "#<INSTANCE>" "~s") - obj -) ) +;; OBJECT with MULTIPLE INHERITANCE {First Found Rule} +;@ +(define-syntax object-with-ancestors + (syntax-rules () + ((object-with-ancestors ( (<ancestor1> <init1>) ... ) + ((<name> <self> <arg> ...) <exp1> <exp2> ...) ...) + ;;=> + (let* ((<ancestor1> <init1>) + ... + (self (make-object <ancestor1> ...))) + (make-method! self <name> (lambda (<self> <arg> ...) <exp1> <exp2> ...)) + ... + self)))) -(define-operation (yasos:size obj) - ;; default behavior - (cond - ((vector? obj) (vector-length obj)) - ((list? obj) (length obj)) - ((pair? obj) 2) - ((string? obj) (string-length obj)) - ((char? obj) 1) - (else - (slib:error "Operation not supported: size" obj)) -) ) +;; OPERATE-AS {a.k.a. send-to-super} + +; used in operations/methods +;@ +(define-syntax operate-as + (syntax-rules () + ((operate-as <component> <op> <composit> <arg> ...) ;; What is <composit> ??? + ;;=> + ((get-method <component> <op>) <composit> <arg> ...)))) -(require 'format) -;;; exports: -(define print yasos:print) ; print also in debug.scm -(define size yasos:size) -(define add-setter yasos:add-setter) -(define remove-setter-for yasos:remove-setter-for) -(define setter yasos:setter) +;; SET & SETTER -(provide 'oop) ;in case we were loaded this way. -(provide 'yasos) +;@ +(define-syntax set + (syntax-rules () + ((set (<access> <index> ...) <newval>) + ((yasos:setter <access>) <index> ... <newval>) + ) + ((set <var> <newval>) + (set! <var> <newval>) + ) +) ) +;@ +(define-syntax define-access-operation + (syntax-rules () + ((define-access-operation <name>) + ;=> + (define <name> (yasos:make-access-operation '<name>)) +) ) ) |