aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorSteve Langasek <vorlon@debian.org>2005-01-10 08:53:33 +0000
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:30 -0800
commite33f9eb9cf5cc29c36ce2aa7e10cd0f37ae0cc8e (patch)
treeabbf06041619e445f9d0b772b0d58132009d8234
parentf559c149c83da84d0b1c285f0298c84aec564af9 (diff)
parent8466d8cfa486fb30d1755c4261b781135083787b (diff)
downloadslib-e33f9eb9cf5cc29c36ce2aa7e10cd0f37ae0cc8e.zip
slib-e33f9eb9cf5cc29c36ce2aa7e10cd0f37ae0cc8e.tar.gz
Import Debian changes 3a1-4.2debian/3a1-4.2
slib (3a1-4.2) unstable; urgency=low * Non-maintainer upload. * Add guile.init.local for use within the build dir, since otherwise we have an (earlier unnoticed) circular build-dep due to a difference between scm and guile. slib (3a1-4.1) unstable; urgency=low * Non-maintainer upload. * Build-depend on guile-1.6 instead of scm, since the new version of scm is wedged in unstable (closes: #281809). slib (3a1-4) unstable; urgency=low * Also check for expected creation on slibcat. (Closes: #240096) slib (3a1-3) unstable; urgency=low * Also check for /usr/share/guile/1.6/slib before installing for guile 1.6. (Closes: #239267) slib (3a1-2) unstable; urgency=low * Add format.scm back into slib until gnucash stops using it. * Call guile-1.6 new-catalog (Closes: #238231) slib (3a1-1) unstable; urgency=low * New upstream release * Remove Info section from doc-base file (Closes: #186950) * Remove period from end of description (linda, lintian) * html gen fixed upstream (Closes: #111778) slib (2d4-2) unstable; urgency=low * Fix url for upstream source (Closes: #144981) * Fix typo in slib.texi (enquque->enqueue) (Closes: #147475) * Add build depends. slib (2d4-1) unstable; urgency=low * New upstream. slib (2d3-1) unstable; urgency=low * New upstream. * Remove texi2html call in debian/rules. Now done upstream. Add make html instead. * Changes to rules and doc-base to conform to upstream html gen * Clean up upstream makefile to make sure it cleans up after itself.
-rw-r--r--.slibcat164
-rw-r--r--ANNOUNCE136
-rw-r--r--Bev2slib.scm2
-rw-r--r--COPYING2
-rw-r--r--ChangeLog2079
-rw-r--r--DrScheme.init61
-rw-r--r--FAQ23
-rw-r--r--Makefile312
-rw-r--r--README88
-rw-r--r--RScheme.init50
-rw-r--r--STk.init63
-rw-r--r--Template.scm146
-rw-r--r--alist.scm55
-rw-r--r--alist.txi70
-rw-r--r--alistab.scm33
-rw-r--r--array.scm186
-rw-r--r--array.txi136
-rw-r--r--arraymap.scm83
-rw-r--r--arraymap.txi68
-rw-r--r--batch.scm145
-rw-r--r--bigloo.init82
-rw-r--r--break.scm29
-rw-r--r--byte.scm214
-rw-r--r--byte.txi179
-rw-r--r--bytenumb.scm346
-rw-r--r--bytenumb.txi181
-rw-r--r--chap.scm47
-rw-r--r--chap.txi46
-rw-r--r--charplot.scm380
-rw-r--r--chez.init75
-rw-r--r--cie1931.xyz82
-rw-r--r--cie1964.xyz82
-rw-r--r--cltime.scm10
-rw-r--r--coerce.scm2
-rw-r--r--collect.scm105
-rw-r--r--collectx.scm247
-rw-r--r--color.scm674
-rw-r--r--color.txi345
-rw-r--r--colornam.scm117
-rw-r--r--colornam.txi75
-rw-r--r--colorspc.scm536
-rw-r--r--comlist.scm317
-rw-r--r--comparse.scm76
-rw-r--r--comparse.txi81
-rw-r--r--crc.scm137
-rw-r--r--cring.scm30
-rw-r--r--cvs.scm140
-rw-r--r--cvs.txi32
-rw-r--r--daylight.scm356
-rw-r--r--daylight.txi117
-rw-r--r--db2html.scm77
-rw-r--r--db2html.txi13
-rw-r--r--dbcom.scm215
-rw-r--r--dbinterp.scm34
-rw-r--r--dbrowse.scm14
-rw-r--r--dbsyn.scm54
-rw-r--r--dbutil.scm674
-rw-r--r--dbutil.txi219
-rw-r--r--debian/changelog76
-rw-r--r--debian/control5
-rw-r--r--debian/copyright7
-rw-r--r--debian/doc-base9
-rw-r--r--debian/postinst10
-rwxr-xr-xdebian/rules8
-rw-r--r--debug.scm6
-rw-r--r--defmacex.scm4
-rw-r--r--determ.scm157
-rw-r--r--determ.txi47
-rw-r--r--differ.scm521
-rw-r--r--differ.txi90
-rw-r--r--dirs.scm98
-rw-r--r--dirs.txi46
-rw-r--r--dwindtst.scm2
-rw-r--r--dynamic.scm10
-rw-r--r--dynwind.scm6
-rw-r--r--elk.init69
-rw-r--r--eval.scm12
-rw-r--r--factor.scm39
-rw-r--r--fft.scm44
-rw-r--r--fft.txi32
-rw-r--r--fluidlet.scm9
-rw-r--r--fmtdoc.txi434
-rw-r--r--format.scm22
-rw-r--r--formatst.scm19
-rw-r--r--gambit.init73
-rw-r--r--genwrite.scm4
-rw-r--r--getopt.scm34
-rw-r--r--getparam.scm132
-rw-r--r--getparam.txi85
-rw-r--r--glob.scm136
-rw-r--r--glob.txi100
-rw-r--r--grapheps.ps344
-rw-r--r--grapheps.scm617
-rw-r--r--grapheps.txi465
-rw-r--r--guile.init420
-rw-r--r--guile.init.local416
-rw-r--r--hash.scm42
-rw-r--r--hashtab.scm78
-rw-r--r--hashtab.txi84
-rw-r--r--html4each.scm240
-rw-r--r--html4each.txi70
-rw-r--r--htmlform.scm74
-rw-r--r--htmlform.txi27
-rw-r--r--http-cgi.scm34
-rw-r--r--lineio.scm34
-rw-r--r--lineio.txi19
-rw-r--r--logical.scm335
-rw-r--r--macscheme.init47
-rw-r--r--macwork.scm18
-rw-r--r--makcrc.scm96
-rw-r--r--manifest.scm350
-rw-r--r--manifest.txi145
-rw-r--r--matfile.scm187
-rw-r--r--matfile.txi31
-rw-r--r--mbe.scm72
-rw-r--r--minimize.scm3
-rw-r--r--mitscheme.init305
-rw-r--r--mkclrnam.scm259
-rw-r--r--mkclrnam.txi54
-rw-r--r--mklibcat.scm401
-rw-r--r--modular.scm180
-rw-r--r--modular.txi114
-rw-r--r--mulapply.scm22
-rw-r--r--mularg.scm20
-rw-r--r--mwexpand.scm40
-rw-r--r--mwsynrul.scm8
-rw-r--r--ncbi-dna.scm172
-rw-r--r--ncbi-dna.txi54
-rw-r--r--nclients.scm385
-rw-r--r--nclients.txi103
-rw-r--r--null.scm1
-rw-r--r--obj2str.scm3
-rw-r--r--object.scm18
-rw-r--r--object.texi (renamed from objdoc.txi)0
-rw-r--r--paramlst.scm18
-rw-r--r--phil-spc.scm94
-rw-r--r--phil-spc.txi38
-rw-r--r--plottest.scm27
-rw-r--r--pnm.scm277
-rw-r--r--pnm.txi66
-rw-r--r--pp.scm8
-rw-r--r--ppfile.scm7
-rw-r--r--prec.scm72
-rw-r--r--printf.scm21
-rw-r--r--priorque.scm73
-rw-r--r--priorque.txi33
-rw-r--r--process.scm7
-rw-r--r--promise.scm15
-rw-r--r--pscheme.init44
-rw-r--r--psxtime.scm40
-rw-r--r--qp.scm35
-rw-r--r--queue.scm77
-rw-r--r--queue.txi60
-rw-r--r--r4rsyn.scm2
-rw-r--r--randinex.scm42
-rw-r--r--randinex.txi21
-rw-r--r--random.scm69
-rw-r--r--random.txi26
-rw-r--r--ratize.scm43
-rw-r--r--ratize.txi41
-rw-r--r--rdms.scm287
-rw-r--r--recobj.scm11
-rw-r--r--record.scm27
-rw-r--r--repl.scm81
-rw-r--r--report.scm116
-rw-r--r--require.scm280
-rw-r--r--resenecolours.txt1410
-rw-r--r--root.scm14
-rw-r--r--s48-0_57.init85
-rw-r--r--saturate.txt39
-rw-r--r--sc2.scm15
-rw-r--r--sc4opt.scm17
-rw-r--r--sc4sc3.scm2
-rw-r--r--scainit.scm25
-rw-r--r--scamacr.scm2
-rw-r--r--scanf.scm514
-rw-r--r--scheme2c.init70
-rw-r--r--scheme48.init85
-rw-r--r--schmooz.scm434
-rw-r--r--schmooz.texi18
-rw-r--r--scm.init1
-rw-r--r--scmacro.scm21
-rw-r--r--scsh.init63
-rw-r--r--selfset.scm2
-rw-r--r--sierpinski.scm2
-rw-r--r--simetrix.scm5
-rw-r--r--slib.html76
-rw-r--r--slib.info10520
-rwxr-xr-xslib.sh119
-rw-r--r--slib.spec37
-rw-r--r--slib.texi6464
-rw-r--r--slib_1.html1172
-rw-r--r--slib_10.html217
-rw-r--r--slib_11.html268
-rw-r--r--slib_12.html346
-rw-r--r--slib_13.html325
-rw-r--r--slib_14.html314
-rw-r--r--slib_15.html367
-rw-r--r--slib_16.html311
-rw-r--r--slib_17.html461
-rw-r--r--slib_18.html331
-rw-r--r--slib_19.html214
-rw-r--r--slib_2.html824
-rw-r--r--slib_20.html294
-rw-r--r--slib_21.html271
-rw-r--r--slib_22.html180
-rw-r--r--slib_3.html2013
-rw-r--r--slib_4.html5157
-rw-r--r--slib_5.html6100
-rw-r--r--slib_6.html3658
-rw-r--r--slib_7.html8218
-rw-r--r--slib_8.html767
-rw-r--r--slib_9.html340
-rw-r--r--slib_abt.html205
-rw-r--r--slib_fot.html92
-rw-r--r--slib_ovr.html69
-rw-r--r--slib_toc.html676
-rw-r--r--solid.scm943
-rw-r--r--solid.txi441
-rw-r--r--sort.scm251
-rw-r--r--soundex.scm30
-rw-r--r--srcdir.mk2
-rw-r--r--srfi-1.scm230
-rw-r--r--srfi-1.txi86
-rw-r--r--srfi-2.scm41
-rw-r--r--srfi-2.txi8
-rw-r--r--srfi-8.scm14
-rw-r--r--srfi-8.txi8
-rw-r--r--srfi-9.scm16
-rw-r--r--srfi.scm2
-rw-r--r--stdio.scm5
-rw-r--r--strcase.scm41
-rw-r--r--strport.scm6
-rw-r--r--strsrch.scm164
-rw-r--r--structure.scm2
-rw-r--r--subarray.scm172
-rw-r--r--subarray.txi94
-rw-r--r--synchk.scm2
-rw-r--r--synclo.scm12
-rw-r--r--synrul.scm2
-rw-r--r--t3.init49
-rw-r--r--tek40.scm92
-rw-r--r--tek41.scm147
-rw-r--r--timezone.scm16
-rw-r--r--top-refs.scm285
-rw-r--r--top-refs.txi65
-rw-r--r--trace.scm24
-rw-r--r--transact.scm486
-rw-r--r--transact.txi150
-rw-r--r--tree.scm69
-rw-r--r--tree.txi48
-rw-r--r--trnscrpt.scm18
-rw-r--r--tsort.scm58
-rw-r--r--tsort.txi53
-rw-r--r--tzfile.scm134
-rw-r--r--umbscheme.init50
-rw-r--r--uri.scm139
-rw-r--r--uri.txi87
-rw-r--r--values.scm4
-rw-r--r--version.txi4
-rw-r--r--vet.scm218
-rw-r--r--vet.txi35
-rw-r--r--vscm.init66
-rw-r--r--withfile.scm26
-rw-r--r--wttest.scm2
-rw-r--r--wttree.scm6
-rw-r--r--yasyn.scm253
267 files changed, 67975 insertions, 11544 deletions
diff --git a/.slibcat b/.slibcat
new file mode 100644
index 0000000..54d82ee
--- /dev/null
+++ b/.slibcat
@@ -0,0 +1,164 @@
+;"slibcat" SLIB catalog for guile1.6.7. -*-scheme-*-
+;
+; DO NOT EDIT THIS FILE -- it is automagically generated
+
+(
+ (schelog . "./schelog/schelog")
+ (portable-scheme-debugger . "./psd/psd-slib")
+ (jfilter . "./jfilter/jfilter")
+ (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")
+ (printf . "./printf")
+ (scanf defmacro "./scanf")
+ (stdio-ports . "./stdio")
+ (stdio aggregate scanf printf stdio-ports)
+ (break defmacro "./break")
+ (trace defmacro "./trace")
+ (debugf . "./debug")
+ (debug aggregate trace break debugf)
+ (delay . promise)
+ (promise macro "./promise")
+ (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")
+ (*slib-version* . "3a1")
+)
diff --git a/ANNOUNCE b/ANNOUNCE
index 6070290..a4201ba 100644
--- a/ANNOUNCE
+++ b/ANNOUNCE
@@ -1,72 +1,56 @@
-This message announces the availability of Scheme Library release slib2d2.
-
-New in slib2d2:
-
- * s48-0_57.init: Added.
- * array.scm (make-shared-array): Fixed offset.
- * record.scm: Changed identifiers containing VECTOR to VECT or VCT
- (but no help for scheme48-0.57).
- * slib.texi (Collections, Lists as sets, Multi-argument / and -,
- Multi-argument Apply): Improved procedure templates.
- * comlist.scm: Replaced single-letter identifier names to improve
- readability.
- * slib.texi (Lists as sequences): Updated examples per change to
- comlist.scm.
- * comlist.scm (comlist:union, comlist:intersection,
- comlist:set-difference, comlist:remove-if, comlist:remove-if-not,
- comlist:remove-duplicates): Earlier tail-recursion enhancements
- changed the element order; which broke things. Order restored.
- * array.scm: Rewritten to sidestep license issues.
- (array=?): Added.
- * slib.texi (Arrays): Documentation integrated with array.scm.
- * tree.scm (tree:subst): Rewritten; takes optional equality
- predicate argument.
- * Makefile (docfiles): Added "COPYING".
- * mitcomp.pat: Unmaintained; removed.
- * RScheme.init: Put in the public domain.
- * Makefile (slib48): Simplified: scheme48 < scheme48.init
- * scheme48.init (slib-primitives): Pipe into scheme48, not load.
- Scheme48-0.45 the only version which runs jacal successfully.
- * scmactst.scm: Removed for lack of license.
- * struct.scm, structst.scm: Removed. struct.scm lacks license.
- * scheme48.init (atan): Added workaround.
- * Makefile (slib48-0.55): Makes slib48, but fluid-let broken.
- * format.scm (mutliarg/and-): Requires.
- * mularg.scm (two-arg:/, two-arg:-): Added.
- * scheme48.init (*features*): Doesn't support multiarg/and-.
- * Makefile (slib48-0.45): Added ",load-package floatnums".
- * slib.texi (Installation): Added specific instructions for
- DrScheme, MIT-Scheme, and Guile.
- * guile.init: Added.
- * require.scm (program-vicinity): Improved error message.
- * slib.texi (Installation): Explicit instructions for MzScheme.
- * Makefile (pdf): Added target for creating $(htmldir)slib.pdf.
- * slib.texi (Installation): Expanded instructions.
- * bigloo.init, RScheme.init, STk.init (*features*): Provide srfi.
- * Template.scm, *.init (*features*): Put into consistent form.
- * require.scm (srfi): Detect presence of srfi-0 through srfi-30.
- * srfi-1.scm: Added.
- * comlist.scm (comlist:remove): Returns don't disturb order.
- * array.scm: Generalized so strings and vectors are arrays.
- * slib.texi (Standard Formatted Output): %b was missing.
- * slib.texi (Sorting and Searching): Section split from
- "Procedures".
- * differ.scm (diff:longest-common-subsequence): Added.
- (diff:longest-common-subsequence, diff:edits, diff:edit-length):
- Optional third argument is equality predicate.
- * differ.scm: An O(NP) Sequence Comparison Algorithm.
- * srfi.scm (cond-expand): Added.
- * wttree.scm (error:error): Replaces error.
- * dbutil.scm (make-defaulter): number defaults to 0.
- * Makefile (rpm): Fixed dependencies.
-
-From Jacques Mequin <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.
;
diff --git a/COPYING b/COPYING
index c16d8bd..a2eb7dd 100644
--- a/COPYING
+++ b/COPYING
@@ -27,7 +27,7 @@ the beginning of "require.scm" states:
;1. Any copy made of this software must include this copyright notice
;in full.
;
- ;2. I have made no warrantee or representation that the operation of
+ ;2. I have made no warranty or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
diff --git a/ChangeLog b/ChangeLog
index e5f19fa..857cc78 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,2066 @@
+2003-11-30 Aubrey Jaffer <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)))))
diff --git a/FAQ b/FAQ
index 93f94da..3a428a5 100644
--- a/FAQ
+++ b/FAQ
@@ -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?
diff --git a/Makefile b/Makefile
index 3a1d5fc..2251d10 100644
--- a/Makefile
+++ b/Makefile
@@ -9,146 +9,214 @@ intro:
@echo "Welcome to SLIB. Read \"README\" and \"slib.info\" (or"
@echo "\"slib.texi\") to learn how to install and use SLIB."
@echo
- @echo
-make slib.info
include srcdir.mk
srcdir.mk: .. Makefile
echo -e "srcdir = `pwd`/\n" > srcdir.mk
#srcdir=$(HOME)/slib/
-PREVDOCS = prevdocs/
-dvidir=../dvi/
-dvi: $(dvidir)slib.dvi
-$(dvidir)slib.dvi: version.txi slib.texi $(dvidir)slib.fn schmooz.texi
-# cd $(dvidir);export TEXINPUTS=$(srcdir):;texi2dvi $(srcdir)slib.texi
- -(cd $(dvidir);export TEXINPUTS=$(srcdir):;texindex slib.??)
- cd $(dvidir);export TEXINPUTS=$(srcdir):;tex $(srcdir)slib.texi
-$(dvidir)slib.fn:
- cd $(dvidir);export TEXINPUTS=$(srcdir):;tex $(srcdir)slib.texi \
- $(srcdir)schmooz.texi
-xdvi: $(dvidir)slib.dvi
- xdvi -s 6 $(dvidir)slib.dvi
-htmldir=../public_html/
-slib_toc.html: version.txi slib.texi htmlform.txi schmooz.texi
- texi2html -split -verbose slib.texi
-pdf: $(htmldir)slib.pdf
-$(htmldir)slib.pdf: version.txi slib.texi $(dvidir)slib.fn schmooz.texi
-# cd $(dvidir);dvipdf slib.dvi # doesn't have links!
- cd $(dvidir);export TEXINPUTS=$(srcdir):;pdftex $(srcdir)slib.texi
- mv $(dvidir)slib.pdf $(htmldir)
-xpdf: $(htmldir)slib.pdf
- xpdf -z 3 $(htmldir)slib.pdf
-
-html: $(htmldir)slib_toc.html
-$(htmldir)slib_toc.html: slib_toc.html Makefile
- hitch $(PREVDOCS)slib_\*.html slib_\*.html $(htmldir)
+VERSION = 3a1
+RELEASE = 1
rpm_prefix=/usr/src/redhat/
-
prefix = debian/tmp/usr
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=slib_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
+scheme = guile-1.6
-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 format.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 formatst.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) -l guile.init.local -c '(require '\''schmooz) (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 = texi2html -split chapter -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 mkdir -p $(htmldir) ; 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,23 +359,25 @@ 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
-rm -f slib$(VERSION).info
+ -rm -f version.txi
+ -rm -rf $(htmldir)
+ echo $(scheme) -l guile.init.local -c '(require '\''schmooz) (schmooz-which-files "slib.texi")'
distclean: realclean
realclean:
diff --git a/README b/README
index 8d4d31d..1443e0e 100644
--- a/README
+++ b/README
@@ -1,4 +1,4 @@
-This directory contains the distribution of Scheme Library slib2d2.
+This directory contains the distribution of Scheme Library slib3a1.
Slib conforms to Revised^5 Report on the Algorithmic Language Scheme
and the IEEE P1178 specification. Slib supports Unix and similar
systems, VMS, and MS-DOS.
@@ -8,8 +8,8 @@ The maintainer can be reached at agj @ alum.mit.edu.
MANIFEST
- `README' is this file. It contains a MANIFEST, INSTALLATION
- INSTRUCTIONS, and coding guidelines.
+ `README' is this file. It contains a MANIFEST and INSTALLATION
+ INSTRUCTIONS.
`FAQ' Frequently Asked Questions and answers.
`ChangeLog' documents changes to slib.
`slib.texi' has documentation on library packages in TexInfo format.
@@ -19,7 +19,7 @@ The maintainer can be reached at agj @ alum.mit.edu.
`bigloo.init' is a configuration file for Bigloo.
`chez.init' is a configuration file for Chez Scheme.
`DrScheme.init' is a configuration file for DrScheme.
- `elk.init' is a configuration file for ELK 2.1
+ `elk.init' is a configuration file for ELK 3.0.
`gambit.init' is a configuration file for Gambit Scheme.
`macscheme.init' is a configuration file for MacScheme.
`mitscheme.init' is a configuration file for MIT Scheme.
@@ -32,16 +32,15 @@ The maintainer can be reached at agj @ alum.mit.edu.
`scm.init' is a configuration file for SCM.
`t3.init' is a configuration file for T3.1 in Scheme mode.
`STk.init' is a configuration file for STk.
- `umbscheme.init' is a configuration file for umb-scheme.
+ `umbscheme.init' is a configuration file for umb-scheme.
`vscm.init' is a configuration file for VSCM.
`guile.init' is a configuration file for guile.
`mklibcat.scm' builds the *catalog* cache.
`require.scm' has code which allows system independent access to
the library files.
+ `slib.sh' is a shell script for running various Schemes with SLIB.
`Bev2slib.scm' Converts Stephen Bevan's "*.map" files to SLIB catalog entries.
- `format.scm' has Common-Lisp style format.
- `formatst.scm' has code to test format.scm
`pp.scm' has pretty-print.
`ppfile.scm' has pprint-file and pprint-filter-file.
`obj2str.scm' has object->string.
@@ -63,6 +62,7 @@ The maintainer can be reached at agj @ alum.mit.edu.
`hash.scm' defines hash, hashq, and hashv.
`hashtab.scm' has hash tables.
`sierpinski.scm' 2-dimensional coordinate hash.
+ `phil-spc.scm' Peano-Hilbert Space-Filling Curve.
`soundex.scm' English name hash.
`logical.scm' emulates 2's complement logical operations.
`random.scm' has random number generator compatible with Common Lisp.
@@ -75,10 +75,19 @@ The maintainer can be reached at agj @ alum.mit.edu.
`selfset.scm' sets single letter identifiers to their symbols.
`determ.scm' compute determinant of list of lists.
`charplot.scm' has procedure for plotting on character screens.
+ `grapheps.scm' has procedures for creating PostScript graphs.
+ `grapheps.ps' is PostScript runtime support for creating graphs.
+ `matfile.scm' reads MAT-File Format version 4 (MATLAB).
`plottest.scm' has code to test charplot.scm.
- `tek40.scm' has routines for Tektronix 4000 series graphics.
- `tek41.scm' has routines for Tektronix 4100 series graphics.
- `getopt.scm' has posix-like getopt for parsing command line arguments.
+ `solid.scm' has VRML97 solid-modeling.
+ `colorspc.scm' has CIE and sRGB color transforms.
+ `colornam.scm' has color-name database functions.
+ `mkclrnam.scm' creates color-name databases.
+ `color.scm' has color data-type.
+ `cie1931.xyz' CIE XYZ(1931) Spectra from 380.nm to 780.nm.
+ `cie1964.xyz' CIE XYZ(1964) Spectra from 380.nm to 780.nm.
+ `daylight.scm' Model of sky colors.
+ `getopt.scm' has posix-like getopt for parsing command line arguments.
`psxtime.scm' has Posix time conversion routines.
`cltime.scm' has Common-Lisp time conversion routines.
`timezone.scm' has the default time-zone, UTC.
@@ -88,23 +97,29 @@ The maintainer can be reached at agj @ alum.mit.edu.
`rdms.scm' has code to construct a relational database from a base
table implementation.
`alistab.scm' has association list base tables.
- `dbutil.scm' has utilities for creating and manipulating relational
+ `dbutil.scm' has procedures for creating and opening relational
databases.
+ `dbsyn.scm' has Syntactic extensions for RDMS (within-database).
+ `dbcom.scm' embeds *commands* in relational databases.
+ `dbinterp.scm' Interpolate function from database table.
`htmlform.scm' generates HTML-3.2 with forms.
`db2html.scm' convert relational database to hyperlinked tables and
pages.
`http-cgi.scm' serves WWW pages with HTTP or CGI.
+ `html4each.scm' parses HTML files.
+ `dirs.scm' maps over directory filenames.
`uri.scm' encodes and decodes Uniform Resource Identifiers.
`dbrowse.scm' browses relational databases.
`paramlst.scm' has procedures for passing parameters by name.
`getparam.scm' has procedures for converting getopt to parameters.
- `report.scm' prints database reports.
+ `manifest.scm' List SLIB module requires and exports; useful for compiling.
+ `top-defs.scm' Finds external references.
+ `vet.scm' Checks each module imports, exports, and documentation.
`schmooz.scm' is a simple, lightweight markup language for
interspersing Texinfo documentation with Scheme source code.
`glob.scm' has filename matching and manipulation.
`batch.scm' Group and execute commands on various operating systems.
- `makcrc.scm' Create Scheme procedure to calculate POSIX.2 checksums
- or other CRCs.
+ `crc.scm' Calculate POSIX.2 checksums and other CRCs.
`record.scm' a MITScheme user-definable datatypes package
`promise.scm' has code from R4RS for supporting DELAY and FORCE.
@@ -134,7 +149,8 @@ The maintainer can be reached at agj @ alum.mit.edu.
`wttree.scm' has weight-balanced trees.
`wttest.scm' tests weight-balanced trees.
`process.scm' has multi-processing primitives.
- `array.scm' has multi-dimensional arrays and sub-arrays.
+ `array.scm' has multi-dimensional arrays.
+ `subarray.scm' has subarray and accessory procedures.
`arraymap.scm' has array-map!, array-for-each, and array-indexes.
`sort.scm' has sorted?, sort, sort!, merge, and merge!.
@@ -147,7 +163,7 @@ The maintainer can be reached at agj @ alum.mit.edu.
`sc4opt.scm' has optional rev4 procedures.
`sc4sc3.scm' has procedures to make a rev3 implementation run rev4
- code.
+ code.
`sc2.scm' has rev2 procedures eliminated in subsequent versions.
`mularg.scm' redefines - and / to take more than 2 arguments.
`mulapply.scm' redefines apply to take more than 2 arguments.
@@ -161,9 +177,11 @@ The maintainer can be reached at agj @ alum.mit.edu.
`fluidlet.scm' has fluid-let syntax.
`structure.scm' has undocumented syntax-case macros.
`byte.scm' has arrays of small integers.
- `nclients.scm' provides a Scheme interface to FTP and WWW Browsers.
+ `bytenumb.scm' convert byte-arrays to integers; IEEE floating-point numbers.
+ `transact.scm' File locking and backup.
`pnm.scm' provides a Scheme interface to "portable bitmap" files.
`simetrix.scm' provides SI Metric Interchange Format.
+ `ncbi-dna.scm' reads and manipulates DNA and protein sequences.
`srfi.scm' implements Scheme Request for Implementation.
`srfi-N.scm' implements srfi-N.
@@ -237,6 +255,13 @@ when installing SLIB.
(require 'new-catalog)
+ The catalog also supports color-name dictionaries. With an
+SLIB-installed scheme implementation, type:
+ (require 'color-names)
+ (make-slib-color-name-db)
+ (require 'new-catalog)
+ (slib:exit)
+
Implementation-specific Instructions
------------------------------------
@@ -293,7 +318,7 @@ as outlined above.
To use SLIB in MzScheme, set the SCHEME_LIBRARY_PATH environment
variable to the installed SLIB location; then invoke MzScheme thus:
- `mzscheme -L init.ss slibinit'
+ `mzscheme -f ${SCHEME_LIBRARY_PATH}DrScheme.init'
- Implementation: MIT Scheme
`scheme -load ${SCHEME_LIBRARY_PATH}mitscheme.init'
@@ -326,27 +351,14 @@ library will then be accessible in a system independent fashion.
Please mail new working configuration files to `agj @ alum.mit.edu' so
that they can be included in the SLIB distribution.
- CODING GUIDELINES
+ USING SLIB
- All library packages are written in IEEE P1178 Scheme and assume that
-a configuration file and `require.scm' package have already been
+ All library packages are written in IEEE P1178 Scheme and assume
+that a configuration file and `require.scm' package have already been
loaded. Other versions of Scheme can be supported in library packages
-as well by using, for example, `(provided? 'rev3-report)' or `(require
-'rev3-report)'.
-
- `require.scm' defines `*catalog*', an association list of module
-names and filenames. When a new package is added to the library, an
-entry should be added to `require.scm'. Local packages can also be
-added to `*catalog*' and even shadow entries already in the table.
-
- The module name and `:' should prefix each symbol defined in the
-package. Definitions for external use should then be exported by having
-`(define foo module-name:foo)'.
+as well by using, for example, `(provided? 'r3rs)' or `(require 'r3rs)'.
- Submitted packages should not duplicate routines which are already in
-SLIB files. Use `require' to force those features to be supported in
-your package. Care should be taken that there are no circularities in
-the `require's and `load's between the library packages.
+The first chapter of the SLIB manual "The Library System" explains the
+mechanics of using SLIB modules.
- Documentation should be provided in Emacs Texinfo format if possible,
-But documentation must be provided.
+ http://swissnet.ai.mit.edu/~jaffer/slib_1
diff --git a/RScheme.init b/RScheme.init
index c03119c..b9a7d84 100644
--- a/RScheme.init
+++ b/RScheme.init
@@ -54,6 +54,19 @@
(else "")))))
(lambda () library-path)))
+;;; (home-vicinity) should return the vicinity of the user's HOME
+;;; directory, the directory which typically contains files which
+;;; customize a computer environment for a user.
+(define (home-vicinity)
+ (let ((home (getenv "HOME")))
+ (and home
+ (case (software-type)
+ ((UNIX COHERENT MS-DOS) ;V7 unix has a / on HOME
+ (if (eqv? #\/ (string-ref home (+ -1 (string-length home))))
+ home
+ (string-append home "/")))
+ (else home)))))
+
;;; *FEATURES* should be set to a list of symbols describing features
;;; of this implementation. Suggestions for features are:
@@ -66,7 +79,7 @@
;; Scheme report features
-; rev5-report ;conforms to
+; r5rs ;conforms to
; eval ;R5RS two-argument eval
; values ;R5RS multiple values
; dynamic-wind ;R5RS dynamic-wind
@@ -80,11 +93,11 @@
;STRING-FILL!, LIST->VECTOR,
;VECTOR->LIST, and VECTOR-FILL!
- rev4-report ;conforms to
+ r4rs ;conforms to
ieee-p1178 ;conforms to
-; rev3-report ;conforms to
+; r3rs ;conforms to
; rev2-procedures ;SUBSTRING-MOVE-LEFT!,
;SUBSTRING-MOVE-RIGHT!,
@@ -95,7 +108,7 @@
multiarg/and- ;/ and - can take more than 2 args.
with-file ;has WITH-INPUT-FROM-FILE and
- ;WITH-OUTPUT-FROM-FILE
+ ;WITH-OUTPUT-TO-FILE
; transcript ;TRANSCRIPT-ON and TRANSCRIPT-OFF
; ieee-floating-point ;conforms to IEEE Standard 754-1985
;IEEE Standard for Binary
@@ -160,6 +173,33 @@
;;; CALL-WITH-INPUT-STRING and CALL-WITH-OUTPUT-STRING are the string
;;; port versions of CALL-WITH-*PUT-FILE.
+(define (make-exchanger obj)
+ (lambda (rep) (let ((old obj)) (set! obj rep) old)))
+(define (open-file filename modes)
+ (case modes
+ ((r rb) (open-input-file filename))
+ ((w wb) (open-output-file filename))
+ (else (slib:error 'open-file 'mode? modes))))
+(define (port? obj) (or (input-port? port) (output-port? port)))
+(define (call-with-open-ports . ports)
+ (define proc (car ports))
+ (cond ((procedure? proc) (set! ports (cdr ports)))
+ (else (set! ports (reverse ports))
+ (set! proc (car ports))
+ (set! ports (reverse (cdr ports)))))
+ (let ((ans (apply proc ports)))
+ (for-each close-port ports)
+ ans))
+(define (close-port port)
+ (cond ((input-port? port)
+ (close-input-port port)
+ (if (output-port? port) (close-output-port port)))
+ ((output-port? port) (close-output-port port))
+ (else (slib:error 'close-port 'port? port))))
+
+(define (browse-url url)
+ (slib:warn "define BROWSE-URL in macscheme.init"))
+
;;; CHAR-CODE-LIMIT is one greater than the largest integer which can
;;; be returned by CHAR->INTEGER.
(define char-code-limit 65536)
@@ -232,7 +272,7 @@
(let ((cep (current-error-port)))
(if (provided? 'trace) (print-call-stack cep))
(display "Warn: " cep)
- (for-each (lambda (x) (display x cep)) args))))
+ (for-each (lambda (x) (display #\ cep) (write x cep)) args))))
;;; define an error procedure for the library
(define (slib:error msg . args)
diff --git a/STk.init b/STk.init
index b4f256d..97edf81 100644
--- a/STk.init
+++ b/STk.init
@@ -7,35 +7,29 @@
;;; (software-type) should be set to the generic operating system type.
;;; UNIX, VMS, MACOS, AMIGA and MS-DOS are supported.
-
(define (software-type) 'UNIX)
;;; (scheme-implementation-type) should return the name of the scheme
;;; implementation loading this file.
-
(define (scheme-implementation-type) '|STk|)
;;; (scheme-implementation-home-page) should return a (string) URI
;;; (Uniform Resource Identifier) for this scheme implementation's home
;;; page; or false if there isn't one.
-
(define (scheme-implementation-home-page)
"http://kaolin.unice.fr/STk/STk.html")
;;; (scheme-implementation-version) should return a string describing
;;; the version the scheme implementation loading this file.
-
(define (scheme-implementation-version) (version))
;;; (implementation-vicinity) should be defined to be the pathname of
;;; the directory where any auxillary files to your Scheme
;;; implementation reside.
-
(define (implementation-vicinity) "/usr/local/lib/stk/3.99.3/")
;;; (library-vicinity) should be defined to be the pathname of the
;;; directory where files of Scheme library functions reside.
-
(define library-vicinity
(let ((library-path (or (getenv "SCHEME_LIBRARY_PATH") "/usr/local/lib/slib/")))
(lambda () library-path)))
@@ -44,14 +38,18 @@
;;; (home-vicinity) should return the vicinity of the user's HOME
;;; directory, the directory which typically contains files which
;;; customize a computer environment for a user.
-
-(define home-vicinity
- (let ((home-path (or (getenv "HOME") "/")))
- (lambda () home-path)))
+(define (home-vicinity)
+ (let ((home (getenv "HOME")))
+ (and home
+ (case (software-type)
+ ((UNIX COHERENT MS-DOS) ;V7 unix has a / on HOME
+ (if (eqv? #\/ (string-ref home (+ -1 (string-length home))))
+ home
+ (string-append home "/")))
+ (else home)))))
;;; *FEATURES* should be set to a list of symbols describing features
;;; of this implementation. Suggestions for features are:
-
(define *features*
'(
source ;can load scheme source files
@@ -61,7 +59,7 @@
;; Scheme report features
-; rev5-report ;conforms to
+; r5rs ;conforms to
eval ;R5RS two-argument eval
; values ;R5RS multiple values
dynamic-wind ;R5RS dynamic-wind
@@ -75,11 +73,11 @@
;STRING-FILL!, LIST->VECTOR,
;VECTOR->LIST, and VECTOR-FILL!
- rev4-report ;conforms to
+ r4rs ;conforms to
ieee-p1178 ;conforms to
-; rev3-report ;conforms to
+; r3rs ;conforms to
; rev2-procedures ;SUBSTRING-MOVE-LEFT!,
;SUBSTRING-MOVE-RIGHT!,
@@ -90,7 +88,7 @@
multiarg/and- ;/ and - can take more than 2 args.
with-file ;has WITH-INPUT-FROM-FILE and
- ;WITH-OUTPUT-FROM-FILE
+ ;WITH-OUTPUT-TO-FILE
; transcript ;TRANSCRIPT-ON and TRANSCRIPT-OFF
ieee-floating-point ;conforms to IEEE Standard 754-1985
;IEEE Standard for Binary
@@ -141,6 +139,37 @@
;;; use this definition if your system doesn't have such a procedure.
(define (force-output . arg) (apply flush arg))
+(define (make-exchanger obj)
+ (lambda (rep) (let ((old obj)) (set! obj rep) old)))
+(define (open-file filename modes)
+ (case modes
+ ((r rb) (open-input-file filename))
+ ((w wb) (open-output-file filename))
+ (else (slib:error 'open-file 'mode? modes))))
+(define (port? obj) (or (input-port? port) (output-port? port)))
+(define (call-with-open-ports . ports)
+ (define proc (car ports))
+ (cond ((procedure? proc) (set! ports (cdr ports)))
+ (else (set! ports (reverse ports))
+ (set! proc (car ports))
+ (set! ports (reverse (cdr ports)))))
+ (let ((ans (apply proc ports)))
+ (for-each close-port ports)
+ ans))
+(define (close-port port)
+ (cond ((input-port? port)
+ (close-input-port port)
+ (if (output-port? port) (close-output-port port)))
+ ((output-port? port) (close-output-port port))
+ (else (slib:error 'close-port 'port? port))))
+
+(define (browse-url url)
+ (define (try cmd) (eqv? 0 (system (sprintf #f cmd url))))
+ (or (try "netscape-remote -remote 'openURL(%s)'")
+ (try "netscape -remote 'openURL(%s)'")
+ (try "netscape '%s'&")
+ (try "netscape '%s'")))
+
;;; CHAR-CODE-LIMIT is one greater than the largest integer which can
;;; be returned by CHAR->INTEGER.
(define char-code-limit 256)
@@ -199,7 +228,7 @@
(let ((cep (current-error-port)))
(if (provided? 'trace) (print-call-stack cep))
(display "Warn: " cep)
- (for-each (lambda (x) (display x cep)) args))))
+ (for-each (lambda (x) (display #\ cep) (write x cep)) args))))
;;; define an error procedure for the library
(define (slib:error . args)
@@ -230,13 +259,11 @@
;;; (SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever
;;; suffix all the module files in SLIB have. See feature 'SOURCE.
-
(define slib:load-source LOAD)
;;; (SLIB:LOAD-COMPILED "foo") should load the file that was produced
;;; by compiling "foo.scm" if this implementation can compile files.
;;; See feature 'COMPILED.
-
(define slib:load-compiled load)
;;;
diff --git a/Template.scm b/Template.scm
index 6421d92..63c10c9 100644
--- a/Template.scm
+++ b/Template.scm
@@ -3,40 +3,34 @@
;;;
;;; This code is in the public domain.
-;;; (software-type) should be set to the generic operating system type.
+;;@ (software-type) should be set to the generic operating system type.
;;; UNIX, VMS, MACOS, AMIGA and MS-DOS are supported.
-
(define (software-type) 'UNIX)
-;;; (scheme-implementation-type) should return the name of the scheme
+;;@ (scheme-implementation-type) should return the name of the scheme
;;; implementation loading this file.
-
(define (scheme-implementation-type) 'Template)
-;;; (scheme-implementation-home-page) should return a (string) URI
+;;@ (scheme-implementation-home-page) should return a (string) URI
;;; (Uniform Resource Identifier) for this scheme implementation's home
;;; page; or false if there isn't one.
-
(define (scheme-implementation-home-page) #f)
-;;; (scheme-implementation-version) should return a string describing
+;;@ (scheme-implementation-version) should return a string describing
;;; the version the scheme implementation loading this file.
-
(define (scheme-implementation-version) "?")
-;;; (implementation-vicinity) should be defined to be the pathname of
+;;@ (implementation-vicinity) should be defined to be the pathname of
;;; the directory where any auxillary files to your Scheme
;;; implementation reside.
-
(define (implementation-vicinity)
(case (software-type)
((UNIX) "/usr/local/src/scheme/")
((VMS) "scheme$src:")
((MS-DOS) "C:\\scheme\\")))
-;;; (library-vicinity) should be defined to be the pathname of the
+;;@ (library-vicinity) should be defined to be the pathname of the
;;; directory where files of Scheme library functions reside.
-
(define library-vicinity
(let ((library-path
(or
@@ -51,17 +45,21 @@
(else "")))))
(lambda () library-path)))
-;;; (home-vicinity) should return the vicinity of the user's HOME
+;;@ (home-vicinity) should return the vicinity of the user's HOME
;;; directory, the directory which typically contains files which
;;; customize a computer environment for a user.
-
-(define home-vicinity
- (let ((home-path (getenv "HOME")))
- (lambda () home-path)))
-
-;;; *FEATURES* should be set to a list of symbols describing features
+(define (home-vicinity)
+ (let ((home (getenv "HOME")))
+ (and home
+ (case (software-type)
+ ((UNIX COHERENT MS-DOS) ;V7 unix has a / on HOME
+ (if (eqv? #\/ (string-ref home (+ -1 (string-length home))))
+ home
+ (string-append home "/")))
+ (else home)))))
+
+;;@ *FEATURES* should be set to a list of symbols describing features
;;; of this implementation. Suggestions for features are:
-
(define *features*
'(
source ;can load scheme source files
@@ -71,7 +69,7 @@
;; Scheme report features
- rev5-report ;conforms to
+ r5rs ;conforms to
eval ;R5RS two-argument eval
values ;R5RS multiple values
dynamic-wind ;R5RS dynamic-wind
@@ -85,11 +83,11 @@
;STRING-FILL!, LIST->VECTOR,
;VECTOR->LIST, and VECTOR-FILL!
- rev4-report ;conforms to
+ r4rs ;conforms to
ieee-p1178 ;conforms to
-; rev3-report ;conforms to
+; r3rs ;conforms to
; rev2-procedures ;SUBSTRING-MOVE-LEFT!,
;SUBSTRING-MOVE-RIGHT!,
@@ -100,7 +98,7 @@
; multiarg/and- ;/ and - can take more than 2 args.
; with-file ;has WITH-INPUT-FROM-FILE and
- ;WITH-OUTPUT-FROM-FILE
+ ;WITH-OUTPUT-TO-FILE
; transcript ;TRANSCRIPT-ON and TRANSCRIPT-OFF
ieee-floating-point ;conforms to IEEE Standard 754-1985
;IEEE Standard for Binary
@@ -133,66 +131,66 @@
))
-;;; (OUTPUT-PORT-WIDTH <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"))
diff --git a/alist.scm b/alist.scm
index 5917c7c..f1bdd70 100644
--- a/alist.scm
+++ b/alist.scm
@@ -1,5 +1,5 @@
;;;"alist.scm", alist functions for Scheme.
-;;;Copyright (c) 1992, 1993 Aubrey Jaffer
+;;;Copyright (c) 1992, 1993, 2003 Aubrey Jaffer
;
;Permission to copy this software, to modify it, to redistribute it,
;to distribute modified versions, and to use it for any purpose is
@@ -8,7 +8,7 @@
;1. Any copy made of this software must include this copyright notice
;in full.
;
-;2. I have made no warrantee or representation that the operation of
+;2. I have made no warranty or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
@@ -17,6 +17,23 @@
;promotional, or sales literature without prior written consent in
;each case.
+;;@code{(require 'alist)}
+;;@ftindex alist
+;;
+;;Alist functions provide utilities for treating a list of key-value pairs
+;;as an associative database. These functions take an equality predicate,
+;;@var{pred}, as an argument. This predicate should be repeatable,
+;;symmetric, and transitive.
+;;
+;;Alist functions can be used with a secondary index method such as hash
+;;tables for improved performance.
+
+;;@body
+;;Returns an @dfn{association function} (like @code{assq}, @code{assv}, or
+;;@code{assoc}) corresponding to @var{pred}. The returned function
+;;returns a key-value pair whose key is @code{pred}-equal to its first
+;;argument or @code{#f} if no key in the alist is @var{pred}-equal to the
+;;first argument.
(define (predicate->asso pred)
(cond ((eq? eq? pred) assq)
((eq? = pred) assv)
@@ -30,12 +47,28 @@
((pred key (caar al)) (car al))
(else (l (cdr al)))))))))
+;;@body
+;;Returns a procedure of 2 arguments, @var{alist} and @var{key}, which
+;;returns the value associated with @var{key} in @var{alist} or @code{#f} if
+;;@var{key} does not appear in @var{alist}.
(define (alist-inquirer pred)
(let ((assofun (predicate->asso pred)))
(lambda (alist key)
(let ((pair (assofun key alist)))
(and pair (cdr pair))))))
+;;@body
+;;Returns a procedure of 3 arguments, @var{alist}, @var{key}, and
+;;@var{value}, which returns an alist with @var{key} and @var{value}
+;;associated. Any previous value associated with @var{key} will be
+;;lost. This returned procedure may or may not have side effects on its
+;;@var{alist} argument. An example of correct usage is:
+;;
+;;@lisp
+;;(define put (alist-associator string-ci=?))
+;;(define alist '())
+;;(set! alist (put alist "Foo" 9))
+;;@end lisp
(define (alist-associator pred)
(let ((assofun (predicate->asso pred)))
(lambda (alist key val)
@@ -44,6 +77,16 @@
alist)
(else (cons (cons key val) alist)))))))
+;;@body
+;;Returns a procedure of 2 arguments, @var{alist} and @var{key}, which
+;;returns an alist with an association whose @var{key} is key removed.
+;;This returned procedure may or may not have side effects on its
+;;@var{alist} argument. An example of correct usage is:
+;;
+;;@lisp
+;;(define rem (alist-remover string-ci=?))
+;;(set! alist (rem alist "foo"))
+;;@end lisp
(define (alist-remover pred)
(lambda (alist key)
(cond ((null? alist) alist)
@@ -58,9 +101,17 @@
(set-cdr! al (cddr al)) alist)
(else (l (cdr al)))))))))
+;;@body
+;;Returns a new association list formed by mapping @var{proc} over the
+;;keys and values of @var{alist}. @var{proc} must be a function of 2
+;;arguments which returns the new value part.
(define (alist-map proc alist)
(map (lambda (pair) (cons (car pair) (proc (car pair) (cdr pair))))
alist))
+;;@body
+;;Applies @var{proc} to each pair of keys and values of @var{alist}.
+;;@var{proc} must be a function of 2 arguments. The returned value is
+;;unspecified.
(define (alist-for-each proc alist)
(for-each (lambda (pair) (proc (car pair) (cdr pair))) alist))
diff --git a/alist.txi b/alist.txi
new file mode 100644
index 0000000..804df8a
--- /dev/null
+++ b/alist.txi
@@ -0,0 +1,70 @@
+@code{(require 'alist)}
+@ftindex alist
+
+Alist functions provide utilities for treating a list of key-value pairs
+as an associative database. These functions take an equality predicate,
+@var{pred}, as an argument. This predicate should be repeatable,
+symmetric, and transitive.
+
+Alist functions can be used with a secondary index method such as hash
+tables for improved performance.
+
+
+@defun predicate->asso pred
+
+Returns an @dfn{association function} (like @code{assq}, @code{assv}, or
+@cindex association function
+@code{assoc}) corresponding to @var{pred}. The returned function
+returns a key-value pair whose key is @code{pred}-equal to its first
+argument or @code{#f} if no key in the alist is @var{pred}-equal to the
+first argument.
+@end defun
+
+@defun alist-inquirer pred
+
+Returns a procedure of 2 arguments, @var{alist} and @var{key}, which
+returns the value associated with @var{key} in @var{alist} or @code{#f} if
+@var{key} does not appear in @var{alist}.
+@end defun
+
+@defun alist-associator pred
+
+Returns a procedure of 3 arguments, @var{alist}, @var{key}, and
+@var{value}, which returns an alist with @var{key} and @var{value}
+associated. Any previous value associated with @var{key} will be
+lost. This returned procedure may or may not have side effects on its
+@var{alist} argument. An example of correct usage is:
+
+@lisp
+(define put (alist-associator string-ci=?))
+(define alist '())
+(set! alist (put alist "Foo" 9))
+@end lisp
+@end defun
+
+@defun alist-remover pred
+
+Returns a procedure of 2 arguments, @var{alist} and @var{key}, which
+returns an alist with an association whose @var{key} is key removed.
+This returned procedure may or may not have side effects on its
+@var{alist} argument. An example of correct usage is:
+
+@lisp
+(define rem (alist-remover string-ci=?))
+(set! alist (rem alist "foo"))
+@end lisp
+@end defun
+
+@defun alist-map proc alist
+
+Returns a new association list formed by mapping @var{proc} over the
+keys and values of @var{alist}. @var{proc} must be a function of 2
+arguments which returns the new value part.
+@end defun
+
+@defun alist-for-each proc alist
+
+Applies @var{proc} to each pair of keys and values of @var{alist}.
+@var{proc} must be a function of 2 arguments. The returned value is
+unspecified.
+@end defun
diff --git a/alistab.scm b/alistab.scm
index e51bd26..e8999bf 100644
--- a/alistab.scm
+++ b/alistab.scm
@@ -8,7 +8,7 @@
;1. Any copy made of this software must include this copyright notice
;in full.
;
-;2. I have made no warrantee or representation that the operation of
+;2. I have made no warranty or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
@@ -23,7 +23,9 @@
;;; ROW is a list of non-primary VALUEs
(require 'common-list-functions)
-
+(require 'relational-database) ;for make-relational-system
+(require-if 'compiling 'sort)
+;@
(define alist-table
(let ((catalog-id 0)
(resources '*base-resources*)
@@ -42,13 +44,15 @@
(list resources (list 'free-id 1))))
(define (open-base infile writable)
- (and (or (input-port? infile) (file-exists? infile))
- (cons (if (input-port? infile) #f infile)
- ((lambda (fun)
- (if (input-port? infile)
- (fun infile)
- (call-with-input-file infile fun)))
- read))))
+ (define (reader port)
+ (cond ((eof-object? port) #f)
+ ((not (eqv? #\; (read-char port))) #f)
+ ((not (eqv? #\; (read-char port))) #f)
+ (else (cons (and (not (input-port? infile)) infile)
+ (read port)))))
+ (cond ((input-port? infile) (reader infile))
+ ((file-exists? infile) (call-with-input-file infile reader))
+ (else #f)))
(define (write-base lldb outfile)
((lambda (fun)
@@ -57,7 +61,8 @@
(else #f)))
(lambda (port)
(display (string-append
- ";;; \"" outfile "\" SLIB alist-table database -*-scheme-*-")
+ ";;; \"" outfile "\" SLIB " *SLIB-VERSION*
+ " alist-table database -*-scheme-*-")
port)
(newline port) (newline port)
(display "(" port) (newline port)
@@ -303,12 +308,12 @@
(define (supported-type? type)
(case type
- ((base-id atom integer boolean string symbol expression number) #t)
+ ((atom ordinal integer boolean string symbol expression number) #t)
(else #f)))
(define (supported-key-type? type)
(case type
- ((atom integer number symbol string) #t)
+ ((atom ordinal integer number symbol string) #t)
(else #f)))
;;make-table open-table remover assoc* make-assoc*
@@ -349,4 +354,8 @@
(else #f)))
))
+(set! *base-table-implementations*
+ (cons (list 'alist-table (make-relational-system alist-table))
+ *base-table-implementations*))
+
;; #f (trace-all "/home/jaffer/slib/alistab.scm") (untrace alist-table) (set! *qp-width* 333)
diff --git a/array.scm b/array.scm
index 47df853..417e137 100644
--- a/array.scm
+++ b/array.scm
@@ -1,5 +1,5 @@
;;;;"array.scm" Arrays for Scheme
-; Copyright (C) 2001 Aubrey Jaffer
+; Copyright (C) 2001, 2003 Aubrey Jaffer
;
;Permission to copy this software, to modify it, to redistribute it,
;to distribute modified versions, and to use it for any purpose is
@@ -8,7 +8,7 @@
;1. Any copy made of this software must include this copyright notice
;in full.
;
-;2. I have made no warrantee or representation that the operation of
+;2. I have made no warranty or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
@@ -30,7 +30,12 @@
store ;data
)))
-(define array:shape (record-accessor array:rtd 'shape))
+(define array:shape
+ (let ((shape (record-accessor array:rtd 'shape)))
+ (lambda (array)
+ (cond ((vector? array) (list (list 0 (+ -1 (vector-length array)))))
+ ((string? array) (list (list 0 (+ -1 (string-length array)))))
+ (else (shape array))))))
(define array:scales
(let ((scales (record-accessor array:rtd 'scales)))
@@ -77,7 +82,8 @@
;;corresponding elements of @1 and @2 are @code{equal?}.
;;
;;@example
-;;(array=? (make-array 'foo 3 3) (make-array 'foo '(0 2) '(1 2)))
+;;(array=? (create-array '#(foo) 3 3)
+;; (create-array '#(foo) '(0 2) '(0 2)))
;; @result{} #t
;;@end example
(define (array=? array1 array2)
@@ -87,17 +93,133 @@
(define (array:dimensions->shape dims)
(map (lambda (dim) (if (list? dim) dim (list 0 (+ -1 dim)))) dims))
-;;@args initial-value bound1 bound2 @dots{}
-;;Creates and returns an array with dimensions @var{bound1},
-;;@var{bound2}, @dots{} and filled with @1.
-(define (make-array initial-value . dimensions)
+;;@args prototype bound1 bound2 @dots{}
+;;
+;;Creates and returns an array of type @1 with dimensions @2, @3,
+;;@dots{} and filled with elements from @1. @1 must be an array,
+;;vector, or string. The implementation-dependent type of the returned
+;;array will be the same as the type of @1; except if that would be a
+;;vector or string with non-zero origin, in which case some variety of
+;;array will be returned.
+;;
+;;If the @1 has no elements, then the initial contents of the returned
+;;array are unspecified. Otherwise, the returned array will be filled
+;;with the element at the origin of @1.
+(define (create-array prototype . dimensions)
+ (define range2length (lambda (bnd) (- 1 (apply - bnd))))
+ ;;(if (not (array? prototype)) (set! prototype (vector prototype)))
(let* ((shape (array:dimensions->shape dimensions))
- (dims (map (lambda (bnd) (- 1 (apply - bnd))) shape))
- (scales (reverse (cons 1 (cdr (reverse dims))))))
- (array:construct shape
- scales
- (- (apply + (map * (map car shape) scales)))
- (make-vector (apply * dims) initial-value))))
+ (dims (map range2length shape))
+ (scales
+ (do ((dims (reverse (cdr dims)) (cdr dims))
+ (scls '(1) (cons (* (car dims) (car scls)) scls)))
+ ((null? dims) scls))))
+ (array:construct
+ shape
+ scales
+ (- (apply + (map * (map car shape) scales)))
+ (if (string? prototype)
+ (case (string-length prototype)
+ ((0) (make-string (apply * dims)))
+ (else (make-string (apply * dims)
+ (string-ref prototype 0))))
+ (let ((pshape (array:shape prototype)))
+ (case (apply * (map range2length pshape))
+ ((0) (make-vector (apply * dims)))
+ (else (make-vector (apply * dims)
+ (apply array-ref prototype
+ (map car pshape))))))))))
+
+;;@noindent
+;;These functions return a prototypical uniform-array enclosing the
+;;optional argument (which must be of the correct type). If the
+;;uniform-array type is supported by the implementation, then it is
+;;returned; defaulting to the next larger precision type; resorting
+;;finally to vector.
+
+(define (make-prototype-checker name pred? creator)
+ (lambda args
+ (case (length args)
+ ((1) (if (pred? (car args))
+ (creator (car args))
+ (slib:error name 'incompatible 'type (car args))))
+ ((0) (creator))
+ (else (slib:error name 'wrong 'number 'of 'args args)))))
+
+(define (integer-bytes?? n)
+ (lambda (obj)
+ (and (integer? obj)
+ (exact? obj)
+ (or (negative? n) (not (negative? obj)))
+ (do ((num obj (quotient num 256))
+ (n (+ -1 (abs n)) (+ -1 n)))
+ ((or (zero? num) (negative? n))
+ (zero? num))))))
+
+;;@args z
+;;@args
+;;Returns a high-precision complex uniform-array prototype.
+(define Ac64 (make-prototype-checker 'Ac64 complex? vector))
+;;@args z
+;;@args
+;;Returns a complex uniform-array prototype.
+(define Ac32 (make-prototype-checker 'Ac32 complex? vector))
+
+;;@args x
+;;@args
+;;Returns a high-precision real uniform-array prototype.
+(define Ar64 (make-prototype-checker 'Ar64 real? vector))
+;;@args x
+;;@args
+;;Returns a real uniform-array prototype.
+(define Ar32 (make-prototype-checker 'Ar32 real? vector))
+
+;;@args n
+;;@args
+;;Returns an exact signed integer uniform-array prototype with at least
+;;64 bits of precision.
+(define As64 (make-prototype-checker 'As64 (integer-bytes?? -8) vector))
+;;@args n
+;;@args
+;;Returns an exact signed integer uniform-array prototype with at least
+;;32 bits of precision.
+(define As32 (make-prototype-checker 'As32 (integer-bytes?? -4) vector))
+;;@args n
+;;@args
+;;Returns an exact signed integer uniform-array prototype with at least
+;;16 bits of precision.
+(define As16 (make-prototype-checker 'As16 (integer-bytes?? -2) vector))
+;;@args n
+;;@args
+;;Returns an exact signed integer uniform-array prototype with at least
+;;8 bits of precision.
+(define As8 (make-prototype-checker 'As8 (integer-bytes?? -1) vector))
+
+;;@args k
+;;@args
+;;Returns an exact non-negative integer uniform-array prototype with at
+;;least 64 bits of precision.
+(define Au64 (make-prototype-checker 'Au64 (integer-bytes?? 8) vector))
+;;@args k
+;;@args
+;;Returns an exact non-negative integer uniform-array prototype with at
+;;least 32 bits of precision.
+(define Au32 (make-prototype-checker 'Au32 (integer-bytes?? 4) vector))
+;;@args k
+;;@args
+;;Returns an exact non-negative integer uniform-array prototype with at
+;;least 16 bits of precision.
+(define Au16 (make-prototype-checker 'Au16 (integer-bytes?? 2) vector))
+;;@args k
+;;@args
+;;Returns an exact non-negative integer uniform-array prototype with at
+;;least 8 bits of precision.
+(define Au8 (make-prototype-checker 'Au8 (integer-bytes?? 1) vector))
+
+;;@args bool
+;;@args
+;;Returns a boolean uniform-array prototype.
+(define At1 (make-prototype-checker 'At1 boolean? vector))
;;@noindent
;;When constructing an array, @var{bound} is either an inclusive range of
@@ -105,18 +227,18 @@
;;a single integer. So
;;
;;@example
-;;(make-array 'foo 3 3) @equiv{} (make-array 'foo '(0 2) '(0 2))
+;;(create-array '#(foo) 3 3) @equiv{} (create-array '#(foo) '(0 2) '(0 2))
;;@end example
;;@args array mapper bound1 bound2 @dots{}
-;;@code{make-shared-array} can be used to create shared subarrays of other
+;;@0 can be used to create shared subarrays of other
;;arrays. The @var{mapper} is a function that translates coordinates in
;;the new array into coordinates in the old array. A @var{mapper} must be
;;linear, and its range must stay within the bounds of the old array, but
;;it can be otherwise arbitrary. A simple example:
;;
;;@example
-;;(define fred (make-array #f 8 8))
+;;(define fred (create-array '#(#f) 8 8))
;;(define freds-diagonal
;; (make-shared-array fred (lambda (i) (list i i)) 8))
;;(array-set! freds-diagonal 'foo 3)
@@ -153,32 +275,28 @@
;;Returns the number of dimensions of @1. If @1 is not an array, 0 is
;;returned.
(define (array-rank obj)
- (if (array? obj) (length (array-shape obj)) 0))
+ (if (array? obj) (length (array:shape obj)) 0))
-;;@body
+;;@args array
;;Returns a list of inclusive bounds.
;;
;;@example
-;;(array-shape (make-array 'foo 3 5))
+;;(array-shape (create-array '#() 3 5))
;; @result{} ((0 2) (0 4))
;;@end example
-(define array-shape
- (lambda (array)
- (cond ((vector? array) (list (list 0 (+ -1 (vector-length array)))))
- ((string? array) (list (list 0 (+ -1 (string-length array)))))
- (else (array:shape array)))))
+(define array-shape array:shape)
;;@body
;;@code{array-dimensions} is similar to @code{array-shape} but replaces
;;elements with a 0 minimum with one greater than the maximum.
;;
;;@example
-;;(array-dimensions (make-array 'foo 3 5))
+;;(array-dimensions (create-array '#() 3 5))
;; @result{} (3 5)
;;@end example
(define (array-dimensions array)
(map (lambda (bnd) (if (zero? (car bnd)) (+ 1 (cadr bnd)) bnd))
- (array-shape array)))
+ (array:shape array)))
(define (array:in-bounds? array indices)
(do ((bnds (array:shape array) (cdr bnds))
@@ -217,12 +335,8 @@
;;; Legacy functions
-;; These procedures are fast versions of @code{array-ref} and
-;; @code{array-set!} for non-string arrays; they take a fixed number of
-;; arguments and perform no bounds checking.
-(define array-1d-ref array-ref)
-(define array-2d-ref array-ref)
-(define array-3d-ref array-ref)
-(define array-1d-set! array-set!)
-(define array-2d-set! array-set!)
-(define array-3d-set! array-set!)
+;; ;;@args initial-value bound1 bound2 @dots{}
+;; ;;Creates and returns an array with dimensions @2,
+;; ;;@3, @dots{} and filled with @1.
+;; (define (make-array initial-value . dimensions)
+;; (apply create-array (vector initial-value) dimensions))
diff --git a/array.txi b/array.txi
index 5d30b19..bb09e16 100644
--- a/array.txi
+++ b/array.txi
@@ -23,15 +23,131 @@ Returns @code{#t} if @var{array1} and @var{array2} have the same rank and shape
corresponding elements of @var{array1} and @var{array2} 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
@end defun
-@defun make-array initial-value bound1 bound2 @dots{}
+@defun create-array prototype bound1 bound2 @dots{}
-Creates and returns an array with dimensions @var{bound1},
-@var{bound2}, @dots{} and filled with @var{initial-value}.
+
+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
@@ -39,7 +155,7 @@ indices expressed as a two element list, or an upper bound expressed as
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
@@ -52,7 +168,7 @@ 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)
@@ -77,7 +193,7 @@ returned.
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
@end defun
@@ -88,7 +204,7 @@ Returns a list of inclusive bounds.
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
@end defun
@@ -104,8 +220,8 @@ Returns @code{#t} if its arguments would be acceptable to
Returns the (@var{index1}, @var{index2}, @dots{}) element of @var{array}.
@end defun
-@defun array-set! array obj index1 index2 @dots{}
+@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 defun
+@end deffn
diff --git a/arraymap.scm b/arraymap.scm
index 15e24da..747962e 100644
--- a/arraymap.scm
+++ b/arraymap.scm
@@ -1,5 +1,5 @@
;;;; "arraymap.scm", applicative routines for arrays in Scheme.
-;;; Copyright (c) 1993 Aubrey Jaffer
+;;; Copyright (c) 1993, 2003 Aubrey Jaffer
;
;Permission to copy this software, to modify it, to redistribute it,
;to distribute modified versions, and to use it for any purpose is
@@ -8,7 +8,7 @@
;1. Any copy made of this software must include this copyright notice
;in full.
;
-;2. I have made no warrantee or representation that the operation of
+;2. I have made no warranty or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
@@ -19,6 +19,16 @@
(require 'array)
+;;@code{(require 'array-for-each)}
+;;@ftindex array-for-each
+
+;;@args array0 proc array1 @dots{}
+;;@var{array1}, @dots{} must have the same number of dimensions as
+;;@var{array0} and have a range for each index which includes the range
+;;for the corresponding index in @var{array0}. @var{proc} is applied to
+;;each tuple of elements of @var{array1} @dots{} and the result is stored
+;;as the corresponding element in @var{array0}. The value returned is
+;;unspecified. The order of application is unspecified.
(define (array-map! ra0 proc . ras)
(define (ramap rshape inds)
(if (null? (cdr rshape))
@@ -27,8 +37,7 @@
(cons (+ -1 i) inds)))
((< i (caar rshape)))
(apply array-set! ra0
- (apply proc (map (lambda (ra) (apply array-ref ra is))
- ras))
+ (apply proc (map (lambda (ra) (apply array-ref ra is)) ras))
is))
(let ((crshape (cdr rshape))
(ll (caar rshape)))
@@ -37,14 +46,31 @@
(ramap crshape (cons i inds))))))
(ramap (reverse (array-shape ra0)) '()))
+;;@args prototype proc array1 array2 @dots{}
+;;@var{array2}, @dots{} must have the same number of dimensions as
+;;@var{array1} and have a range for each index which includes the
+;;range for the corresponding index in @var{array1}. @var{proc} is
+;;applied to each tuple of elements of @var{array1}, @var{array2},
+;;@dots{} and the result is stored as the corresponding element in a
+;;new array of type @var{prototype}. The new array is returned. The
+;;order of application is unspecified.
+(define (array-map prototype proc ra1 . ras)
+ (define nra (apply create-array prototype (array-shape ra1)))
+ (apply array-map! nra proc ra1 ras)
+ nra)
+
+;;@args proc array0 @dots{}
+;;@var{proc} is applied to each tuple of elements of @var{array0} @dots{}
+;;in row-major order. The value returned is unspecified.
(define (array-for-each proc . ras)
(define (rafe rshape inds)
(if (null? (cdr rshape))
- (do ((i (caar rshape) (+ 1 i)))
- ((> i (cadar rshape)))
- (apply proc
- (map (lambda (ra)
- (apply array-ref ra (reverse (cons i inds)))) ras)))
+ (let ((sdni (reverse (cons #f inds))))
+ (define lastpair (last-pair sdni))
+ (do ((i (caar rshape) (+ 1 i)))
+ ((> i (cadar rshape)))
+ (set-car! lastpair i)
+ (apply proc (map (lambda (ra) (apply array-ref ra sdni)) ras))))
(let ((crshape (cdr rshape))
(ll (cadar rshape)))
(do ((i (caar rshape) (+ 1 i)))
@@ -52,6 +78,35 @@
(rafe crshape (cons i inds))))))
(rafe (array-shape (car ras)) '()))
+;;@args array
+;;Returns an array of lists of indexes for @var{array} such that, if
+;;@var{li} is a list of indexes for which @var{array} is defined,
+;;(equal? @var{li} (apply array-ref (array-indexes @var{array})
+;;@var{li})).
+(define (array-indexes ra)
+ (let ((ra0 (apply create-array '#() (array-shape ra))))
+ (array-index-map! ra0 list)
+ ra0))
+
+;;@args array proc
+;;applies @var{proc} to the indices of each element of @var{array} in
+;;turn, storing the result in the corresponding element. The value
+;;returned and the order of application are unspecified.
+;;
+;;One can implement @var{array-indexes} as
+;;@example
+;;(define (array-indexes array)
+;; (let ((ra (apply create-array '#() (array-shape array))))
+;; (array-index-map! ra (lambda x x))
+;; ra))
+;;@end example
+;;Another example:
+;;@example
+;;(define (apl:index-generator n)
+;; (let ((v (make-vector n 1)))
+;; (array-index-map! v (lambda (i) i))
+;; v))
+;;@end example
(define (array-index-map! ra fun)
(define (ramap rshape inds)
(if (null? (cdr rshape))
@@ -69,10 +124,10 @@
(array-set! ra (fun))
(ramap (reverse (array-shape ra)) '())))
-(define (array-indexes ra)
- (let ((ra0 (apply make-array '() (array-shape ra))))
- (array-index-map! ra0 list)
- ra0))
-
+;;@args source destination
+;;Copies every element from vector or array @var{source} to the
+;;corresponding element of @var{destination}. @var{destination} must
+;;have the same rank as @var{source}, and be at least as large in each
+;;dimension. The order of copying is unspecified.
(define (array-copy! source dest)
(array-map! dest identity source))
diff --git a/arraymap.txi b/arraymap.txi
new file mode 100644
index 0000000..f10ad65
--- /dev/null
+++ b/arraymap.txi
@@ -0,0 +1,68 @@
+@code{(require 'array-for-each)}
+@ftindex array-for-each
+
+
+@deffn {Procedure} array-map! array0 proc array1 @dots{}
+
+@var{array1}, @dots{} must have the same number of dimensions as
+@var{array0} and have a range for each index which includes the range
+for the corresponding index in @var{array0}. @var{proc} is applied to
+each tuple of elements of @var{array1} @dots{} and the result is stored
+as the corresponding element in @var{array0}. The value returned is
+unspecified. The order of application is unspecified.
+@end deffn
+
+@defun array-map prototype proc array1 array2 @dots{}
+
+@var{array2}, @dots{} must have the same number of dimensions as
+@var{array1} and have a range for each index which includes the
+range for the corresponding index in @var{array1}. @var{proc} is
+applied to each tuple of elements of @var{array1}, @var{array2},
+@dots{} and the result is stored as the corresponding element in a
+new array of type @var{prototype}. The new array is returned. The
+order of application is unspecified.
+@end defun
+
+@defun array-for-each proc array0 @dots{}
+
+@var{proc} is applied to each tuple of elements of @var{array0} @dots{}
+in row-major order. The value returned is unspecified.
+@end defun
+
+@defun array-indexes array
+
+Returns an array of lists of indexes for @var{array} such that, if
+@var{li} is a list of indexes for which @var{array} is defined,
+(equal? @var{li} (apply array-ref (array-indexes @var{array})
+@var{li})).
+@end defun
+
+@deffn {Procedure} array-index-map! array proc
+
+applies @var{proc} to the indices of each element of @var{array} in
+turn, storing the result in the corresponding element. The value
+returned and the order of application are unspecified.
+
+One can implement @var{array-indexes} as
+@example
+(define (array-indexes array)
+ (let ((ra (apply create-array '#() (array-shape array))))
+ (array-index-map! ra (lambda x x))
+ ra))
+@end example
+Another example:
+@example
+(define (apl:index-generator n)
+ (let ((v (make-vector n 1)))
+ (array-index-map! v (lambda (i) i))
+ v))
+@end example
+@end deffn
+
+@deffn {Procedure} array-copy! source destination
+
+Copies every element from vector or array @var{source} to the
+corresponding element of @var{destination}. @var{destination} must
+have the same rank as @var{source}, and be at least as large in each
+dimension. The order of copying is unspecified.
+@end deffn
diff --git a/batch.scm b/batch.scm
index 45b404c..bef29cc 100644
--- a/batch.scm
+++ b/batch.scm
@@ -8,7 +8,7 @@
;1. Any copy made of this software must include this copyright notice
;in full.
;
-;2. I have made no warrantee or representation that the operation of
+;2. I have made no warranty or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
@@ -17,11 +17,14 @@
;promotional, or sales literature without prior written consent in
;each case.
+(require 'tree)
(require 'line-i/o) ;Just for write-line
+(require 'databases)
(require 'parameters)
-(require 'database-utilities)
(require 'string-port)
-(require 'tree)
+(require 'pretty-print)
+(require 'common-list-functions)
+(require-if '(and bignum compiling) 'posix-time)
(define system
(if (provided? 'system)
@@ -43,6 +46,9 @@
(define (batch:dialect parms) ; was batch-family
(car (parameter-list-ref parms 'batch-dialect)))
+(define (batch:operating-system parms)
+ (car (parameter-list-ref parms 'operating-system)))
+
(define (write-batch-line str line-limit port)
(cond ((and line-limit (>= (string-length str) line-limit))
(slib:warn 'write-batch-line 'too-long
@@ -53,7 +59,7 @@
(write-batch-line str (batch:line-length-limit parms) (batch:port parms)))
;;; add a Scheme batch-dialect?
-
+;@
(define (batch:try-chopped-command parms . args)
(define args-but-last (batch:flatten (butlast args 1)))
(define line-limit (batch:line-length-limit parms))
@@ -65,7 +71,7 @@
(batch:try-command parms str))
((< (length fodder) 2)
(slib:warn 'batch:try-chopped-command "can't fit in " line-limit
- (cons proc (append args-but-last (list fodder))))
+ (append args-but-last (list fodder)))
#f)
(else (let ((hlen (quotient (length fodder) 2)))
(and (loop (last fodder hlen))
@@ -74,15 +80,15 @@
(define (batch:glued-line parms strings)
(case (batch:dialect parms)
((vms) (apply string-join " " "$" strings))
- ((unix dos amigados system *unknown*) (apply string-join " " strings))
+ ((unix dos amigaos system *unknown*) (apply string-join " " strings))
(else #f)))
-
+;@
(define (batch:try-command parms . strings)
(set! strings (batch:flatten strings))
(let ((line (batch:glued-line parms strings)))
(and line
(case (batch:dialect parms)
- ((unix dos vms amigados) (batch-line parms line))
+ ((unix dos vms amigaos) (batch-line parms line))
((system)
(let ((port (batch:port parms)))
(write `(system ,line) port) (newline port)
@@ -91,11 +97,11 @@
(let ((port (batch:port parms)))
(write `(system ,line) port) (newline port) #t))
(else #f)))))
-
+;@
(define (batch:command parms . strings)
(cond ((apply batch:try-command parms strings))
(else (slib:error 'batch:command 'failed strings))))
-
+;@
(define (batch:run-script parms name . strings)
(case (batch:dialect parms strings)
((vms) (batch:command parms (string-append "@" name) strings))
@@ -106,12 +112,12 @@
((unix) (write-batch-line (string-append "# " line) #f port))
((dos) (write-batch-line (string-append "rem " line) #f port))
((vms) (write-batch-line (string-append "$! " line) #f port))
- ((amigados) (write-batch-line (string-append "; " line) #f port))
+ ((amigaos) (write-batch-line (string-append "; " line) #f port))
((system) (write-batch-line (string-append "; " line) #f port))
((*unknown*) (write-batch-line (string-append ";;; " line) #f port)
;;(newline port)
#f)))
-
+;@
(define (batch:comment parms . lines)
(define port (batch:port parms))
(define dialect (batch:dialect parms))
@@ -119,7 +125,7 @@
(every (lambda (line)
(batch:write-comment-line dialect line port))
lines))
-
+;@
(define (batch:lines->file parms file . lines)
(define port (batch:port parms))
(set! lines (batch:flatten lines))
@@ -142,7 +148,7 @@
(every (lambda (string) (batch-line parms string))
lines)
(batch-line parms (string-append "$EOD"))))
- ((amigados) (batch-line parms (string-append "delete force " file))
+ ((amigaos) (batch-line parms (string-append "delete force " file))
(every
(lambda (str)
(letrec ((star-quote
@@ -162,7 +168,6 @@
lines))
((system) (write `(delete-file ,file) port) (newline port)
(delete-file file)
- (require 'pretty-print)
(pretty-print `(call-with-output-file ,file
(lambda (fp)
(for-each
@@ -175,7 +180,6 @@
#t)
((*unknown*)
(write `(delete-file ,file) port) (newline port)
- (require 'pretty-print)
(pretty-print
`(call-with-output-file ,file
(lambda (fp)
@@ -185,7 +189,7 @@
,lines)))
port)
#f)))
-
+;@
(define (batch:delete-file parms file)
(define port (batch:port parms))
(case (batch:dialect parms)
@@ -195,13 +199,13 @@
#t)
((vms) (batch-line parms (string-append "$DELETE " file))
#t)
- ((amigados) (batch-line parms (string-append "delete force " file))
+ ((amigaos) (batch-line parms (string-append "delete force " file))
#t)
((system) (write `(delete-file ,file) port) (newline port)
(delete-file file)) ; SLIB provides
((*unknown*) (write `(delete-file ,file) port) (newline port)
#f)))
-
+;@
(define (batch:rename-file parms old-name new-name)
(define port (batch:port parms))
(case (batch:dialect parms)
@@ -209,15 +213,18 @@
;;((dos) (batch-line parms (string-join " " "REN" old-name new-name)))
((dos) (batch-line parms (string-join " " "MOVE" "/Y" old-name new-name)))
((vms) (batch-line parms (string-join " " "$RENAME" old-name new-name)))
- ((amigados) (batch-line parms (string-join " " "failat 21"))
- (batch-line parms (string-join " " "delete force" new-name))
- (batch-line parms (string-join " " "rename" old-name new-name)))
+ ((amigaos) (batch-line parms (string-join " " "failat 21"))
+ (batch-line parms (string-join " " "delete force" new-name))
+ (batch-line parms (string-join " " "rename" old-name new-name)))
((system) (batch:extender 'rename-file batch:rename-file))
((*unknown*) (write `(rename-file ,old-name ,new-name) port)
(newline port)
#f)))
-(define (batch:write-header-comment dialect name port)
+(define (batch:write-header-comment parms name port)
+ (define dialect (batch:dialect parms))
+ (define operating-system
+ (or (batch:operating-system parms) *operating-system*))
(batch:write-comment-line
dialect
(string-append (if (string? name)
@@ -228,6 +235,7 @@
((dos) "DOS")
((default-for-platform) "??")
(else (symbol->string dialect))))
+ " (" (symbol->string operating-system) ")"
" script created by SLIB/batch "
(cond ((provided? 'bignum)
(require 'posix-time)
@@ -235,9 +243,11 @@
(substring ct 0 (+ -1 (string-length ct)))))
(else "")))
port))
-
+;@
(define (batch:call-with-output-script parms name proc)
(define dialect (batch:dialect parms))
+ (define operating-system
+ (or (batch:operating-system parms) *operating-system*))
(case dialect
((unix) ((cond ((and (string? name) (provided? 'system))
(lambda (proc)
@@ -247,8 +257,11 @@
((output-port? name) (lambda (proc) (proc name)))
(else (lambda (proc) (proc (current-output-port)))))
(lambda (port)
- (write-line "#!/bin/sh" port)
- (batch:write-header-comment dialect name port)
+ (write-line (if (eq? 'plan9 operating-system)
+ "#! /bin/rc"
+ "#! /bin/sh")
+ port)
+ (batch:write-header-comment parms name port)
(proc port))))
((dos) ((cond ((string? name)
@@ -257,7 +270,7 @@
((output-port? name) (lambda (proc) (proc name)))
(else (lambda (proc) (proc (current-output-port)))))
(lambda (port)
- (batch:write-header-comment dialect name port)
+ (batch:write-header-comment parms name port)
(proc port))))
((vms) ((cond ((string? name)
@@ -266,20 +279,20 @@
((output-port? name) (lambda (proc) (proc name)))
(else (lambda (proc) (proc (current-output-port)))))
(lambda (port)
- (batch:write-header-comment dialect name port)
+ (batch:write-header-comment parms name port)
;;(write-line "$DEFINE/USER SYS$OUTPUT BUILD.LOG" port)
(proc port))))
- ((amigados) ((cond ((and (string? name) (provided? 'system))
- (lambda (proc)
- (let ((ans (call-with-output-file name proc)))
- (system (string-append "protect " name " rswd"))
- ans)))
- ((output-port? name) (lambda (proc) (proc name)))
- (else (lambda (proc) (proc (current-output-port)))))
- (lambda (port)
- (batch:write-header-comment dialect name port)
- (proc port))))
+ ((amigaos) ((cond ((and (string? name) (provided? 'system))
+ (lambda (proc)
+ (let ((ans (call-with-output-file name proc)))
+ (system (string-append "protect " name " rswd"))
+ ans)))
+ ((output-port? name) (lambda (proc) (proc name)))
+ (else (lambda (proc) (proc (current-output-port)))))
+ (lambda (port)
+ (batch:write-header-comment parms name port)
+ (proc port))))
((system) ((cond ((and (string? name) (provided? 'system))
(lambda (proc)
@@ -290,7 +303,7 @@
((output-port? name) (lambda (proc) (proc name)))
(else (lambda (proc) (proc (current-output-port)))))
(lambda (port)
- (batch:write-header-comment dialect name port)
+ (batch:write-header-comment parms name port)
(proc port))))
((*unknown*) ((cond ((and (string? name) (provided? 'system))
@@ -302,7 +315,7 @@
((output-port? name) (lambda (proc) (proc name)))
(else (lambda (proc) (proc (current-output-port)))))
(lambda (port)
- (batch:write-header-comment dialect name port)
+ (batch:write-header-comment parms name port)
(proc port))))))
;;; This little ditty figures out how to use a Scheme extension or
@@ -321,8 +334,9 @@
(else
(let ((pl (make-parameter-list (map car parms))))
(adjoin-parameters!
- pl (cons 'batch-dialect (os->batch-dialect
- (parameter-list-ref parms 'platform))))
+ pl (cons 'batch-dialect
+ (os->batch-dialect
+ (parameter-list-ref parms 'operating-system))))
(system
(call-with-output-string
(lambda (port)
@@ -332,7 +346,7 @@
(define new-parms (copy-tree pl))
(adjoin-parameters! new-parms (list 'batch-port batch-port))
(apply BATCHER new-parms args)))))))))))
-
+;@
(define (truncate-up-to str chars)
(define (tut str)
(do ((i (string-length str) (+ -1 i)))
@@ -341,15 +355,15 @@
(cond ((char? chars) (set! chars (list chars)))
((string? chars) (set! chars (string->list chars))))
(if (string? str) (tut str) (map tut str)))
-
+;@
(define (must-be-first firsts lst)
(append (remove-if-not (lambda (i) (member i lst)) firsts)
(remove-if (lambda (i) (member i firsts)) lst)))
-
+;@
(define (must-be-last lst lasts)
(append (remove-if (lambda (i) (member i lasts)) lst)
(remove-if-not (lambda (i) (member i lst)) lasts)))
-
+;@
(define (string-join joiner . args)
(if (null? args) ""
(apply string-append
@@ -369,21 +383,15 @@
obj "in" strings))))
strings)))
-(define batch:platform (software-type))
-(cond ((and (eq? 'unix batch:platform) (provided? 'system))
- (let ((file-name (tmpnam)))
- (system (string-append "uname > " file-name))
- (set! batch:platform (call-with-input-file file-name read))
- (delete-file file-name))))
-
(define batch:database #f)
-(define os->batch-dialect #f)
(define batch-dialect->line-length-limit #f)
+;@
+(define os->batch-dialect #f)
(define (batch:line-length-limit parms)
(let ((bl (parameter-list-ref parms 'batch-line-length-limit)))
(if bl (car bl) (batch-dialect->line-length-limit (batch:dialect parms)))))
-
+;@
(define (batch:initialize! database)
(set! batch:database database)
(define-tables database
@@ -394,7 +402,7 @@
((unix 1023)
(dos 127)
(vms 1023)
- (amigados 511)
+ (amigaos 511)
(system 1023)
(*unknown* -1)))
@@ -406,7 +414,7 @@
(acorn *unknown*)
(aix unix)
(alliant *unknown*)
- (amiga amigados)
+ (amiga amigaos)
(apollo unix)
(apple2 *unknown*)
(arm *unknown*)
@@ -415,6 +423,7 @@
(celerity *unknown*)
(concurrent *unknown*)
(convex *unknown*)
+ (darwin unix)
(encore *unknown*)
(harris *unknown*)
(hp-ux unix)
@@ -432,6 +441,7 @@
(novell *unknown*)
(os/2 dos)
(osf1 unix)
+ (plan9 unix)
(prime *unknown*)
(psion *unknown*)
(pyramid *unknown*)
@@ -445,10 +455,29 @@
(vms vms)
)))
- ((database 'add-domain) '(operating-system operating-system #f symbol #f))
+ (define-domains database '(operating-system operating-system #f symbol #f))
(set! os->batch-dialect (((batch:database 'open-table) 'operating-system #f)
'get 'os-family))
(set! batch-dialect->line-length-limit
(((batch:database 'open-table) 'batch-dialect #f)
'get 'line-length-limit))
)
+;@
+(define *operating-system*
+ (cond ((and (eq? 'unix (software-type)) (provided? 'system))
+ (let* ((file-name (tmpnam))
+ (uname (and (system (string-append "uname > " file-name))
+ (call-with-input-file file-name read)))
+ (ustr (and (symbol? uname) (symbol->string uname))))
+ (delete-file file-name)
+ (cond ((and ustr
+ (> (string-length ustr) 5)
+ (string-ci=? "cygwin" (substring ustr 0 6)))
+ 'gnu-win32)
+ ((and ustr
+ (> (string-length ustr) 4)
+ (string-ci=? "mingw" (substring ustr 0 5)))
+ 'gnu-win32)
+ (ustr uname)
+ (else (software-type)))))
+ (else (software-type))))
diff --git a/bigloo.init b/bigloo.init
index 41a4179..9ded1a4 100644
--- a/bigloo.init
+++ b/bigloo.init
@@ -7,34 +7,29 @@
;;; (scheme-implementation-type) should return the name of the scheme
;;; implementation loading this file.
-
(define (scheme-implementation-type) 'Bigloo)
;;; (scheme-implementation-home-page) should return a (string) URI
;;; (Uniform Resource Identifier) for this scheme implementation's home
;;; page; or false if there isn't one.
-
(define (scheme-implementation-home-page)
- "http://kaolin.unice.fr/~serrano/bigloo/bigloo.html")
+ "http://www-sop.inria.fr/mimosa/fp/Bigloo/")
;;; (scheme-implementation-version) should return a string describing
;;; the version the scheme implementation loading this file.
-
-(define (scheme-implementation-version) "2.0c")
+(define (scheme-implementation-version) *bigloo-version*)
;;; (implementation-vicinity) should be defined to be the pathname of
;;; the directory where any auxillary files to your Scheme
;;; implementation reside.
-
(define (implementation-vicinity)
(case (software-type)
- ((UNIX) "/usr/local/lib/bigloo/")
- ((VMS) "scheme$src:")
- ((MS-DOS) "C:\\scheme\\")))
+ ((UNIX) (string-append *default-lib-dir* "/"))
+ ((MS-DOS) "C:\\scheme\\")
+ (else "")))
;;; (library-vicinity) should be defined to be the pathname of the
;;; directory where files of Scheme library functions reside.
-
(define library-vicinity
(let ((library-path
(or
@@ -43,8 +38,11 @@
;; Use this path if your scheme does not support GETENV
;; or if SCHEME_LIBRARY_PATH is not set.
(case (software-type)
- ((UNIX) "/usr/share/slib/")
- ((VMS) "lib$scheme:")
+ ((UNIX) (cond ((directory? "/usr/share/slib/")
+ "/usr/share/slib/")
+ ((directory? "/usr/local/lib/slib/")
+ "/usr/local/lib/slib/")
+ (else "")))
((MS-DOS) "C:\\SLIB\\")
(else "")))))
(lambda () library-path)))
@@ -52,15 +50,19 @@
;;; (home-vicinity) should return the vicinity of the user's HOME
;;; directory, the directory which typically contains files which
;;; customize a computer environment for a user.
-
-(define home-vicinity
- (let ((home-path (getenv "HOME")))
- (lambda () home-path)))
+(define (home-vicinity)
+ (let ((home (getenv "HOME")))
+ (and home
+ (case (software-type)
+ ((UNIX COHERENT MS-DOS) ;V7 unix has a / on HOME
+ (if (eqv? #\/ (string-ref home (+ -1 (string-length home))))
+ home
+ (string-append home "/")))
+ (else home)))))
;;; *FEATURES* should be set to a list of symbols describing features
;;; of this implementation. See Template.scm for the list of feature
;;; names.
-
(define *features*
'(
source ;can load scheme source files
@@ -70,7 +72,7 @@
;; Scheme report features
-; rev5-report ;conforms to
+; r5rs ;conforms to
eval ;R5RS two-argument eval
; values ;R5RS multiple values
; dynamic-wind ;R5RS dynamic-wind
@@ -84,11 +86,11 @@
;STRING-FILL!, LIST->VECTOR,
;VECTOR->LIST, and VECTOR-FILL!
- rev4-report ;conforms to
+ r4rs ;conforms to
ieee-p1178 ;conforms to
- rev3-report ;conforms to
+ r3rs ;conforms to
; rev2-procedures ;SUBSTRING-MOVE-LEFT!,
;SUBSTRING-MOVE-RIGHT!,
@@ -99,7 +101,7 @@
multiarg/and- ;/ and - can take more than 2 args.
with-file ;has WITH-INPUT-FROM-FILE and
- ;WITH-OUTPUT-FROM-FILE
+ ;WITH-OUTPUT-TO-FILE
transcript ;TRANSCRIPT-ON and TRANSCRIPT-OFF
ieee-floating-point ;conforms to IEEE Standard 754-1985
;IEEE Standard for Binary
@@ -170,6 +172,37 @@
(close-input-port insp)
res))
+(define (make-exchanger obj)
+ (lambda (rep) (let ((old obj)) (set! obj rep) old)))
+(define (open-file filename modes)
+ (case modes
+ ((r rb) (open-input-file filename))
+ ((w wb) (open-output-file filename))
+ (else (slib:error 'open-file 'mode? modes))))
+;;(define (port? obj) (or (input-port? port) (output-port? port)))
+(define (call-with-open-ports . ports)
+ (define proc (car ports))
+ (cond ((procedure? proc) (set! ports (cdr ports)))
+ (else (set! ports (reverse ports))
+ (set! proc (car ports))
+ (set! ports (reverse (cdr ports)))))
+ (let ((ans (apply proc ports)))
+ (for-each close-port ports)
+ ans))
+(define (close-port port)
+ (cond ((input-port? port)
+ (close-input-port port)
+ (if (output-port? port) (close-output-port port)))
+ ((output-port? port) (close-output-port port))
+ (else (slib:error 'close-port 'port? port))))
+
+(define (browse-url url)
+ (define (try cmd end) (zero? (system (string-append cmd url end))))
+ (or (try "netscape-remote -remote 'openURL(" ")'")
+ (try "netscape -remote 'openURL(" ")'")
+ (try "netscape '" "'&")
+ (try "netscape '" "'")))
+
;;; "rationalize" adjunct procedures.
(define (find-ratio x e)
(let ((rat (rationalize x e)))
@@ -216,7 +249,7 @@
(let ((cep (current-error-port)))
(if (provided? 'trace) (print-call-stack cep))
(display "Warn: " cep)
- (for-each (lambda (x) (display x cep)) args))))
+ (for-each (lambda (x) (display #\ cep) (write x cep)) args))))
;;; define an error procedure for the library
@@ -238,7 +271,7 @@
))
-(define (promise:force p) (force p))
+;;(define force force)
;;; Define these if your implementation's syntax can support it and if
;;; they are not already defined.
@@ -262,17 +295,14 @@
;;; (SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever
;;; suffix all the module files in SLIB have. See feature 'SOURCE.
-
(define (slib:load-source f) (loadq (string-append f (scheme-file-suffix))))
;;; (SLIB:LOAD-COMPILED "foo") should load the file that was produced
;;; by compiling "foo.scm" if this implementation can compile files.
;;; See feature 'COMPILED.
-
(define slib:load-compiled loadq)
;;; At this point SLIB:LOAD must be able to load SLIB files.
-
(define slib:load slib:load-source)
(define defmacro:eval slib:eval)
diff --git a/break.scm b/break.scm
index 4d18efc..d62eeb6 100644
--- a/break.scm
+++ b/break.scm
@@ -1,5 +1,5 @@
;;;; "break.scm" Breakpoints for debugging in Scheme.
-;;; Copyright (C) 1991, 1992, 1993, 1995 Aubrey Jaffer
+;;; Copyright (C) 1991, 1992, 1993, 1995, 2003 Aubrey Jaffer
;
;Permission to copy this software, to modify it, to redistribute it,
;to distribute modified versions, and to use it for any purpose is
@@ -8,7 +8,7 @@
;1. Any copy made of this software must include this copyright notice
;in full.
;
-;2. I have made no warrantee or representation that the operation of
+;2. I have made no warranty or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
@@ -18,6 +18,7 @@
;each case.
(require 'qp)
+(require 'alist)
;;;; BREAKPOINTS
@@ -29,8 +30,8 @@
;;; of breakpoint:continuation-stack and returns #f to it.
(define breakpoint:continuation-stack '())
-
-(define debug:breakpoint
+;@
+(define breakpoint
(let ((call-with-current-continuation call-with-current-continuation)
(apply apply) (qpn qpn)
(cons cons) (length length))
@@ -45,8 +46,8 @@
(debug:top-continuation
(length breakpoint:continuation-stack))))))
(cond ((not (eq? ans breakpoint:continuation-stack)) ans))))))
-
-(define debug:continue
+;@
+(define continue
(let ((null? null?) (car car) (cdr cdr))
(lambda args
(cond ((null? breakpoint:continuation-stack)
@@ -63,21 +64,17 @@
(if (provided? 'abort)
(lambda (val) (display val) (newline) (abort))
(begin (display "; type (init-debug)") #f)))
-
+;@
(define (init-debug)
(call-with-current-continuation
(lambda (x) (set! debug:top-continuation x))))
-
-(define breakpoint debug:breakpoint)
-(define bkpt debug:breakpoint)
-(define continue debug:continue)
-
+;@
(define breakf
(let ((null? null?) ;These bindings are so that
(not not) ;breakf will not break on parts
(car car) (cdr cdr) ;of itself.
(eq? eq?) (+ +) (zero? zero?) (modulo modulo)
- (apply apply) (display display) (breakpoint debug:breakpoint))
+ (apply apply) (display display) (breakpoint breakpoint))
(lambda (function . optname)
;; (set! trace:indent 0)
(let ((name (if (null? optname) function (car optname))))
@@ -92,7 +89,7 @@
;;; the reason I use a symbol for debug:unbreak-object is so
;;; that functions can still be unbreaked if this file is read in twice.
-
+;@
(define (unbreakf function)
;; (set! trace:indent 0)
(function 'debug:unbreak-object))
@@ -101,7 +98,6 @@
;;; niceties like keeping track of breakd functions and dealing with
;;; redefinition.
-(require 'alist)
(define break:adder (alist-associator eq?))
(define break:deler (alist-remover eq?))
@@ -131,9 +127,8 @@
((eq? (cdr p) fun)
(unbreakf fun))
(else fun))))
-
;;;; Finally, the macros break and unbreak
-
+;@
(defmacro break xs
(if (null? xs)
`(begin ,@(map (lambda (x) `(set! ,x (break:breakf ,x ',x)))
diff --git a/byte.scm b/byte.scm
index b34816d..b7e12da 100644
--- a/byte.scm
+++ b/byte.scm
@@ -1,15 +1,219 @@
;;; "byte.scm" small integers, not necessarily chars.
+; Copyright (c) 2001, 2002, 2003 Aubrey Jaffer
+;
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
+;
+;1. Any copy made of this software must include this copyright notice
+;in full.
+;
+;2. I have made no warranty or representation that the operation of
+;this software will be error-free, and I am under no obligation to
+;provide any services, by way of maintenance, update, or otherwise.
+;
+;3. In conjunction with products arising from the use of this
+;material, there shall be no use of my name in any advertising,
+;promotional, or sales literature without prior written consent in
+;each case.
-(define (byte-ref str ind) (char->integer (string-ref str ind)))
-(define (byte-set! str ind val) (string-set! str ind (integer->char val)))
+;;@code{(require 'byte)}
+;;@ftindex byte
+;;
+;;@noindent
+;;Some algorithms are expressed in terms of arrays of small integers.
+;;Using Scheme strings to implement these arrays is not portable vis-a-vis
+;;the correspondence between integers and characters and non-ascii
+;;character sets. These functions abstract the notion of a @dfn{byte}.
+;;@cindex byte
+
+;;@body
+;;@2 must be a valid index of @1. @0 returns byte @2 of @1 using
+;;zero-origin indexing.
+(define (byte-ref bytes k) (char->integer (string-ref bytes k)))
+
+;;@body
+;;@2 must be a valid index of @1, and @var{byte} must be a small
+;;nonnegative integer. @0 stores @var{byte} in element @2 of @1 and
+;;returns an unspecified value. @c <!>
+(define (byte-set! bytes k byte) (string-set! bytes k (integer->char byte)))
+
+;;@args k byte
+;;@args k
+;;@0 returns a newly allocated byte-array of length @1. If @2 is
+;;given, then all elements of the byte-array are initialized to @2,
+;;otherwise the contents of the byte-array are unspecified.
(define (make-bytes len . opt)
(if (null? opt) (make-string len)
(make-string len (integer->char (car opt)))))
+
+;;@args bytes
+;;@0 returns length of byte-array @1.
(define bytes-length string-length)
+
+;;@args byte @dots{}
+;;Returns a newly allocated byte-array composed of the small
+;;nonnegative arguments.
+(define (bytes . args) (list->bytes args))
+
+;;@args bytes
+;;@0 returns a newly allocated list of the bytes that make up the
+;;given byte-array.
+(define (bytes->list bts) (map char->integer (string->list bts)))
+
+;;@args bytes
+;;@0 returns a newly allocated byte-array formed from the small
+;;nonnegative integers in the list @1.
+(define (list->bytes lst) (list->string (map integer->char lst)))
+
+;;@noindent
+;;@code{Bytes->list} and @code{list->bytes} are inverses so far as
+;;@code{equal?} is concerned.
+;;@findex equal?
+
+;;@args bytes
+;;Returns a newly allocated copy of the given @1.
+(define bytes-copy string-copy)
+
+;;@body
+;;Reverses the order of byte-array @1.
+(define (bytes-reverse! bytes)
+ (do ((idx 0 (+ 1 idx))
+ (xdi (+ -1 (bytes-length bytes)) (+ -1 xdi)))
+ ((>= idx xdi) bytes)
+ (let ((tmp (byte-ref bytes idx)))
+ (byte-set! bytes idx (byte-ref bytes xdi))
+ (byte-set! bytes xdi tmp))))
+
+;;@body
+;;Returns a newly allocated bytes-array consisting of the elements of
+;;@1 in reverse order.
+(define (bytes-reverse bytes)
+ (bytes-reverse! (bytes-copy bytes)))
+
+;;@noindent
+;;@cindex binary
+;;Input and output of bytes should be with ports opened in @dfn{binary}
+;;mode (@pxref{Input/Output}). Calling @code{open-file} with @r{'rb} or
+;;@findex open-file
+;;@r{'wb} modes argument will return a binary port if the Scheme
+;;implementation supports it.
+
+;;@args byte port
+;;@args byte
+;;Writes the byte @1 (not an external representation of the byte) to
+;;the given @2 and returns an unspecified value. The @2 argument may
+;;be omitted, in which case it defaults to the value returned by
+;;@code{current-output-port}.
+;;@findex current-output-port
(define (write-byte byt . opt) (apply write-char (integer->char byt) opt))
+
+;;@args port
+;;@args
+;;Returns the next byte available from the input @1, updating the @1
+;;to point to the following byte. If no more bytes are available, an
+;;end-of-file object is returned. @1 may be omitted, in which case it
+;;defaults to the value returned by @code{current-input-port}.
+;;@findex current-input-port
(define (read-byte . opt)
(let ((c (apply read-char opt)))
(if (eof-object? c) c (char->integer c))))
-(define (bytes . args) (list->bytes args))
-(define (bytes->list bts) (map char->integer (string->list bts)))
-(define (list->bytes lst) (list->string (map integer->char lst)))
+
+;;@noindent
+;;When reading and writing binary numbers with @code{read-bytes} and
+;;@code{write-bytes}, the sign of the length argument determines the
+;;endianness (order) of bytes. Positive treats them as big-endian,
+;;the first byte input or output is highest order. Negative treats
+;;them as little-endian, the first byte input or output is the lowest
+;;order.
+;;
+;;@noindent
+;;Once read in, SLIB treats byte sequences as big-endian. The
+;;multi-byte sequences produced and used by number conversion routines
+;;@pxref{Byte/Number Conversions} are always big-endian.
+
+;;@args n port
+;;@args n
+;;@0 returns a newly allocated bytes-array filled with
+;;@code{(abs @var{n})} bytes read from @2. If @1 is positive, then
+;;the first byte read is stored at index 0; otherwise the last byte
+;;read is stored at index 0. Note that the length of the returned
+;;string will be less than @code{(abs @var{n})} if @2 reaches
+;;end-of-file.
+;;
+;;@2 may be omitted, in which case it defaults to the value returned
+;;by @code{current-input-port}.
+(define (read-bytes n . port)
+ (let* ((len (abs n))
+ (byts (make-bytes len))
+ (cnt (if (positive? n)
+ (apply substring-read! byts 0 n port)
+ (apply substring-read! byts (- n) 0 port))))
+ (if (= cnt len)
+ byts
+ (if (positive? n)
+ (substring byts 0 cnt)
+ (substring byts (- len cnt) len)))))
+
+;;@args bytes n port
+;;@args bytes n
+;;@0 writes @code{(abs @var{n})} bytes to output-port @3. If @2 is
+;;positive, then the first byte written is index 0 of @1; otherwise
+;;the last byte written is index 0 of @1. @0 returns an unspecified
+;;value.
+;;
+;;@3 may be omitted, in which case it defaults to the value returned
+;;by @code{current-output-port}.
+(define (write-bytes bytes n . port)
+ (if (positive? n)
+ (apply substring-write bytes 0 n port)
+ (apply substring-write bytes (- n) 0 port)))
+
+;;@noindent
+;;@code{substring-read!} and @code{substring-write} provide
+;;lower-level procedures for reading and writing blocks of bytes. The
+;;relative size of @var{start} and @var{end} determines the order of
+;;writing.
+
+;;@args string start end port
+;;@args string start end
+;;Fills @1 with up to @code{(abs (- @var{start} @var{end}))} bytes
+;;read from @4. The first byte read is stored at index @1.
+;;@0 returns the number of bytes read.
+;;
+;;@4 may be omitted, in which case it defaults to the value returned
+;;by @code{current-input-port}.
+(define (substring-read! string start end . port)
+ (if (>= end start)
+ (do ((idx start (+ 1 idx)))
+ ((>= idx end) idx)
+ (let ((byt (apply read-byte port)))
+ (cond ((eof-object? byt)
+ (set! idx (+ -1 idx))
+ (set! end idx))
+ (else (byte-set! string idx byt)))))
+ (do ((idx (+ -1 start) (+ -1 idx))
+ (cnt 0 (+ 1 cnt)))
+ ((< idx end) cnt)
+ (let ((byt (apply read-byte port)))
+ (cond ((eof-object? byt)
+ (set! idx start)
+ (set! cnt (+ -1 cnt)))
+ (else (byte-set! string idx byt)))))))
+
+;;@args string start end port
+;;@args string start end
+;;@0 writes @code{(abs (- @var{start} @var{end}))} bytes to
+;;output-port @4. The first byte written is index @2 of @1. @0
+;;returns the number of bytes written.
+;;
+;;@4 may be omitted, in which case it defaults to the value returned
+;;by @code{current-output-port}.
+(define (substring-write string start end . port)
+ (if (>= end start)
+ (do ((idx start (+ 1 idx)))
+ ((>= idx end) (- end start))
+ (apply write-byte (byte-ref string idx) port))
+ (do ((idx (+ -1 start) (+ -1 idx)))
+ ((< idx end) (- start end))
+ (apply write-byte (byte-ref string idx) port))))
diff --git a/byte.txi b/byte.txi
new file mode 100644
index 0000000..01c725b
--- /dev/null
+++ b/byte.txi
@@ -0,0 +1,179 @@
+@code{(require 'byte)}
+@ftindex byte
+
+@noindent
+Some algorithms are expressed in terms of arrays of small integers.
+Using Scheme strings to implement these arrays is not portable vis-a-vis
+the correspondence between integers and characters and non-ascii
+character sets. These functions abstract the notion of a @dfn{byte}.
+@cindex byte
+@cindex byte
+
+
+@defun byte-ref bytes k
+
+@var{k} must be a valid index of @var{bytes}. @code{byte-ref} returns byte @var{k} of @var{bytes} using
+zero-origin indexing.
+@end defun
+
+@deffn {Procedure} byte-set! bytes k byte
+
+@var{k} must be a valid index of @var{bytes}, and @var{byte} must be a small
+nonnegative integer. @code{byte-set!} stores @var{byte} in element @var{k} of @var{bytes} and
+returns an unspecified value. @c <!>
+@end deffn
+
+@defun make-bytes k byte
+
+
+@defunx make-bytes k
+@code{make-bytes} returns a newly allocated byte-array of length @var{k}. If @var{byte} is
+given, then all elements of the byte-array are initialized to @var{byte},
+otherwise the contents of the byte-array are unspecified.
+@end defun
+
+@defun bytes-length bytes
+
+@code{bytes-length} returns length of byte-array @var{bytes}.
+@end defun
+
+@defun bytes byte @dots{}
+
+Returns a newly allocated byte-array composed of the small
+nonnegative arguments.
+@end defun
+
+@defun bytes->list bytes
+
+@code{bytes->list} returns a newly allocated list of the bytes that make up the
+given byte-array.
+@end defun
+
+@defun list->bytes bytes
+
+@code{list->bytes} returns a newly allocated byte-array formed from the small
+nonnegative integers in the list @var{bytes}.
+@end defun
+@noindent
+@code{Bytes->list} and @code{list->bytes} are inverses so far as
+@code{equal?} is concerned.
+@findex equal?
+
+
+@defun bytes-copy bytes
+
+Returns a newly allocated copy of the given @var{bytes}.
+@end defun
+
+@deffn {Procedure} bytes-reverse! bytes
+
+Reverses the order of byte-array @var{bytes}.
+@end deffn
+
+@defun bytes-reverse bytes
+
+Returns a newly allocated bytes-array consisting of the elements of
+@var{bytes} in reverse order.
+@end defun
+@noindent
+@cindex binary
+Input and output of bytes should be with ports opened in @dfn{binary}
+@cindex binary
+mode (@pxref{Input/Output}). Calling @code{open-file} with @r{'rb} or
+@findex open-file
+@r{'wb} modes argument will return a binary port if the Scheme
+implementation supports it.
+
+
+@defun write-byte byte port
+
+
+@defunx write-byte byte
+Writes the byte @var{byte} (not an external representation of the byte) to
+the given @var{port} and returns an unspecified value. The @var{port} argument may
+be omitted, in which case it defaults to the value returned by
+@code{current-output-port}.
+@findex current-output-port
+@end defun
+
+@defun read-byte port
+
+
+@defunx read-byte
+Returns the next byte available from the input @var{port}, updating the @var{port}
+to point to the following byte. If no more bytes are available, an
+end-of-file object is returned. @var{port} may be omitted, in which case it
+defaults to the value returned by @code{current-input-port}.
+@findex current-input-port
+@end defun
+@noindent
+When reading and writing binary numbers with @code{read-bytes} and
+@code{write-bytes}, the sign of the length argument determines the
+endianness (order) of bytes. Positive treats them as big-endian,
+the first byte input or output is highest order. Negative treats
+them as little-endian, the first byte input or output is the lowest
+order.
+
+@noindent
+Once read in, SLIB treats byte sequences as big-endian. The
+multi-byte sequences produced and used by number conversion routines
+@pxref{Byte/Number Conversions} are always big-endian.
+
+
+@defun read-bytes n port
+
+
+@defunx read-bytes n
+@code{read-bytes} returns a newly allocated bytes-array filled with
+@code{(abs @var{n})} bytes read from @var{port}. If @var{n} is positive, then
+the first byte read is stored at index 0; otherwise the last byte
+read is stored at index 0. Note that the length of the returned
+string will be less than @code{(abs @var{n})} if @var{port} reaches
+end-of-file.
+
+@var{port} may be omitted, in which case it defaults to the value returned
+by @code{current-input-port}.
+@end defun
+
+@defun write-bytes bytes n port
+
+
+@defunx write-bytes bytes n
+@code{write-bytes} writes @code{(abs @var{n})} bytes to output-port @var{port}. If @var{n} is
+positive, then the first byte written is index 0 of @var{bytes}; otherwise
+the last byte written is index 0 of @var{bytes}. @code{write-bytes} returns an unspecified
+value.
+
+@var{port} may be omitted, in which case it defaults to the value returned
+by @code{current-output-port}.
+@end defun
+@noindent
+@code{substring-read!} and @code{substring-write} provide
+lower-level procedures for reading and writing blocks of bytes. The
+relative size of @var{start} and @var{end} determines the order of
+writing.
+
+
+@deffn {Procedure} substring-read! string start end port
+
+
+@deffnx {Procedure} substring-read! string start end
+Fills @var{string} with up to @code{(abs (- @var{start} @var{end}))} bytes
+read from @var{port}. The first byte read is stored at index @var{string}.
+@code{substring-read!} returns the number of bytes read.
+
+@var{port} may be omitted, in which case it defaults to the value returned
+by @code{current-input-port}.
+@end deffn
+
+@defun substring-write string start end port
+
+
+@defunx substring-write string start end
+@code{substring-write} writes @code{(abs (- @var{start} @var{end}))} bytes to
+output-port @var{port}. The first byte written is index @var{start} of @var{string}. @code{substring-write}
+returns the number of bytes written.
+
+@var{port} may be omitted, in which case it defaults to the value returned
+by @code{current-output-port}.
+@end defun
diff --git a/bytenumb.scm b/bytenumb.scm
new file mode 100644
index 0000000..68ee748
--- /dev/null
+++ b/bytenumb.scm
@@ -0,0 +1,346 @@
+;;; "bytenumb.scm" Byte integer and IEEE floating-point conversions.
+; Copyright (c) 2003 Aubrey Jaffer
+;
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
+;
+;1. Any copy made of this software must include this copyright notice
+;in full.
+;
+;2. I have made no warranty or representation that the operation of
+;this software will be error-free, and I am under no obligation to
+;provide any services, by way of maintenance, update, or otherwise.
+;
+;3. In conjunction with products arising from the use of this
+;material, there shall be no use of my name in any advertising,
+;promotional, or sales literature without prior written consent in
+;each case.
+
+(require 'byte)
+(require 'logical)
+
+(define bn:expt
+ (if (provided? 'inexact) expt
+ (lambda (n k) (if (negative? k) 0 (integer-expt n k)))))
+
+;;@code{(require 'byte-number)}
+;;@ftindex byte-number
+
+;;@noindent
+;;The multi-byte sequences produced and used by numeric conversion
+;;routines are always big-endian. Endianness can be changed during
+;;reading and writing bytes using @code{read-bytes} and
+;;@code{write-bytes} @xref{Byte, read-bytes}.
+;;
+;;@noindent
+;;The sign of the length argument to bytes/integer conversion
+;;procedures determines the signedness of the number.
+
+;;@body
+;;Converts the first @code{(abs @var{n})} bytes of big-endian @1 array
+;;to an integer. If @2 is negative then the integer coded by the
+;;bytes are treated as two's-complement (can be negative).
+;;
+;;@example
+;;(bytes->integer (bytes 0 0 0 15) -4) @result{} 15
+;;(bytes->integer (bytes 0 0 0 15) 4) @result{} 15
+;;(bytes->integer (bytes 255 255 255 255) -4) @result{} -1
+;;(bytes->integer (bytes 255 255 255 255) 4) @result{} 4294967295
+;;(bytes->integer (bytes 128 0 0 0) -4) @result{} -2147483648
+;;(bytes->integer (bytes 128 0 0 0) 4) @result{} 2147483648
+;;@end example
+(define (bytes->integer bytes n)
+ (define cnt (abs n))
+ (cond ((zero? n) 0)
+ ((and (negative? n) (> (byte-ref bytes 0) 127))
+ (do ((lng (- 255 (byte-ref bytes 0))
+ (+ (- 255 (byte-ref bytes idx)) (* 256 lng)))
+ (idx 1 (+ 1 idx)))
+ ((>= idx cnt) (- -1 lng))))
+ (else
+ (do ((lng (byte-ref bytes 0)
+ (+ (byte-ref bytes idx) (* 256 lng)))
+ (idx 1 (+ 1 idx)))
+ ((>= idx cnt) lng)))))
+
+;;@body
+;;Converts the integer @1 to a byte-array of @code{(abs @var{n})}
+;;bytes. If @1 and @2 are both negative, then the bytes in the
+;;returned array are coded two's-complement.
+;;
+;;@example
+;;(bytes->list (integer->bytes 15 -4)) @result{} (0 0 0 15)
+;;(bytes->list (integer->bytes 15 4)) @result{} (0 0 0 15)
+;;(bytes->list (integer->bytes -1 -4)) @result{} (255 255 255 255)
+;;(bytes->list (integer->bytes 4294967295 4)) @result{} (255 255 255 255)
+;;(bytes->list (integer->bytes -2147483648 -4)) @result{} (128 0 0 0)
+;;(bytes->list (integer->bytes 2147483648 4)) @result{} (128 0 0 0)
+;;@end example
+(define (integer->bytes n len)
+ (define bytes (make-bytes (abs len)))
+ (cond ((and (negative? n) (negative? len))
+ (do ((idx (+ -1 (abs len)) (+ -1 idx))
+ (res (- -1 n) (quotient res 256)))
+ ((negative? idx) bytes)
+ (byte-set! bytes idx (- 255 (modulo res 256)))))
+ (else
+ (do ((idx (+ -1 (abs len)) (+ -1 idx))
+ (res n (quotient res 256)))
+ ((negative? idx) bytes)
+ (byte-set! bytes idx (modulo res 256))))))
+
+;;@body
+;;@1 must be a 4-element byte-array. @0 calculates and returns the
+;;value of @1 interpreted as a big-endian IEEE 4-byte (32-bit) number.
+(define (bytes->ieee-float bytes)
+ (define zero (or (string->number "0.0") 0))
+ (define one (or (string->number "1.0") 1))
+ (define len (bytes-length bytes))
+ (define S (logbit? 7 (byte-ref bytes 0)))
+ (define E (+ (ash (logand #x7F (byte-ref bytes 0)) 1)
+ (ash (logand #x80 (byte-ref bytes 1)) -7)))
+ (if (not (eqv? 4 len))
+ (slib:error 'bytes->ieee-float 'wrong 'length len))
+ (do ((F (byte-ref bytes (+ -1 len))
+ (+ (byte-ref bytes idx) (/ F 256)))
+ (idx (+ -2 len) (+ -1 idx)))
+ ((<= idx 1)
+ (set! F (/ (+ (logand #x7F (byte-ref bytes 1)) (/ F 256)) 128))
+ (cond ((< 0 E 255) (* (if S -1 1) (bn:expt 2 (- E 127)) (+ 1 F)))
+ ((zero? E)
+ (if (zero? F)
+ (if S (- zero) zero)
+ (* (if S -1 1) (expt 2 -126) F)))
+ ;; E must be 255
+ ((not (zero? F)) (/ zero zero))
+ (else (/ (if S (- one) one) zero))))))
+
+;; S EEEEEEE E FFFFFFF FFFFFFFF FFFFFFFF
+;; ========= ========= ======== ========
+;; 0 1 8 9 31
+
+;;@example
+;;(bytes->ieee-float (bytes #x40 0 0 0)) @result{} 2.0
+;;(bytes->ieee-float (bytes #x40 #xd0 0 0)) @result{} 6.5
+;;(bytes->ieee-float (bytes #xc0 #xd0 0 0)) @result{} -6.5
+;;
+;;(bytes->ieee-float (bytes 0 #x80 0 0)) @result{} 11.754943508222875e-39
+;;(bytes->ieee-float (bytes 0 #x40 0 0)) @result{} 5.877471754111437e-39
+;;(bytes->ieee-float (bytes 0 0 0 1)) @result{} 1.401298464324817e-45
+;;
+;;(bytes->ieee-float (bytes #xff #x80 0 0)) @result{} -1/0
+;;(bytes->ieee-float (bytes #x7f #x80 0 0)) @result{} 1/0
+;;(bytes->ieee-float (bytes #x7f #x80 0 1)) @result{} 0/0
+;;@end example
+
+;;@body
+;;@1 must be a 8-element byte-array. @0 calculates and returns the
+;;value of @1 interpreted as a big-endian IEEE 8-byte (64-bit) number.
+(define (bytes->ieee-double bytes)
+ (define zero (or (string->number "0.0") 0))
+ (define one (or (string->number "1.0") 1))
+ (define len (bytes-length bytes))
+ (define S (logbit? 7 (byte-ref bytes 0)))
+ (define E (+ (ash (logand #x7F (byte-ref bytes 0)) 4)
+ (ash (logand #xF0 (byte-ref bytes 1)) -4)))
+ (if (not (eqv? 8 len))
+ (slib:error 'bytes->ieee-double 'wrong 'length len))
+ (do ((F (byte-ref bytes (+ -1 len))
+ (+ (byte-ref bytes idx) (/ F 256)))
+ (idx (+ -2 len) (+ -1 idx)))
+ ((<= idx 1)
+ (set! F (/ (+ (logand #x0F (byte-ref bytes 1)) (/ F 256)) 16))
+ (cond ((< 0 E 2047) (* (if S -1 1) (bn:expt 2 (- E 1023)) (+ 1 F)))
+ ((zero? E)
+ (if (zero? F)
+ (if S (- zero) zero)
+ (* (if S -1 1) (expt 2 -1022) F)))
+ ;; E must be 2047
+ ((not (zero? F)) (/ zero zero))
+ (else (/ (if S (- one) one) zero))))))
+
+;; S EEEEEEE EEEE FFFF FFFFFFFF FFFFFFFF FFFFFFFF FFFFFFFF FFFFFFFF FFFFFFFF
+;; ========= ========= ======== ======== ======== ======== ======== ========
+;; 0 1 11 12 63
+
+;;@example
+;;(bytes->ieee-double (bytes 0 0 0 0 0 0 0 0)) @result{} 0.0
+;;(bytes->ieee-double (bytes #x40 0 0 0 0 0 0 0)) @result{} 2
+;;(bytes->ieee-double (bytes #x40 #x1A 0 0 0 0 0 0)) @result{} 6.5
+;;(bytes->ieee-double (bytes #xC0 #x1A 0 0 0 0 0 0)) @result{} -6.5
+;;
+;;(bytes->ieee-double (bytes 0 8 0 0 0 0 0 0)) @result{} 11.125369292536006e-309
+;;(bytes->ieee-double (bytes 0 4 0 0 0 0 0 0)) @result{} 5.562684646268003e-309
+;;(bytes->ieee-double (bytes 0 0 0 0 0 0 0 1)) @result{} 4.0e-324
+;;
+;;(bytes->ieee-double (bytes #xFF #xF0 0 0 0 0 0 0)) @result{} -1/0
+;;(bytes->ieee-double (bytes #x7F #xF0 0 0 0 0 0 0)) @result{} 1/0
+;;(bytes->ieee-double (bytes #x7F #xF8 0 0 0 0 0 0)) @result{} 0/0
+;;@end example
+
+;;@args x
+;;Returns a 4-element byte-array encoding the IEEE single-precision
+;;floating-point of @1.
+(define ieee-float->bytes
+ (let ((zero (or (string->number "0.0") 0))
+ (exactify (if (provided? 'inexact) inexact->exact identity)))
+ (lambda (flt)
+ (define byts (make-bytes 4 0))
+ (define S (negative? flt))
+ (define (scale flt scl)
+ (cond ((zero? scl) (out (/ flt 2) scl))
+ ((zero? flt) byts)
+ ((>= flt 16)
+ (let ((flt/16 (/ flt 16)))
+ (cond ((= flt/16 flt)
+ (byte-set! byts 0 (if S #xFF #x7F))
+ (byte-set! byts 1 (if (= flt (* zero flt)) #xC0 #x80))
+ byts)
+ (else (scale flt/16 (+ scl 4))))))
+ ((>= flt 2) (scale (/ flt 2) (+ scl 1)))
+ ((and (>= scl 4)
+ (< (* 16 flt) 1)) (scale (* flt 16) (+ scl -4)))
+ ((< flt 1) (scale (* flt 2) (+ scl -1)))
+ (else (out (+ -1 flt) scl))))
+ (define (out flt scl)
+ (do ((flt (* 128 flt) (* 256 (- flt val)))
+ (val (exactify (floor (* 128 flt)))
+ (exactify (floor (* 256 (- flt val)))))
+ (idx 1 (+ 1 idx)))
+ ((> idx 3)
+ (byte-set! byts 1 (bitwise-if #x80 (ash scl 7) (byte-ref byts 1)))
+ (byte-set! byts 0 (+ (if S 128 0) (ash scl -1)))
+ byts)
+ (byte-set! byts idx val)))
+ (scale (abs flt) 127))))
+;;@example
+;;(bytes->list (ieee-float->bytes 2.0)) @result{} (64 0 0 0)
+;;(bytes->list (ieee-float->bytes 6.5)) @result{} (64 208 0 0)
+;;(bytes->list (ieee-float->bytes -6.5)) @result{} (192 208 0 0)
+;;
+;;(bytes->list (ieee-float->bytes 11.754943508222875e-39)) @result{} ( 0 128 0 0)
+;;(bytes->list (ieee-float->bytes 5.877471754111438e-39)) @result{} ( 0 64 0 0)
+;;(bytes->list (ieee-float->bytes 1.401298464324817e-45)) @result{} ( 0 0 0 1)
+;;
+;;(bytes->list (ieee-float->bytes -1/0)) @result{} (255 128 0 0)
+;;(bytes->list (ieee-float->bytes 1/0)) @result{} (127 128 0 0)
+;;(bytes->list (ieee-float->bytes 0/0)) @result{} (127 128 0 1)
+;;@end example
+
+
+;;@args x
+;;Returns a 8-element byte-array encoding the IEEE double-precision
+;;floating-point of @1.
+(define ieee-double->bytes
+ (let ((zero (or (string->number "0.0") 0))
+ (exactify (if (provided? 'inexact) inexact->exact identity)))
+ (lambda (flt)
+ (define byts (make-bytes 8 0))
+ (define S (negative? flt))
+ (define (scale flt scl)
+ (cond ((zero? scl) (out (/ flt 2) scl))
+ ((zero? flt) byts)
+ ((>= flt 16)
+ (let ((flt/16 (/ flt 16)))
+ (cond ((= flt/16 flt)
+ (byte-set! byts 0 (if S #xFF #x7F))
+ (byte-set! byts 1 (if (= flt (* zero flt)) #xF8 #xF0))
+ byts)
+ (else (scale flt/16 (+ scl 4))))))
+ ((>= flt 2) (scale (/ flt 2) (+ scl 1)))
+ ((and (>= scl 4)
+ (< (* 16 flt) 1)) (scale (* flt 16) (+ scl -4)))
+ ((< flt 1) (scale (* flt 2) (+ scl -1)))
+ (else (out (+ -1 flt) scl))))
+ (define (out flt scl)
+ (do ((flt (* 16 flt) (* 256 (- flt val)))
+ (val (exactify (floor (* 16 flt)))
+ (exactify (floor (* 256 (- flt val)))))
+ (idx 1 (+ 1 idx)))
+ ((> idx 7)
+ (byte-set! byts 1 (bitwise-if #xF0 (ash scl 4) (byte-ref byts 1)))
+ (byte-set! byts 0 (+ (if S 128 0) (ash scl -4)))
+ byts)
+ (byte-set! byts idx val)))
+ (scale (abs flt) 1023))))
+;;@example
+;;(bytes->list (ieee-double->bytes 2.0)) @result{} (64 0 0 0 0 0 0 0)
+;;(bytes->list (ieee-double->bytes 6.5)) @result{} (64 26 0 0 0 0 0 0)
+;;(bytes->list (ieee-double->bytes -6.5)) @result{} (192 26 0 0 0 0 0 0)
+;;
+;;(bytes->list (ieee-double->bytes 11.125369292536006e-309))
+;; @result{} ( 0 8 0 0 0 0 0 0)
+;;(bytes->list (ieee-double->bytes 5.562684646268003e-309))
+;; @result{} ( 0 4 0 0 0 0 0 0)
+;;(bytes->list (ieee-double->bytes 4.0e-324))
+;; @result{} ( 0 0 0 0 0 0 0 1)
+;;
+;;(bytes->list (ieee-double->bytes -1/0)) @result{} (255 240 0 0 0 0 0 0)
+;;(bytes->list (ieee-double->bytes 1/0)) @result{} (127 240 0 0 0 0 0 0)
+;;(bytes->list (ieee-double->bytes 0/0)) @result{} (127 248 0 0 0 0 0 0)
+;;@end example
+
+;;@subsubheading Byte Collation Order
+;;
+;;@noindent
+;;The @code{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
diff --git a/chap.scm b/chap.scm
index 0d8f99f..1766720 100644
--- a/chap.scm
+++ b/chap.scm
@@ -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)))
diff --git a/chez.init b/chez.init
index 44acba8..19d796e 100644
--- a/chez.init
+++ b/chez.init
@@ -8,36 +8,30 @@
;;; (software-type) should be set to the generic operating system type.
;;; UNIX, VMS, MACOS, AMIGA and MS-DOS are supported.
-
(define (software-type) 'UNIX)
;;; (scheme-implementation-type) should return the name of the scheme
;;; implementation loading this file.
-
(define (scheme-implementation-type) 'chez)
;;; (scheme-implementation-home-page) should return a (string) URI
;;; (Uniform Resource Identifier) for this scheme implementation's home
;;; page; or false if there isn't one.
-
(define (scheme-implementation-home-page)
- "http://www.cs.indiana.edu/chezscheme/")
+ "http://www.scheme.com/")
;;; (scheme-implementation-version) should return a string describing
;;; the version the scheme implementation loading this file.
-
(define (scheme-implementation-version) "6.0a")
;;; (implementation-vicinity) should be defined to be the pathname of
;;; the directory where any auxillary files to your Scheme
;;; implementation reside.
-
(define implementation-vicinity
(lambda () "/usr/unsup/scheme/chez/"))
;;; (library-vicinity) should be defined to be the pathname of the
;;; directory where files of Scheme library functions reside.
-
(define library-vicinity
(let ((library-path
(or
@@ -55,14 +49,18 @@
;;; (home-vicinity) should return the vicinity of the user's HOME
;;; directory, the directory which typically contains files which
;;; customize a computer environment for a user.
-
-(define home-vicinity
- (let ((home-path (getenv "HOME")))
- (lambda () home-path)))
+(define (home-vicinity)
+ (let ((home (getenv "HOME")))
+ (and home
+ (case (software-type)
+ ((UNIX COHERENT MS-DOS) ;V7 unix has a / on HOME
+ (if (eqv? #\/ (string-ref home (+ -1 (string-length home))))
+ home
+ (string-append home "/")))
+ (else home)))))
;;; *FEATURES* should be set to a list of symbols describing features
;;; of this implementation. Suggestions for features are:
-
(define *features*
'(
source ;can load scheme source files
@@ -72,7 +70,7 @@
;; Scheme report features
- rev5-report ;conforms to
+ r5rs ;conforms to
eval ;R5RS two-argument eval
values ;R5RS multiple values
dynamic-wind ;R5RS dynamic-wind
@@ -86,11 +84,11 @@
;STRING-FILL!, LIST->VECTOR,
;VECTOR->LIST, and VECTOR-FILL!
- rev4-report ;conforms to
+ r4rs ;conforms to
ieee-p1178 ;conforms to
- rev3-report ;conforms to
+ r3rs ;conforms to
; rev2-procedures ;SUBSTRING-MOVE-LEFT!,
;SUBSTRING-MOVE-RIGHT!,
@@ -101,7 +99,7 @@
multiarg/and- ;/ and - can take more than 2 args.
with-file ;has WITH-INPUT-FROM-FILE and
- ;WITH-OUTPUT-FROM-FILE
+ ;WITH-OUTPUT-TO-FILE
transcript ;TRANSCRIPT-ON and TRANSCRIPT-OFF
; ieee-floating-point ;conforms to IEEE Standard 754-1985
;IEEE Standard for Binary
@@ -132,13 +130,12 @@
;; Implementation Specific features
+;;; random ;Not the same as SLIB random
fluid-let
- random
))
;;; (OUTPUT-PORT-WIDTH <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
diff --git a/cltime.scm b/cltime.scm
index d22922c..76d06d2 100644
--- a/cltime.scm
+++ b/cltime.scm
@@ -8,7 +8,7 @@
;1. Any copy made of this software must include this copyright notice
;in full.
;
-;2. I have made no warrantee or representation that the operation of
+;2. I have made no warranty or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
@@ -22,13 +22,13 @@
(require 'posix-time)
(define time:1900 (time:invert time:gmtime '#(0 0 0 1 0 0 #f #f 0 0 "GMT")))
-
+;@
(define (get-decoded-time)
(decode-universal-time (get-universal-time)))
-
+;@
(define (get-universal-time)
(difftime (current-time) time:1900))
-
+;@
(define (decode-universal-time utime . tzarg)
(let ((tv (apply time:split
(offset-time time:1900 utime)
@@ -48,7 +48,7 @@
(inexact->exact (/ (vector-ref tv 9) 3600))
(/ (vector-ref tv 9) 3600)) ;time-zone [-24..24]
)))
-
+;@
(define (encode-universal-time second minute hour date month year . tzarg)
(let* ((tz (if (null? tzarg)
(tzset)
diff --git a/coerce.scm b/coerce.scm
index 83023df..7505f3f 100644
--- a/coerce.scm
+++ b/coerce.scm
@@ -8,7 +8,7 @@
;1. Any copy made of this software must include this copyright notice
;in full.
;
-;2. I have made no warrantee or representation that the operation of
+;2. I have made no warranty or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
diff --git a/collect.scm b/collect.scm
index 35a333d..05bc2cf 100644
--- a/collect.scm
+++ b/collect.scm
@@ -2,49 +2,55 @@
; COPYRIGHT (c) Kenneth Dickey 1992
;
; This software may be used for any purpose whatever
-; without warrantee of any kind.
+; without warranty of any kind.
; AUTHOR Ken Dickey
; DATE 1992 September 1
; LAST UPDATED 1992 September 2
; NOTES Expository (optimizations & checks elided).
; Requires YASOS (Yet Another Scheme Object System).
+(require 'object)
(require 'yasos)
-(define-operation (collect:collection? obj)
+(define collect:size size)
+(define collect:print print)
+
+;@
+(define-operation (collection? obj)
;; default
(cond
((or (list? obj) (vector? obj) (string? obj)) #t)
(else #f)
) )
-
-(define (collect:empty? collection) (zero? (yasos:size collection)))
-
-(define-operation (collect:gen-elts <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
diff --git a/crc.scm b/crc.scm
new file mode 100644
index 0000000..423622b
--- /dev/null
+++ b/crc.scm
@@ -0,0 +1,137 @@
+;;;; "crc.scm" Compute Cyclic Checksums
+;;; Copyright (C) 1995, 1996, 1997, 2001, 2002 Aubrey Jaffer
+;
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
+;
+;1. Any copy made of this software must include this copyright notice
+;in full.
+;
+;2. I have made no warranty or representation that the operation of
+;this software will be error-free, and I am under no obligation to
+;provide any services, by way of maintenance, update, or otherwise.
+;
+;3. In conjunction with products arising from the use of this
+;material, there shall be no use of my name in any advertising,
+;promotional, or sales literature without prior written consent in
+;each case.
+
+(require 'byte)
+(require 'logical)
+
+;;@ (define CRC-32-polynomial "100000100100000010001110110110111") ; IEEE-802, FDDI
+(define CRC-32-polynomial "100000100110000010001110110110111") ; IEEE-802, AAL5
+;@
+(define CRC-CCITT-polynomial "10001000000100001") ; X25
+;@
+(define CRC-16-polynomial "11000000000000101") ; IBM Bisync, HDLC, SDLC, USB-Data
+
+;;@ (define CRC-12-polynomial "1100000001101")
+(define CRC-12-polynomial "1100000001111")
+
+;;@ (define CRC-10-polynomial "11000110001")
+(define CRC-10-polynomial "11000110011")
+;@
+(define CRC-08-polynomial "100000111")
+;@
+(define ATM-HEC-polynomial "100000111")
+;@
+(define DOWCRC-polynomial "100110001")
+;@
+(define USB-Token-polynomial "100101")
+
+;;This procedure is careful not to use more than DEG bits in
+;;computing (- (expt 2 DEG) 1). It returns #f if the integer would
+;;be larger than the implementation supports.
+(define (crc:make-mask deg)
+ (string->number (make-string deg #\1) 2))
+;@
+(define (crc:make-table str)
+ (define deg (+ -1 (string-length str)))
+ (define generator (string->number (substring str 1 (string-length str)) 2))
+ (define crctab (make-vector 256))
+ (if (not (eqv? #\1 (string-ref str 0)))
+ (slib:error 'crc:make-table 'first-digit-of-polynomial-must-be-1 str))
+ (if (< deg 8)
+ (slib:error 'crc:make-table 'degree-must-be>7 deg str))
+ (and
+ generator
+ (do ((i 0 (+ 1 i))
+ (deg-1-mask (crc:make-mask (+ -1 deg)))
+ (gen generator
+ (if (logbit? (+ -1 deg) gen)
+ (logxor (ash (logand deg-1-mask gen) 1) generator)
+ (ash (logand deg-1-mask gen) 1)))
+ (gens '() (cons gen gens)))
+ ((>= i 8) (set! gens (reverse gens))
+ (do ((crc 0 0)
+ (m 0 (+ 1 m)))
+ ((> m 255) crctab)
+ (for-each (lambda (gen i)
+ (set! crc (if (logbit? i m) (logxor crc gen) crc)))
+ gens '(0 1 2 3 4 5 6 7))
+ (vector-set! crctab m crc))))))
+
+(define crc-32-table (crc:make-table CRC-32-polynomial))
+
+;;@ Computes the P1003.2/D11.2 (POSIX.2) 32-bit checksum.
+(define (cksum file)
+ (cond ((not crc-32-table) #f)
+ ((input-port? file) (cksum-port file))
+ (else (call-with-input-file file cksum-port))))
+
+(define cksum-port
+ (let ((mask-24 (crc:make-mask 24))
+ (mask-32 (crc:make-mask 32)))
+ (lambda (port)
+ (define crc 0)
+ (define (accumulate-crc byt)
+ (set! crc
+ (logxor (ash (logand mask-24 crc) 8)
+ (vector-ref crc-32-table (logxor (ash crc -24) byt)))))
+ (do ((byt (read-byte port) (read-byte port))
+ (byte-count 0 (+ 1 byte-count)))
+ ((eof-object? byt)
+ (do ((byte-count byte-count (ash byte-count -8)))
+ ((zero? byte-count) (logxor mask-32 crc))
+ (accumulate-crc (logand #xff byte-count))))
+ (accumulate-crc byt)))))
+;@
+(define (crc16 file)
+ (cond ((not crc-16-table) #f)
+ ((input-port? file) (crc16-port file))
+ (else (call-with-input-file file crc16-port))))
+
+(define crc-16-table (crc:make-table CRC-16-polynomial))
+
+(define crc16-port
+ (let ((mask-8 (crc:make-mask 8))
+ (mask-16 (crc:make-mask 16)))
+ (lambda (port)
+ (define crc mask-16)
+ (define (accumulate-crc byt)
+ (set! crc
+ (logxor (ash (logand mask-8 crc) 8)
+ (vector-ref crc-16-table (logxor (ash crc -8) byt)))))
+ (do ((byt (read-byte port) (read-byte port)))
+ ((eof-object? byt) (logxor mask-16 crc))
+ (accumulate-crc byt)))))
+;@
+(define (crc5 file)
+ (cond ((input-port? file) (crc5-port file))
+ (else (call-with-input-file file crc5-port))))
+
+(define (crc5-port port)
+ (define generator #b00101)
+ (define crc #b11111)
+ (do ((byt (read-byte port) (read-byte port)))
+ ((eof-object? byt) (logxor #b11111 crc))
+ (do ((data byt (ash data 1))
+ (len (+ -1 8) (+ -1 len)))
+ ((negative? len))
+ (set! crc
+ (logand #b11111
+ (if (eqv? (logbit? 7 data) (logbit? 4 crc))
+ (ash crc 1)
+ (logxor (ash crc 1) generator)))))))
diff --git a/cring.scm b/cring.scm
index dfbb027..97a637d 100644
--- a/cring.scm
+++ b/cring.scm
@@ -1,5 +1,5 @@
;;;"cring.scm" Extend Scheme numerics to any commutative ring.
-;Copyright (C) 1997, 1998 Aubrey Jaffer
+;Copyright (C) 1997, 1998, 2001 Aubrey Jaffer
;
;Permission to copy this software, to modify it, to redistribute it,
;to distribute modified versions, and to use it for any purpose is
@@ -8,7 +8,7 @@
;1. Any copy made of this software must include this copyright notice
;in full.
;
-;2. I have made no warrantee or representation that the operation of
+;2. I have made no warranty or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
@@ -19,10 +19,21 @@
(require 'common-list-functions)
(require 'relational-database)
-(require 'database-utilities)
+(require 'databases)
(require 'sort)
+(require-if '(not inexact) 'logical) ;for integer-expt
+(define number^ (if (provided? 'inexact) expt integer-expt))
+
+(define number* *)
+(define number+ +)
+(define number- -)
+(define number/ /)
+(define number0? zero?)
+(define (zero? x) (and (number? x) (number0? x)))
+;;(define (sign x) (if (positive? x) 1 (if (negative? x) -1 0)))
(define cring:db (create-database #f 'alist-table))
+;@
(define (make-ruleset . rules)
(define name #f)
(cond ((and (not (null? rules)) (symbol? (car rules)))
@@ -41,12 +52,13 @@
(list (table 'get 'reduction)
(table 'row:update)
table))))
+;@
(define *ruleset* (make-ruleset 'default))
(define (cring:define-rule . args)
(if *ruleset*
((cadr *ruleset*) args)
(slib:warn "No ruleset in *ruleset*")))
-
+;@
(define (combined-rulesets . rulesets)
(define name #f)
(cond ((symbol? (car rulesets))
@@ -59,6 +71,7 @@
rulesets))))
;;; Distribute * over + (and -)
+;@
(define distribute*
(make-ruleset
'distribute*
@@ -72,6 +85,7 @@
(apply - (map (lambda (trm) (* trm exp2)) (cdr exp1)))))))
;;; Distribute / over + (and -)
+;@
(define distribute/
(make-ruleset
'distribute/
@@ -103,15 +117,7 @@
(else (expression-< (cdr x) (cdr y)))))
(define (expression-sort seq) (sort! seq expression-<))
-(define number* *)
-(define number+ +)
-(define number- -)
-(define number/ /)
-(define number^ integer-expt)
(define is-term-op? (lambda (term op) (and (pair? term) (eq? op (car term)))))
-;;(define (sign x) (if (positive? x) 1 (if (negative? x) -1 0)))
-(define number0? zero?)
-(define (zero? x) (and (number? x) (number0? x)))
;; To convert to CR internal form, NUMBER-op all the `numbers' in the
;; argument list and remove them from the argument list. Collect the
diff --git a/cvs.scm b/cvs.scm
new file mode 100644
index 0000000..f1c853c
--- /dev/null
+++ b/cvs.scm
@@ -0,0 +1,140 @@
+;;;;"cvs.scm" enumerate files under CVS control.
+;;; Copyright 2002 Aubrey Jaffer
+;
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
+;
+;1. Any copy made of this software must include this copyright notice
+;in full.
+;
+;2. I have made no warranty or representation that the operation of
+;this software will be error-free, and I am under no obligation to
+;provide any services, by way of maintenance, update, or otherwise.
+;
+;3. In conjunction with products arising from the use of this
+;material, there shall be no use of my name in any advertising,
+;promotional, or sales literature without prior written consent in
+;each case.
+
+(require 'scanf)
+(require 'line-i/o)
+(require 'string-search)
+
+;;@body Returns a list of the local pathnames (with prefix @1) of all
+;;CVS controlled files in @1 and in @1's subdirectories.
+(define (cvs-files directory/)
+ (cvs:entries directory/ #t))
+
+;;@body Returns a list of all of @1 and all @1's CVS controlled
+;;subdirectories.
+(define (cvs-directories directory/)
+ (and (file-exists? (in-vicinity directory/ "CVS/Entries"))
+ (cons directory/ (cvs:entries directory/ #f))))
+
+(define (cvs:entries directory do-files?)
+ (define files '())
+ (define cvse (in-vicinity directory "CVS/Entries"))
+ (define cvsel (in-vicinity directory "CVS/Entries.Log"))
+ (set! directory (substring directory
+ (if (eqv? 0 (substring? "./" directory)) 2 0)
+ (string-length directory)))
+ (if (file-exists? cvse)
+ (call-with-input-file cvse
+ (lambda (port)
+ (do ((line (read-line port) (read-line port)))
+ ((eof-object? line))
+ (let ((fname #f))
+ (cond ((eqv? 1 (sscanf line "/%[^/]" fname))
+ (and do-files?
+ (set! files
+ (cons (in-vicinity directory fname) files))))
+ ((eqv? 1 (sscanf line "D/%[^/]" fname))
+ (set! files
+ (append (cvs:entries (sub-vicinity directory fname)
+ do-files?)
+ (if do-files? '()
+ (list (sub-vicinity directory fname)))
+ files))))))))
+ (slib:warn 'cvs:entries 'missing cvse))
+ (set! files (reverse files))
+ (if (file-exists? cvsel)
+ (call-with-input-file cvsel
+ (lambda (port)
+ (do ((line (read-line port) (read-line port)))
+ ((eof-object? line) files)
+ (let ((fname #f))
+ (cond ((eqv? 1 (sscanf line "A D/%[^/]/" fname))
+ (set! files
+ (append files
+ (if do-files? '()
+ (list (sub-vicinity directory fname)))
+ (cvs:entries (sub-vicinity directory fname)
+ do-files?)))))))))
+ files))
+
+;;@body Returns the (string) contents of @var{path/}CVS/Root;
+;;or @code{(getenv "CVSROOT")} if Root doesn't exist.
+(define (cvs-root path/)
+ (if (not (vicinity:suffix? (string-ref path/ (+ -1 (string-length path/)))))
+ (slib:error 'missing 'vicinity-suffix path/))
+ (let ((rootpath (string-append path/ "CVS/Root")))
+ (if (file-exists? rootpath)
+ (call-with-input-file rootpath read-line)
+ (getenv "CVSROOT"))))
+
+;;@body Returns the (string) contents of @var{directory/}CVS/Root appended
+;;with @var{directory/}CVS/Repository; or #f if @var{directory/}CVS/Repository
+;;doesn't exist.
+(define (cvs-repository directory/)
+ (let ((root (cvs-root directory/))
+ (repath (in-vicinity (sub-vicinity directory/ "CVS/") "Repository")))
+ (define root/idx (substring? "/" root))
+ (define rootlen (string-length root))
+ (and
+ root/idx
+ (file-exists? repath)
+ (let ((repos (call-with-input-file repath read-line)))
+ (define replen (and (string? repos) (string-length repos)))
+ (cond ((not (and replen (< 1 replen))) #f)
+ ((not (char=? #\/ (string-ref repos 0)))
+ (string-append root "/" repos))
+ ((eqv? 0 (substring? (substring root root/idx rootlen) repos))
+ (string-append
+ root
+ (substring repos (- rootlen root/idx) replen)))
+ (else (slib:error 'mismatched root repos)))))))
+
+;;@body
+;;Writes @1 to file CVS/Root of @2 and all its subdirectories.
+(define (cvs-set-root! new-root directory/)
+ (define root (cvs-root directory/))
+ (define repos (cvs-repository directory/))
+ (if (not repos) (slib:error 'not 'cvs directory/))
+ (if (not (eqv? 0 (substring? root repos)))
+ (slib:error 'bad 'cvs root repos))
+ (call-with-output-file
+ (in-vicinity (sub-vicinity directory/ "CVS") "Root")
+ (lambda (port) (write-line new-root port)))
+ (call-with-output-file
+ (in-vicinity (sub-vicinity directory/ "CVS") "Repository")
+ (lambda (port)
+ (write-line
+ (substring repos (+ 1 (string-length root)) (string-length repos))
+ port))))
+
+;;@body
+;;Signals an error if CVS/Repository or CVS/Root files in @1 or any
+;;subdirectory do not match.
+(define (cvs-vet directory/)
+ (define diroot (cvs-root directory/))
+ (for-each
+ (lambda (path/)
+ (define path/CVS (sub-vicinity path/ "CVS/"))
+ (cond ((not (cvs-repository path/))
+ (slib:error 'bad (in-vicinity path/CVS "Repository")))
+ ((not (equal? diroot (cvs-root path/)))
+ (slib:error 'mismatched 'root (in-vicinity path/CVS "Root")))))
+ (or (cvs-directories directory/) (slib:error 'not 'cvs directory/))))
+
+;;(define cvs-rsh (or (getenv "CVS_RSH") "rsh"))
diff --git a/cvs.txi b/cvs.txi
new file mode 100644
index 0000000..0ff1656
--- /dev/null
+++ b/cvs.txi
@@ -0,0 +1,32 @@
+
+@defun cvs-files directory/
+Returns a list of the local pathnames (with prefix @var{directory/}) of all
+CVS controlled files in @var{directory/} and in @var{directory/}'s subdirectories.
+@end defun
+
+@defun cvs-directories directory/
+Returns a list of all of @var{directory/} and all @var{directory/}'s CVS controlled
+subdirectories.
+@end defun
+
+@defun cvs-root path/
+Returns the (string) contents of @var{path/}CVS/Root;
+or @code{(getenv "CVSROOT")} if Root doesn't exist.
+@end defun
+
+@defun cvs-repository directory/
+Returns the (string) contents of @var{directory/}CVS/Root appended
+with @var{directory/}CVS/Repository; or #f if @var{directory/}CVS/Repository
+doesn't exist.
+@end defun
+
+@deffn {Procedure} cvs-set-root! new-root directory/
+
+Writes @var{new-root} to file CVS/Root of @var{directory/} and all its subdirectories.
+@end deffn
+
+@defun cvs-vet directory/
+
+Signals an error if CVS/Repository or CVS/Root files in @var{directory/} or any
+subdirectory do not match.
+@end defun
diff --git a/daylight.scm b/daylight.scm
new file mode 100644
index 0000000..6c989b2
--- /dev/null
+++ b/daylight.scm
@@ -0,0 +1,356 @@
+;;; "daylight.scm" Model of sun and sky colors.
+; Copyright 2001 Aubrey Jaffer
+;
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
+;
+;1. Any copy made of this software must include this copyright notice
+;in full.
+;
+;2. I have made no warranty or representation that the operation of
+;this software will be error-free, and I am under no obligation to
+;provide any services, by way of maintenance, update, or otherwise.
+;
+;3. In conjunction with products arising from the use of this
+;material, there shall be no use of my name in any advertising,
+;promotional, or sales literature without prior written consent in
+;each case.
+
+(require 'color-space)
+
+(define pi (* 4 (atan 1)))
+(define pi/180 (/ pi 180))
+
+;;@code{(require 'daylight)}
+;;@ftindex daylight
+;;@ftindex sunlight
+;;@ftindex sun
+;;@ftindex sky
+;;
+;;@noindent
+;;This package calculates the colors of sky as detailed in:@*
+;;@uref{http://www.cs.utah.edu/vissim/papers/sunsky/sunsky.pdf}@*
+;;@cite{A Practical Analytic Model for Daylight}@*
+;;A. J. Preetham, Peter Shirley, Brian Smits
+
+;;@body
+;;
+;;Returns the solar-time in hours given the integer @1 in the range 1 to
+;;366, and the local time in hours.
+;;
+;;To be meticulous, subtract 4 minutes for each degree of longitude west
+;;of the standard meridian of your time zone.
+(define (solar-hour julian-day hour)
+ (+ hour
+ (* 0.170 (sin (* 4 pi (- julian-day 80) 1/373)))
+ (* -0.129 (sin (* 2 pi (- julian-day 8) 1/355)))))
+
+;;@body
+(define (solar-declination julian-day)
+ (/ (* 0.4093 (sin (* 2 pi (- julian-day 81) 1/368))) pi/180))
+
+;;@body Returns a list of @var{theta_s}, the solar angle from the
+;;zenith, and @var{phi_s}, the solar azimuth. 0 <= @var{theta_s}
+;;measured in degrees. @var{phi_s} is measured in degrees from due
+;;south; west of south being positive.
+(define (solar-polar declination latitude solar-hour)
+ (define l (* pi/180 latitude))
+ (define d (* pi/180 declination))
+ (define pi*t/12 (* pi solar-hour 1/12))
+ (map (lambda (x) (/ x pi/180))
+ (list (- (/ pi 2) (asin (- (* (sin l) (sin d))
+ (* (cos l) (cos d) (cos pi*t/12)))))
+ (atan (* -1 (cos d) (sin pi*t/12))
+ (- (* (cos l) (sin d))
+ (* (sin l) (cos d) (cos pi*t/12)))))))
+
+;;@noindent
+;;In the following procedures, the number 0 <= @var{theta_s} <= 90 is
+;;the solar angle from the zenith in degrees.
+
+;;(plot (lambda (t) (+ -.5 (/ 9 (expt 1.55 t)))) 0 6) ;tweaked
+
+;;@cindex turbidity
+;;@noindent
+;;Turbidity is a measure of the fraction of scattering due to haze as
+;;opposed to molecules. This is a convenient quantity because it can be
+;;estimated based on visibility of distant objects. This model fails
+;;for turbidity values less than 1.3.
+;;
+;;@example
+;;@group
+;; _______________________________________________________________
+;;512|-: |
+;; | * pure-air |
+;;256|-:** |
+;; | : ** exceptionally-clear |
+;;128|-: * |
+;; | : ** |
+;; 64|-: * |
+;; | : ** very-clear |
+;; 32|-: ** |
+;; | : ** |
+;; 16|-: *** clear |
+;; | : **** |
+;; 8|-: **** |
+;; | : **** light-haze |
+;; 4|-: **** |
+;; | : ****** |
+;; 2|-: ******** haze thin-|
+;; | : *********** fog |
+;; 1|-:----------------------------------------------------*******--|
+;; |_:____.____:____.____:____.____:____.____:____.____:____.____:_|
+;; 1 2 4 8 16 32 64
+;; Meterorological range (km) versus Turbidity
+;;@end group
+;;@end example
+
+(define sol-spec
+ '#(16559.0
+ 16233.7
+ 21127.5
+ 25888.2
+ 25829.1
+ 24232.3
+ 26760.5
+ 29658.3
+ 30545.4
+ 30057.5
+ 30663.7
+ 28830.4
+ 28712.1
+ 27825.0
+ 27100.6
+ 27233.6
+ 26361.3
+ 25503.8
+ 25060.2
+ 25311.6
+ 25355.9
+ 25134.2
+ 24631.5
+ 24173.2
+ 23685.3
+ 23212.1
+ 22827.7
+ 22339.8
+ 21970.2
+ 21526.7
+ 21097.9
+ 20728.3
+ 20240.4
+ 19870.8
+ 19427.2
+ 19072.4
+ 18628.9
+ 18259.2
+ 17960 ;guesses for the rest
+ 17730
+ 17570))
+
+(define k_o-spec
+ '#(0.003
+ 0.006
+ 0.009
+ 0.014
+ 0.021
+ 0.03
+ 0.04
+ 0.048
+ 0.063
+ 0.075
+ 0.085
+ 0.103
+ 0.12
+ 0.12
+ 0.115
+ 0.125
+ 0.12
+ 0.105
+ 0.09
+ 0.079
+ 0.067
+ 0.057
+ 0.048
+ 0.036
+ 0.028
+ 0.023
+ 0.018
+ 0.014
+ 0.011
+ 0.01
+ 0.009
+ 0.007
+ 0.004
+ 0))
+
+;;@body Returns a vector of 41 values, the spectrum of sunlight from
+;;380.nm to 790.nm for a given @1 and @2.
+(define (sunlight-spectrum turbidity theta_s)
+ (define (solCurve wl) (vector-ref sol-spec (quotient (- wl 380) 10)))
+ (define (k_oCurve wl) (if (>= wl 450)
+ (vector-ref k_o-spec (quotient (- wl 450) 10))
+ 0))
+ (define (k_gCurve wl) (case wl
+ ((760) 3.0)
+ ((770) 0.21)
+ (else 0)))
+ (define (k_waCurve wl) (case wl
+ ((690) 0.016)
+ ((700) 0.024)
+ ((710) 0.0125)
+ ((720) 1)
+ ((730) 0.87)
+ ((740) 0.061)
+ ((750) 0.001)
+ ((760) 1.e-05)
+ ((770) 1.e-05)
+ ((780) 0.0006)
+ (else 0)))
+
+ (define data (make-vector (+ 1 (quotient (- 780 380) 10)) 0.0))
+ ;;alpha - ratio of small to large particle sizes. (0:4,usually 1.3)
+ (define alpha 1.3)
+ ;;beta - amount of aerosols present
+ (define beta (- (* 0.04608365822050 turbidity) 0.04586025928522))
+ ;;lOzone - amount of ozone in cm(NTP)
+ (define lOzone .35)
+ ;;w - precipitable water vapor in centimeters (standard = 2)
+ (define w 2.0)
+ ;;m - Relative Optical Mass
+ (define m (/ (+ (cos (* pi/180 theta_s))
+ (* 0.15 (expt (- 93.885 theta_s) -1.253)))))
+ (and
+ (not (negative? (- 93.885 theta_s)))
+ ;; Compute specturm of sunlight
+ (do ((wl 780 (+ -5 wl)))
+ ((< wl 380) data)
+ (let* (;;Rayleigh Scattering
+ ;; paper and program disagree!! Looks like font-size typo in paper.
+ ;;(tauR (exp (* -0.008735 (expt (/ wl 1000) (* -4.08 m))))) ;sunsky.pdf
+ (tauR (exp (* -0.008735 m (expt (/ wl 1000) -4.08)))) ;RiSunConstants.C
+ ;;Aerosal (water + dust) attenuation
+ ;; paper and program disagree!! Looks like font-size typo in paper.
+ ;;(tauA (exp (* -1 beta (expt (/ wl 1000) (* -1 m alpha)))))
+ (tauA (exp (* -1 m beta (expt (/ wl 1000) (- alpha)))))
+ ;;Attenuation due to ozone absorption
+ (tauO (exp (* -1 m (k_oCurve wl) lOzone)))
+ ;;Attenuation due to mixed gases absorption
+ (tauG (exp (* -1.41 m (k_gCurve wl)
+ (expt (+ 1 (* 118.93 m (k_gCurve wl))) -0.45))))
+ ;;Attenuation due to water vapor absorbtion
+ (tauWA (exp (* -0.2385 m w (k_waCurve wl)
+ (expt (+ 1 (* 20.07 m w (k_waCurve wl))) -0.45)))))
+ (vector-set! data (quotient (- wl 380) 10)
+ (* (solCurve wl) tauR tauA tauO tauG tauWA))))))
+
+;;@body Returns (unnormalized) XYZ values for color of sunlight for a
+;;given @1 and @2.
+(define (sunlight-XYZ turbidity theta_s)
+ (define spectrum (sunlight-spectrum turbidity theta_s))
+ (and spectrum (spectrum->XYZ spectrum 380.e-9 780.e-9)))
+
+;;@body Given @1 and @2, @0 returns the CIEXYZ triple for color of
+;;sunlight scaled to be just inside the RGB709 gamut.
+(define (sunlight-CIEXYZ turbidity theta_s)
+ (define spectrum (sunlight-spectrum turbidity theta_s))
+ (and spectrum (spectrum->CIEXYZ spectrum 380.e-9 780.e-9)))
+
+;; Arguments and result in radians
+(define (angle-between theta phi theta_s phi_s)
+ (define cospsi (+ (* (sin theta) (sin theta_s) (cos (- phi phi_s)))
+ (* (cos theta) (cos theta_s))))
+ (cond ((> cospsi 1) 0)
+ ((< cospsi -1) pi)
+ (else (acos cospsi))))
+
+;;@body Returns the xyY (chromaticity and luminance) at the zenith. The
+;;Luminance has units kcd/m^2.
+(define (zenith-xyY turbidity theta_s)
+ (let* ((ths (* theta_s pi/180))
+ (thetas (do ((th 1 (* ths th))
+ (lst '() (cons th lst))
+ (cnt 3 (+ -1 cnt)))
+ ((negative? cnt) lst)))
+ (turbds (do ((tr 1 (* turbidity tr))
+ (lst '() (cons tr lst))
+ (cnt 2 (+ -1 cnt)))
+ ((negative? cnt) lst))))
+ (append (map (lambda (row) (apply + (map * row turbds)))
+ (map color:linear-transform
+ '(((+0.00165 -0.00374 +0.00208 +0 )
+ (-0.02902 +0.06377 -0.03202 +0.00394)
+ (+0.11693 -0.21196 +0.06052 +0.25885))
+ ((+0.00275 -0.00610 +0.00316 +0 )
+ (-0.04214 +0.08970 -0.04153 +0.00515)
+ (+0.15346 -0.26756 +0.06669 +0.26688)))
+ (list thetas thetas)))
+ (list (+ (* (tan (* (+ 4/9 (/ turbidity -120)) (+ pi (* -2 ths))))
+ (- (* 4.0453 turbidity) 4.9710))
+ (* -0.2155 turbidity)
+ 2.4192)))))
+
+;;@body @1 is a positive real number expressing the amount of light
+;;scattering. The real number @2 is the solar angle from the zenith in
+;;degrees.
+;;
+;;@0 returns a function of one angle @var{theta}, the angle from the
+;;zenith of the viewing direction (in degrees); and returning the xyY
+;;value for light coming from that elevation of the sky.
+(define (overcast-sky-color-xyY turbidity theta_s)
+ (define xyY_z (zenith-xyY turbidity theta_s))
+ (lambda (theta . phi)
+ (list (car xyY_z) (cadr xyY_z)
+ (* 1/3 (caddr xyY_z) (+ 1 (* 2 (cos (* pi/180 theta))))))))
+
+;;@body @1 is a positive real number expressing the amount of light
+;;scattering. The real number @2 is the solar angle from the zenith in
+;;degrees. The real number @3 is the solar angle from south.
+;;
+;;@0 returns a function of two angles, @var{theta} and @var{phi} which
+;;specify the angles from the zenith and south meridian of the viewing
+;;direction (in degrees); returning the xyY value for light coming from
+;;that direction of the sky.
+;;
+;;@code{sky-color-xyY} calls @code{overcast-sky-color-xyY} for
+;;@1 <= 20; otherwise the @0 function.
+(define (clear-sky-color-xyY turbidity theta_s phi_s)
+ (define xyY_z (zenith-xyY turbidity theta_s))
+ (define th_s (* pi/180 theta_s))
+ (define ph_s (* pi/180 phi_s))
+ (define (F~ A B C D E)
+ (lambda (th gm)
+ (* (+ 1 (* A (exp (/ B (cos th)))))
+ (+ 1 (* C (exp (* D gm))) (* E (expt (cos gm) 2))))))
+ (let* ((tb1 (list turbidity 1))
+ (Fs (map (lambda (mat) (apply F~ (color:linear-transform mat tb1)))
+ '((( 0.17872 -1.46303)
+ (-0.35540 +0.42749)
+ (-0.02266 +5.32505)
+ ( 0.12064 -2.57705)
+ (-0.06696 +0.37027))
+ ((-0.01925 -0.25922)
+ (-0.06651 +0.00081)
+ (-0.00041 +0.21247)
+ (-0.06409 -0.89887)
+ (-0.00325 +0.04517))
+ ((-0.01669 -0.26078)
+ (-0.09495 +0.00921)
+ (-0.00792 +0.21023)
+ (-0.04405 -1.65369)
+ (-0.01092 +0.05291)))))
+ (F_0s (map (lambda (F) (F 0 th_s)) Fs)))
+ (lambda (theta phi)
+ (let* ((th (* pi/180 theta))
+ (ph (* pi/180 phi))
+ (gm (angle-between th_s ph_s th ph)))
+ ;;(print th ph '=> gm)
+ (map (lambda (x F F_0) (* x (/ (F th gm) F_0)))
+ xyY_z
+ Fs
+ F_0s)))))
+(define (sky-color-xyY turbidity theta_s phi_s)
+ (if (> turbidity 20)
+ (overcast-sky-color-xyY turbidity theta_s)
+ (clear-sky-color-xyY turbidity theta_s phi_s)))
diff --git a/daylight.txi b/daylight.txi
new file mode 100644
index 0000000..fa24afc
--- /dev/null
+++ b/daylight.txi
@@ -0,0 +1,117 @@
+@code{(require 'daylight)}
+@ftindex daylight
+@ftindex sunlight
+@ftindex sun
+@ftindex sky
+
+@noindent
+This package calculates the colors of sky as detailed in:@*
+@uref{http://www.cs.utah.edu/vissim/papers/sunsky/sunsky.pdf}@*
+@cite{A Practical Analytic Model for Daylight}@*
+A. J. Preetham, Peter Shirley, Brian Smits
+
+
+@defun solar-hour julian-day hour
+
+
+Returns the solar-time in hours given the integer @var{julian-day} in the range 1 to
+366, and the local time in hours.
+
+To be meticulous, subtract 4 minutes for each degree of longitude west
+of the standard meridian of your time zone.
+@end defun
+
+@defun solar-declination julian-day
+
+@end defun
+
+@defun solar-polar declination latitude solar-hour
+Returns a list of @var{theta_s}, the solar angle from the
+zenith, and @var{phi_s}, the solar azimuth. 0 <= @var{theta_s}
+measured in degrees. @var{phi_s} is measured in degrees from due
+south; west of south being positive.
+@end defun
+@noindent
+In the following procedures, the number 0 <= @var{theta_s} <= 90 is
+the solar angle from the zenith in degrees.
+
+@cindex turbidity
+@noindent
+Turbidity is a measure of the fraction of scattering due to haze as
+opposed to molecules. This is a convenient quantity because it can be
+estimated based on visibility of distant objects. This model fails
+for turbidity values less than 1.3.
+
+@example
+@group
+ _______________________________________________________________
+512|-: |
+ | * pure-air |
+256|-:** |
+ | : ** exceptionally-clear |
+128|-: * |
+ | : ** |
+ 64|-: * |
+ | : ** very-clear |
+ 32|-: ** |
+ | : ** |
+ 16|-: *** clear |
+ | : **** |
+ 8|-: **** |
+ | : **** light-haze |
+ 4|-: **** |
+ | : ****** |
+ 2|-: ******** haze thin-|
+ | : *********** fog |
+ 1|-:----------------------------------------------------*******--|
+ |_:____.____:____.____:____.____:____.____:____.____:____.____:_|
+ 1 2 4 8 16 32 64
+ Meterorological range (km) versus Turbidity
+@end group
+@end example
+
+
+@defun sunlight-spectrum turbidity theta_s
+Returns a vector of 41 values, the spectrum of sunlight from
+380.nm to 790.nm for a given @var{turbidity} and @var{theta_s}.
+@end defun
+
+@defun sunlight-xyz turbidity theta_s
+Returns (unnormalized) XYZ values for color of sunlight for a
+given @var{turbidity} and @var{theta_s}.
+@end defun
+
+@defun sunlight-ciexyz turbidity theta_s
+Given @var{turbidity} and @var{theta_s}, @code{sunlight-ciexyz} returns the CIEXYZ triple for color of
+sunlight scaled to be just inside the RGB709 gamut.
+@end defun
+
+@defun zenith-xyy turbidity theta_s
+Returns the xyY (chromaticity and luminance) at the zenith. The
+Luminance has units kcd/m^2.
+@end defun
+
+@defun overcast-sky-color-xyy turbidity theta_s
+@var{turbidity} is a positive real number expressing the amount of light
+scattering. The real number @var{theta_s} is the solar angle from the zenith in
+degrees.
+
+@code{overcast-sky-color-xyy} returns a function of one angle @var{theta}, the angle from the
+zenith of the viewing direction (in degrees); and returning the xyY
+value for light coming from that elevation of the sky.
+@end defun
+
+@defun clear-sky-color-xyy turbidity theta_s phi_s
+@defunx sky-color-xyy turbidity theta_s phi_s
+@var{turbidity} is a positive real number expressing the amount of light
+scattering. The real number @var{theta_s} is the solar angle from the zenith in
+degrees. The real number @var{phi_s} is the solar angle from south.
+
+@code{clear-sky-color-xyy} returns a function of two angles, @var{theta} and @var{phi} which
+specify the angles from the zenith and south meridian of the viewing
+direction (in degrees); returning the xyY value for light coming from
+that direction of the sky.
+
+@code{sky-color-xyY} calls @code{overcast-sky-color-xyY} for
+@var{turbidity} <= 20; otherwise the @code{clear-sky-color-xyy} function.
+@end defun
diff --git a/db2html.scm b/db2html.scm
index 3462966..df34389 100644
--- a/db2html.scm
+++ b/db2html.scm
@@ -8,7 +8,7 @@
;1. Any copy made of this software must include this copyright notice
;in full.
;
-;2. I have made no warrantee or representation that the operation of
+;2. I have made no warranty or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
@@ -18,11 +18,20 @@
;each case.
(require 'uri)
+(require 'printf)
(require 'html-form)
-(require 'net-clients)
+(require 'directory)
+(require 'databases)
+(require 'string-case)
(require 'string-search)
+(require 'common-list-functions)
+(require-if 'compiling 'pretty-print)
+(require-if 'compiling 'database-commands)
+(require 'hash)
+(define (crc:hash-obj obj) (number->string (hash obj most-positive-fixnum) 16))
;;@code{(require 'db->html)}
+;;@ftindex db->html
;;@body
(define (html:table options . rows)
@@ -224,11 +233,11 @@
;;@args table-name null-keys update
;;@args table-name null-keys
;;
-;;Returns procedure (of @var{db}) which returns procedure to modify row
-;;of @1. @2 is the list of @dfn{null} keys which indicate that the row
-;;is to be deleted. Optional arguments @3, @4, and @5 default to the
-;;@code{row:update}, @code{row:delete}, and @code{row:retrieve} of @1 in
-;;@var{db}.
+;;Returns procedure (of @var{db}) which returns procedure to modify
+;;row of @1. @2 is the list of @dfn{null} keys indicating the row is
+;;to be deleted when any matches its corresponding primary key.
+;;Optional arguments @3, @4, and @5 default to the @code{row:update},
+;;@code{row:delete}, and @code{row:retrieve} of @1 in @var{db}.
(define (command:modify-table table-name null-keys . args)
(define argc (length args))
(lambda (rdb)
@@ -251,7 +260,7 @@
(table:update new-row)
((rdb 'sync-database)) #t)
(else '("Row changed by other user"))))
- ((equal? null-keys new-pkeys) ;blanked keys
+ ((command:null-key? null-keys new-pkeys) ;blanked keys
(cond ((not row) #t)
((equal? (crc:hash-obj row) *row-hash*)
;;(slib:warn (sprintf #f "Removing key: %#a => %#a" new-pkeys ))
@@ -268,6 +277,26 @@
(apply table:delete pkeys))
((rdb 'sync-database)) #t)))))))))
+(define (command:null-key? null-keys new-pkeys)
+ (define sts #f)
+ (for-each (lambda (nuk nep) (if (equal? nuk nep) (set! sts #t)))
+ null-keys
+ new-pkeys)
+ sts)
+
+(define (make-defaulter arity type)
+ `(lambda (pl)
+ ',(case arity
+ ((optional nary) '())
+ ((boolean) #f)
+ ((single nary1)
+ (case type
+ ((string) '(""))
+ ((symbol) '(nil))
+ ((number) '(0))
+ (else '(#f))))
+ (else (slib:error 'make-defaulter 'unknown 'arity arity)))))
+
;;@body Given @2 in @1, creates parameter and @code{*command*} tables
;;for editing one row of @2 at a time. @0 returns a procedure taking a
;;row argument which returns the HTML string for editing that row.
@@ -286,6 +315,7 @@
;;@end table
(define (command:make-editable-table rdb table-name . args)
(define table ((rdb 'open-table) table-name #t))
+ (require 'database-commands)
(let ((pkl (table 'primary-limit))
(columns (table 'column-names))
(domains (table 'column-domains))
@@ -313,7 +343,8 @@
(define foreign-choice-lists
(map (lambda (domain-name)
(define tab-name (ftn domain-name))
- (if tab-name (get-foreign-choices (rdb-open tab-name #f)) '()))
+ (if tab-name (get-foreign-choices
+ ((rdb 'open-table) tab-name #f)) '()))
domains))
(define-tables rdb
`(,(symbol-append table-name '- 'params)
@@ -323,7 +354,7 @@
,@field-specs))
`(,(symbol-append table-name '- 'pname)
((name string))
- ((parameter-index uint)) ;should be address-params
+ ((parameter-index ordinal)) ;should be address-params
(("*keys*" 1)
("*row-hash*" 2)
,@(map (lambda (idx column) (list (symbol->string column) idx))
@@ -335,7 +366,10 @@
,(symbol-append table-name '- 'pname)
(command:modify-table ',table-name
',(map (lambda (fs)
- (caadr (caddar (cddddr fs))))
+ (define dfl
+ ((slib:eval (car (cddddr fs)))
+ '()))
+ (if (pair? dfl) (car dfl) dfl))
(butnthcdr pkl field-specs))
,@args)
,(string-append "Modify " (symbol->string table-name))))))
@@ -424,16 +458,17 @@
;;top level page with the catalog of tables (captioned @4) is written
;;to a file named @3.
(define (db->html-files db dir index-filename caption)
- (call-with-output-file (in-vicinity (if dir (sub-vicinity "" dir) "")
- index-filename)
+ (set! dir (if dir (sub-vicinity "" dir) ""))
+ (call-with-output-file (in-vicinity dir index-filename)
(lambda (port)
(display (catalog->page db caption) port)))
- ((((db 'open-table) '*catalog-data* #f) 'for-each-row)
- (lambda (row)
- (call-with-output-file
- (in-vicinity (sub-vicinity "" dir) (table-name->filename (car row)))
- (lambda (port)
- (display (table->linked-page db (car row) index-filename) port))))))
+ (let ((catdat ((db 'open-table) '*catalog-data* #f)))
+ ((or (catdat 'for-each-row-in-order) (catdat 'for-each-row))
+ (lambda (row)
+ (call-with-output-file
+ (in-vicinity dir (table-name->filename (car row)))
+ (lambda (port)
+ (display (table->linked-page db (car row) index-filename) port)))))))
;;@args db dir index-filename
;;@args db dir
@@ -457,7 +492,7 @@
;;@args db dir index-filename
;;@args db dir
;;@0 is just like @code{db->html-directory}, but calls
-;;@code{browse-url-netscape} with the uri for the top page after the
+;;@code{browse-url} with the uri for the top page after the
;;pages are created.
(define (db->netscape . args)
- (browse-url-netscape (apply db->html-directory args)))
+ (browse-url (apply db->html-directory args)))
diff --git a/db2html.txi b/db2html.txi
index 0acdd46..3b47f31 100644
--- a/db2html.txi
+++ b/db2html.txi
@@ -1,4 +1,5 @@
@code{(require 'db->html)}
+@ftindex db->html
@defun html:table options row @dots{}
@@ -104,12 +105,12 @@ database is performed.
@defunx command:modify-table table-name null-keys
-Returns procedure (of @var{db}) which returns procedure to modify row
-of @var{table-name}. @var{null-keys} is the list of @dfn{null} keys which indicate that the row
+Returns procedure (of @var{db}) which returns procedure to modify
+row of @var{table-name}. @var{null-keys} is the list of @dfn{null} keys indicating the row is
@cindex null
-is to be deleted. Optional arguments @var{update}, @var{delete}, and @var{retrieve} default to the
-@code{row:update}, @code{row:delete}, and @code{row:retrieve} of @var{table-name} in
-@var{db}.
+to be deleted when any matches its corresponding primary key.
+Optional arguments @var{update}, @var{delete}, and @var{retrieve} default to the @code{row:update},
+@code{row:delete}, and @code{row:retrieve} of @var{table-name} in @var{db}.
@end defun
@defun command:make-editable-table rdb table-name arg @dots{}
@@ -180,6 +181,6 @@ returned.
@defunx db->netscape db dir
@code{db->netscape} is just like @code{db->html-directory}, but calls
-@code{browse-url-netscape} with the uri for the top page after the
+@code{browse-url} with the uri for the top page after the
pages are created.
@end defun
diff --git a/dbcom.scm b/dbcom.scm
new file mode 100644
index 0000000..428e3db
--- /dev/null
+++ b/dbcom.scm
@@ -0,0 +1,215 @@
+;;; "dbcom.scm" embed commands in relational-database
+; Copyright 1994, 1995, 1997, 2000, 2001 Aubrey Jaffer
+;
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
+;
+;1. Any copy made of this software must include this copyright notice
+;in full.
+;
+;2. I have made no warranty or representation that the operation of
+;this software will be error-free, and I am under no obligation to
+;provide any services, by way of maintenance, update, or otherwise.
+;
+;3. In conjunction with products arising from the use of this
+;material, there shall be no use of my name in any advertising,
+;promotional, or sales literature without prior written consent in
+;each case.
+
+(require 'common-list-functions) ;for position
+(require 'relational-database)
+(require 'databases)
+;@
+(define (wrap-command-interface rdb)
+ (let* ((rdms:commands ((rdb 'open-table) '*commands* #f))
+ (command:get (and rdms:commands (rdms:commands 'get 'procedure))))
+ (and command:get
+ (letrec ((wdb (lambda (command)
+ (let ((com (command:get command)))
+ (if com ((slib:eval com) wdb) (rdb command))))))
+ (let ((init (wdb '*initialize*)))
+ (if (procedure? init) init wdb))))))
+;@
+(define (open-command-database! path . arg)
+ (define bt (apply open-database! path arg))
+ (and bt (wrap-command-interface bt)))
+;@
+(define (open-command-database path . arg)
+ (define bt (apply open-database path arg))
+ (and bt (wrap-command-interface bt)))
+;@
+(define (add-command-tables rdb)
+ (define-tables
+ rdb
+ '(type
+ ((name symbol))
+ ()
+ ((atom)
+ (symbol)
+ (string)
+ (number)
+ (money)
+ (date-time)
+ (boolean)
+ (foreign-key)
+ (expression)
+ (virtual)))
+ '(parameter-arity
+ ((name symbol))
+ ((predicate? expression)
+ (procedure expression))
+ ((single (lambda (a) (and (pair? a) (null? (cdr a)))) car)
+ (optional
+ (lambda (lambda (a) (or (null? a) (and (pair? a) (null? (cdr a))))))
+ identity)
+ (boolean
+ (lambda (a) (or (null? a)
+ (and (pair? a) (null? (cdr a)) (boolean? (car a)))))
+ (lambda (a) (if (null? a) #f (car a))))
+ (nary (lambda (a) #t) identity)
+ (nary1 (lambda (a) (not (null? a))) identity))))
+ (for-each (((rdb 'open-table) '*domains-data* #t) 'row:insert)
+ '((parameter-list *catalog-data* #f symbol 1)
+ (parameter-name-translation *catalog-data* #f symbol 1)
+ (parameter-arity parameter-arity #f symbol 1)
+ (table *catalog-data* #f atom 1)))
+ (define-tables
+ rdb
+ '(*parameter-columns*
+ *columns*
+ *columns*
+ ((1 #t index #f ordinal)
+ (2 #f name #f symbol)
+ (3 #f arity #f parameter-arity)
+ (4 #f domain #f domain)
+ (5 #f defaulter #f expression)
+ (6 #f expander #f expression)
+ (7 #f documentation #f string)))
+ '(no-parameters
+ *parameter-columns*
+ *parameter-columns*
+ ())
+ '(no-parameter-names
+ ((name string))
+ ((parameter-index ordinal))
+ ())
+ '(add-domain-params
+ *parameter-columns*
+ *parameter-columns*
+ ((1 domain-name single atom #f #f "new domain name")
+ (2 foreign-table optional table #f #f
+ "if present, domain-name must be existing key into this table")
+ (3 domain-integrity-rule optional expression #f #f
+ "returns #t if single argument is good")
+ (4 type-id single type #f #f "base type of new domain")
+ (5 type-param optional expression #f #f
+ "which (key) field of the foreign-table")
+ ))
+ '(add-domain-pnames
+ ((name string))
+ ((parameter-index ordinal)) ;should be add-domain-params
+ (
+ ("n" 1) ("name" 1)
+ ("f" 2) ("foreign (key) table" 2)
+ ("r" 3) ("domain integrity rule" 3)
+ ("t" 4) ("type" 4)
+ ("p" 5) ("type param" 5)
+ ))
+ '(del-domain-params
+ *parameter-columns*
+ *parameter-columns*
+ ((1 domain-name single domain #f #f "domain name")))
+ '(del-domain-pnames
+ ((name string))
+ ((parameter-index ordinal)) ;should be del-domain-params
+ (("n" 1) ("name" 1)))
+ '(*commands*
+ ((name symbol))
+ ((parameters parameter-list)
+ (parameter-names parameter-name-translation)
+ (procedure expression)
+ (documentation string))
+ ((domain-checker
+ no-parameters
+ no-parameter-names
+ dbcom:check-domain
+ "return procedure to check given domain name")
+
+ (add-domain
+ add-domain-params
+ add-domain-pnames
+ (lambda (rdb)
+ (((rdb 'open-table) '*domains-data* #t) 'row:update))
+ "add a new domain")
+
+ (delete-domain
+ del-domain-params
+ del-domain-pnames
+ (lambda (rdb)
+ (((rdb 'open-table) '*domains-data* #t) 'row:remove))
+ "delete a domain"))))
+ (let* ((tab ((rdb 'open-table) '*domains-data* #t))
+ (row ((tab 'row:retrieve) 'type)))
+ ((tab 'row:update) (cons 'type (cdr row))))
+ (wrap-command-interface rdb))
+;@
+(define (define-*commands* rdb . cmd-defs)
+ (define defcmd (((rdb 'open-table) '*commands* #t) 'row:update))
+ (for-each (lambda (def)
+ (define procname (caar def))
+ (define args (cdar def))
+ (define body (cdr def))
+ (let ((comment (and (string? (car body)) (car body))))
+ (define nbody (if comment (cdr body) body))
+ (defcmd (list procname
+ 'no-parameters
+ 'no-parameter-names
+ `(lambda ,args ,@nbody)
+ (or comment "")))))
+ cmd-defs))
+
+;; Actually put into command table by add-command-tables
+(define (dbcom:check-domain rdb)
+ (let* ((ro:domains ((rdb 'open-table) '*domains-data* #f))
+ (ro:get-dir (ro:domains 'get 'domain-integrity-rule))
+ (ro:for-tab (ro:domains 'get 'foreign-table)))
+ (lambda (domain)
+ (let ((fkname (ro:for-tab domain))
+ (dir (slib:eval (ro:get-dir domain))))
+ (if fkname (let* ((fktab ((rdb 'open-table) fkname #f))
+ (p? (fktab 'get 1)))
+ (if dir (lambda (e) (and (dir e) (p? e))) p?))
+ dir)))))
+;@
+(define (make-command-server rdb command-table)
+ (let* ((comtab ((rdb 'open-table) command-table #f))
+ (names (comtab 'column-names))
+ (row-ref (lambda (row name) (list-ref row (position name names))))
+ (comgetrow (comtab 'row:retrieve)))
+ (lambda (comname command-callback)
+ (cond ((not comname) (set! comname '*default*)))
+ (cond ((not (comgetrow comname))
+ (slib:error 'command 'not 'known: comname)))
+ (let* ((command:row (comgetrow comname))
+ (parameter-table
+ ((rdb 'open-table) (row-ref command:row 'parameters) #f))
+ (parameter-names
+ ((rdb 'open-table) (row-ref command:row 'parameter-names) #f))
+ (comval ((slib:eval (row-ref command:row 'procedure)) rdb))
+ (options ((parameter-table 'get* 'name)))
+ (positions ((parameter-table 'get* 'index)))
+ (arities ((parameter-table 'get* 'arity)))
+ (defaulters (map slib:eval ((parameter-table 'get* 'defaulter))))
+ (domains ((parameter-table 'get* 'domain)))
+ (types (map (((rdb 'open-table) '*domains-data* #f) 'get 'type-id)
+ domains))
+ (dirs (map (or (rdb 'domain-checker) (lambda (domain)
+ (lambda (domain) #t)))
+ domains))
+ (aliases
+ (map list ((parameter-names 'get* 'name))
+ (map (parameter-table 'get 'name)
+ ((parameter-names 'get* 'parameter-index))))))
+ (command-callback comname comval options positions
+ arities types defaulters dirs aliases)))))
diff --git a/dbinterp.scm b/dbinterp.scm
new file mode 100644
index 0000000..8ccb1df
--- /dev/null
+++ b/dbinterp.scm
@@ -0,0 +1,34 @@
+;;; "dbinterp.scm" Interpolate function from database table.
+;Copyright 2003 Aubrey Jaffer
+;
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
+;
+;1. Any copy made of this software must include this copyright notice
+;in full.
+;
+;2. I have made no warranty or representation that the operation of
+;this software will be error-free, and I am under no obligation to
+;provide any services, by way of maintenance, update, or otherwise.
+;
+;3. In conjunction with products arising from the use of this
+;material, there shall be no use of my name in any advertising,
+;promotional, or sales literature without prior written consent in
+;each case.
+
+;;@ This procedure works only for tables with a single primary key.
+(define (interpolate-from-table table column)
+ (define get (table 'get column))
+ (define prev (table 'isam-prev))
+ (define next (table 'isam-next))
+ (lambda (x)
+ (let ((nxt (next x)))
+ (if nxt (set! nxt (car nxt)))
+ (let ((prv (prev (or nxt x))))
+ (if prv (set! prv (car prv)))
+ (cond ((not nxt) (get prv))
+ ((not prv) (get nxt))
+ (else (/ (+ (* (- x prv) (get nxt))
+ (* (- nxt x) (get prv)))
+ (- nxt prv))))))))
diff --git a/dbrowse.scm b/dbrowse.scm
index e186492..9401c6d 100644
--- a/dbrowse.scm
+++ b/dbrowse.scm
@@ -8,7 +8,7 @@
;1. Any copy made of this software must include this copyright notice
;in full.
;
-;2. I have made no warrantee or representation that the operation of
+;2. I have made no warranty or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
@@ -17,11 +17,11 @@
;promotional, or sales literature without prior written consent in
;each case.
-(require 'database-utilities)
+(require 'databases)
(require 'printf)
(define browse:db #f)
-
+;@
(define (browse . args)
(define table-name #f)
(cond ((null? args))
@@ -48,8 +48,8 @@
(define (browse:display-dir table-name table)
(printf "%s Tables:\\n" table-name)
- ((table 'for-each-row)
- (lambda (row) (printf "\\t%s\\n" (car row)))))
+ ((or (table 'for-each-row-in-order) (table 'for-each-row))
+ (lambda (row) (printf "\\t%a\\n" (car row)))))
(define (browse:display-table table-name table)
(let* ((width 18)
@@ -73,7 +73,7 @@
(newline)
(for-each (lambda (type)
(case type
- ((integer number uint base-id)
+ ((integer number ordinal base-id uint)
(set! form (string-append form dw-integer)))
((boolean domain expression atom)
(set! form (string-append form dwp-any)))
@@ -87,6 +87,6 @@
(for-each (lambda (domain) (printf underline))
(table 'column-domains))
(newline)
- ((table 'for-each-row)
+ ((or (table 'for-each-row-in-order) (table 'for-each-row))
(lambda (row)
(apply printf form row)))))
diff --git a/dbsyn.scm b/dbsyn.scm
new file mode 100644
index 0000000..1bc1319
--- /dev/null
+++ b/dbsyn.scm
@@ -0,0 +1,54 @@
+;;;; "dbsyn.scm" -- Syntactic extensions for RDMS (within-database)
+;;; Copyright (C) 2002 Ivan Shmakov <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 ...)))))
diff --git a/dbutil.scm b/dbutil.scm
index 248ec1d..5e5c86d 100644
--- a/dbutil.scm
+++ b/dbutil.scm
@@ -1,5 +1,5 @@
;;; "dbutil.scm" relational-database-utilities
-; Copyright 1994, 1995, 1997, 2000, 2001 Aubrey Jaffer
+; Copyright 1994, 1995, 1997, 2000, 2001, 2002 Aubrey Jaffer
;
;Permission to copy this software, to modify it, to redistribute it,
;to distribute modified versions, and to use it for any purpose is
@@ -8,7 +8,7 @@
;1. Any copy made of this software must include this copyright notice
;in full.
;
-;2. I have made no warrantee or representation that the operation of
+;2. I have made no warranty or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
@@ -17,226 +17,418 @@
;promotional, or sales literature without prior written consent in
;each case.
+(require 'common-list-functions) ;for nthcdr and butnthcdr
(require 'relational-database)
-(require 'common-list-functions)
-
-(define (db:base-type path)
- 'alist-table) ; currently the only one.
-
-(define (dbutil:wrap-command-interface rdb)
- (and rdb
- (let* ((rdms:commands ((rdb 'open-table) '*commands* #f))
- (command:get
- (and rdms:commands (rdms:commands 'get 'procedure))))
- (and command:get
- (letrec ((wdb (lambda (command)
- (let ((com (command:get command)))
- (cond (com ((slib:eval com) wdb))
- (else (rdb command)))))))
- (let ((init (wdb '*initialize*)))
- (if (procedure? init) init wdb)))))))
-
-(define (dbutil:open-database! path . arg)
- (let ((type (if (null? arg) (db:base-type path) (car arg))))
- (require type)
- (dbutil:wrap-command-interface
- (((make-relational-system (slib:eval type)) 'open-database)
- path #t))))
-
-(define (dbutil:open-database path . arg)
- (let ((type (if (null? arg) (db:base-type path) (car arg))))
- (require type)
- (dbutil:wrap-command-interface
- (((make-relational-system (slib:eval type)) 'open-database)
- path #f))))
-
-(define (dbutil:check-domain rdb)
- (let* ((ro:domains ((rdb 'open-table) '*domains-data* #f))
- (ro:get-dir (ro:domains 'get 'domain-integrity-rule))
- (ro:for-tab (ro:domains 'get 'foreign-table)))
- (lambda (domain)
- (let ((fkname (ro:for-tab domain))
- (dir (slib:eval (ro:get-dir domain))))
- (if fkname (let* ((fktab ((rdb 'open-table) fkname #f))
- (p? (fktab 'get 1)))
- (if dir (lambda (e) (and (dir e) (p? e))) p?))
- dir)))))
-
-(define (dbutil:create-database path type)
+(require 'dynamic-wind)
+(require 'transact)
+(require-if 'compiling 'printf) ;used only by mdbm:report
+(require-if 'compiling 'alist-table)
+
+;;@code{(require 'databases)}
+;;@ftindex databases
+;;
+;;@noindent
+;;This enhancement wraps a utility layer on @code{relational-database}
+;;which provides:
+;;
+;;@itemize @bullet
+;;@item
+;;Identification of open databases by filename.
+;;@item
+;;Automatic sharing of open (immutable) databases.
+;;@item
+;;Automatic loading of base-table package when creating a database.
+;;@item
+;;Detection and automatic loading of the appropriate base-table package
+;;when opening a database.
+;;@item
+;;Table and data definition from Scheme lists.
+;;@end itemize
+
+;;;Each entry in mdbm:*databases* is a list of:
+
+;;; * database (procedure)
+;;; * number of opens (integer)
+;;; * type (symbol)
+;;; * lock-certificate
+
+;;;Because of WRITE-DATABASE, database filenames can change, so we must
+;;;have a global lock.
+(define mdbm:*databases* (make-exchanger '()))
+(define (mdbm:return-dbs dbs)
+ (if (mdbm:*databases* dbs)
+ (slib:error 'mdbm:*databases* 'double 'set!)))
+
+(define (mdbm:find-db? rdb dbs)
+ (and dbs
+ (do ((dbs dbs (cdr dbs)))
+ ((or (null? dbs)
+ (equal? ((caar dbs) 'filename)
+ (if (procedure? rdb) (rdb 'filename) rdb)))
+ (and (not (null? dbs))
+ (if (and (procedure? rdb)
+ (not (eq? ((caar dbs) 'filename) (rdb 'filename))))
+ (slib:error ((caar dbs) 'filename) 'open 'twice)
+ (car dbs)))))))
+
+(define (mdbm:remove-entry dbs entry)
+ (cond ((null? dbs) (slib:error 'mdbm:remove-entry 'not 'found entry))
+ ((eq? entry (car dbs)) (cdr dbs))
+ (else (cons (car dbs) (mdbm:remove-entry (cdr dbs) entry)))))
+
+;;@subsubheading Database Sharing
+
+;;@noindent
+;;@dfn{Auto-sharing} refers to a call to the procedure
+;;@code{open-database} returning an already open database (procedure),
+;;rather than opening the database file a second time.
+;;
+;;@quotation
+;;@emph{Note:} Databases returned by @code{open-database} do not include
+;;wrappers applied by packages like @ref{Embedded Commands}. But
+;;wrapped databases do work as arguments to these functions.
+;;@end quotation
+;;
+;;@noindent
+;;When a database is created, it is mutable by the creator and not
+;;auto-sharable. A database opened mutably is also not auto-sharable.
+;;But any number of readers can (open) share a non-mutable database file.
+
+;;@noindent
+;;This next set of procedures mirror the whole-database methods in
+;;@ref{Database Operations}. Except for @code{create-database}, each
+;;procedure will accept either a filename or database procedure for its
+;;first argument.
+
+(define (mdbm:try-opens filename mutable?)
+ (define (try base)
+ (let ((rdb (base 'open-database)))
+ (and rdb (rdb filename mutable?))))
+ (define certificate (and mutable? (file-lock! filename)))
+ (define (loop bti)
+ (define rdb (try (cadar bti)))
+ (cond ((procedure? rdb) (list rdb 1 (caar bti) certificate))
+ ((null? (cdr bti)) #f)
+ (else (loop (cdr bti)))))
+ (if (null? *base-table-implementations*) (require 'alist-table))
+ (cond ((and (not (and mutable? (not certificate)))
+ (loop *base-table-implementations*)))
+ ((memq 'alist-table *base-table-implementations*) #f)
+ ((let ()
+ (require 'alist-table)
+ (loop (list (car *base-table-implementations*)))))
+ (else #f)))
+
+(define (mdbm:open-type filename type mutable?)
+ (require type)
+ (let ((certificate (and mutable? (file-lock! filename))))
+ (and (not (and mutable? (not certificate)))
+ (let* ((sys (cadr (assq type *base-table-implementations*)))
+ (open (and sys (sys 'open-database)))
+ (ndb (and open (open filename mutable?))))
+ (and ndb (list ndb 1 type certificate))))))
+
+;;@args filename base-table-type
+;;@1 should be a string naming a file; or @code{#f}. @2 must be a
+;;symbol naming a feature which can be passed to @code{require}. @0
+;;returns a new, open relational database (with base-table type @2)
+;;associated with @1, or a new ephemeral database if @1 is @code{#f}.
+;;
+;;@code{create-database} is the only run-time use of require in SLIB
+;;which crosses module boundaries. When @2 is @code{require}d by @0; it
+;;adds an association of @2 with its @dfn{relational-system} procedure
+;;to @var{mdbm:*databases*}.
+;;
+;;alist-table is the default base-table type:
+;;
+;;@example
+;;(require 'databases)
+;;(define my-rdb (create-database "my.db" 'alist-table))
+;;@end example
+(define (create-database filename type)
(require type)
- (let ((rdb (((make-relational-system (slib:eval type)) 'create-database)
- path)))
- (dbutil:define-tables
- rdb
- '(type
- ((name symbol))
- ()
- ((atom)
- (symbol)
- (string)
- (number)
- (money)
- (date-time)
- (boolean)
- (foreign-key)
- (expression)
- (virtual)))
- '(parameter-arity
- ((name symbol))
- ((predicate? expression)
- (procedure expression))
- ((single (lambda (a) (and (pair? a) (null? (cdr a)))) car)
- (optional
- (lambda (lambda (a) (or (null? a) (and (pair? a) (null? (cdr a))))))
- identity)
- (boolean
- (lambda (a) (or (null? a)
- (and (pair? a) (null? (cdr a)) (boolean? (car a)))))
- (lambda (a) (if (null? a) #f (car a))))
- (nary (lambda (a) #t) identity)
- (nary1 (lambda (a) (not (null? a))) identity))))
- (for-each (((rdb 'open-table) '*domains-data* #t) 'row:insert)
- '((parameter-list *catalog-data* #f symbol 1)
- (parameter-name-translation *catalog-data* #f symbol 1)
- (parameter-arity parameter-arity #f symbol 1)
- (table *catalog-data* #f atom 1)))
- (dbutil:define-tables
- rdb
- '(*parameter-columns*
- *columns*
- *columns*
- ((1 #t index #f uint)
- (2 #f name #f symbol)
- (3 #f arity #f parameter-arity)
- (4 #f domain #f domain)
- (5 #f defaulter #f expression)
- (6 #f expander #f expression)
- (7 #f documentation #f string)))
- '(no-parameters
- *parameter-columns*
- *parameter-columns*
- ())
- '(no-parameter-names
- ((name string))
- ((parameter-index uint))
- ())
- '(add-domain-params
- *parameter-columns*
- *parameter-columns*
- ((1 domain-name single atom #f #f "new domain name")
- (2 foreign-table optional table #f #f
- "if present, domain-name must be existing key into this table")
- (3 domain-integrity-rule optional expression #f #f
- "returns #t if single argument is good")
- (4 type-id single type #f #f "base type of new domain")
- (5 type-param optional expression #f #f
- "which (key) field of the foreign-table")
- ))
- '(add-domain-pnames
- ((name string))
- ((parameter-index uint)) ;should be add-domain-params
- (
- ("n" 1) ("name" 1)
- ("f" 2) ("foreign (key) table" 2)
- ("r" 3) ("domain integrity rule" 3)
- ("t" 4) ("type" 4)
- ("p" 5) ("type param" 5)
- ))
- '(del-domain-params
- *parameter-columns*
- *parameter-columns*
- ((1 domain-name single domain #f #f "domain name")))
- '(del-domain-pnames
- ((name string))
- ((parameter-index uint)) ;should be del-domain-params
- (("n" 1) ("name" 1)))
- '(*commands*
- ((name symbol))
- ((parameters parameter-list)
- (parameter-names parameter-name-translation)
- (procedure expression)
- (documentation string))
- ((domain-checker
- no-parameters
- no-parameter-names
- dbutil:check-domain
- "return procedure to check given domain name")
-
- (add-domain
- add-domain-params
- add-domain-pnames
- (lambda (rdb)
- (((rdb 'open-table) '*domains-data* #t) 'row:update))
- "add a new domain")
-
- (delete-domain
- del-domain-params
- del-domain-pnames
- (lambda (rdb)
- (((rdb 'open-table) '*domains-data* #t) 'row:remove))
- "delete a domain"))))
- (let* ((tab ((rdb 'open-table) '*domains-data* #t))
- (row ((tab 'row:retrieve) 'type)))
- (set-car! (cdr row) 'type)
- ((tab 'row:update) row))
- (dbutil:wrap-command-interface rdb)))
-
-(define (make-defaulter arity type)
- `(lambda (pl)
- ',(case arity
- ((optional nary) '())
- ((boolean) #f)
- ((single nary1)
- (case type
- ((string) '(""))
- ((symbol) '(nil))
- ((number) '(0))
- (else '(#f))))
- (else (slib:error 'make-defaulter 'unknown 'arity arity)))))
-
-(define (get-foreign-choices tab)
- (define dlst ((tab 'get* 1)))
- (do ((dlst dlst (cdr dlst))
- (vlst (if (memq 'visible-name (tab 'column-names))
- ((tab 'get* 'visible-name))
- dlst)
- (cdr vlst))
- (out '() (if (member (car dlst) (cdr dlst))
- out
- (cons (list (car dlst) (car vlst)) out))))
- ((null? dlst) out)))
-
-(define (make-command-server rdb command-table)
- (let* ((comtab ((rdb 'open-table) command-table #f))
- (names (comtab 'column-names))
- (row-ref (lambda (row name) (list-ref row (position name names))))
- (comgetrow (comtab 'row:retrieve)))
- (lambda (comname command-callback)
- (cond ((not comname) (set! comname '*default*)))
- (cond ((not (comgetrow comname))
- (slib:error 'command 'not 'known: comname)))
- (let* ((command:row (comgetrow comname))
- (parameter-table
- ((rdb 'open-table) (row-ref command:row 'parameters) #f))
- (parameter-names
- ((rdb 'open-table) (row-ref command:row 'parameter-names) #f))
- (comval ((slib:eval (row-ref command:row 'procedure)) rdb))
- (options ((parameter-table 'get* 'name)))
- (positions ((parameter-table 'get* 'index)))
- (arities ((parameter-table 'get* 'arity)))
- (defaulters (map slib:eval ((parameter-table 'get* 'defaulter))))
- (domains ((parameter-table 'get* 'domain)))
- (types (map (((rdb 'open-table) '*domains-data* #f) 'get 'type-id)
- domains))
- (dirs (map (rdb 'domain-checker) domains))
- (aliases
- (map list ((parameter-names 'get* 'name))
- (map (parameter-table 'get 'name)
- ((parameter-names 'get* 'parameter-index))))))
- (command-callback comname comval options positions
- arities types defaulters dirs aliases)))))
-
-(define (dbutil:define-tables rdb . spec-list)
+ (let ((dbs #f)
+ (certificate (and filename (file-lock! filename))))
+ (and
+ (or certificate (not filename))
+ (dynamic-wind
+ (lambda () (set! dbs (mdbm:*databases* #f)))
+ (lambda ()
+ (define entry (mdbm:find-db? filename dbs))
+ (cond (entry (slib:warn 'close ((car entry) 'filename)
+ 'before 'create-database) #f)
+ (else
+ (let ((pair (assq type *base-table-implementations*)))
+ (define ndb (and pair (((cadr pair) 'create-database)
+ filename)))
+ (if (and ndb dbs)
+ (set! dbs (cons (list ndb 1 type certificate) dbs)))
+ ndb))))
+ (lambda () (and dbs (mdbm:return-dbs dbs)))))))
+
+;;@noindent
+;;Only @code{alist-table} and base-table modules which have been
+;;@code{require}d will dispatch correctly from the
+;;@code{open-database} procedures. Therefore, either pass two
+;;arguments to @code{open-database}, or require the base-table of your
+;;database file uses before calling @code{open-database} with one
+;;argument.
+
+;;@args rdb base-table-type
+;;Returns @emph{mutable} open relational database or #f.
+(define (open-database! filename . type)
+ (set! type (and (not (null? type)) (car type)))
+ (let ((dbs #f))
+ (dynamic-wind
+ (lambda () (set! dbs (mdbm:*databases* #f)))
+ (lambda ()
+ (cond ((and (procedure? filename) (not (filename 'delete-table)))
+ (slib:warn (filename 'filename) 'not 'mutable) #f)
+ ((mdbm:find-db? filename dbs)
+ (cond ((procedure? filename) filename)
+ (else (slib:warn filename 'already 'open) #f)))
+ (else (let ((entry (if type
+ (mdbm:open-type filename type #t)
+ (mdbm:try-opens filename #t))))
+ (cond (entry (and dbs (set! dbs (cons entry dbs)))
+ (car entry))
+ (else #f))))))
+ (lambda () (and dbs (mdbm:return-dbs dbs))))))
+
+;;@args rdb base-table-type
+;;Returns an open relational database associated with @1. The
+;;database will be opened with base-table type @2).
+;;
+;;@args rdb
+;;Returns an open relational database associated with @1.
+;;@0 will attempt to deduce the correct base-table-type.
+(define (open-database rdb . type)
+ (set! type (and (not (null? type)) (car type)))
+ (let ((dbs #f))
+ (dynamic-wind
+ (lambda () (set! dbs (mdbm:*databases* #f)))
+ (lambda ()
+ (define entry (mdbm:find-db? rdb dbs))
+ (and entry (set! rdb (car entry)))
+ (cond ((and entry type (not (eqv? (caddr entry) type)))
+ (slib:warn (rdb 'filename) 'type type '<> (caddr entry)) #f)
+ ((and (procedure? rdb) (rdb 'delete-table))
+ (slib:warn (rdb 'filename) 'mutable) #f)
+ (entry (set-car! (cdr entry) (+ 1 (cadr entry))) rdb)
+ (else
+ (set! entry
+ (cond ((procedure? rdb) (list rdb 1 type #f))
+ (type (mdbm:open-type rdb type #f))
+ (else (mdbm:try-opens rdb #f))))
+ (cond (entry (and dbs (set! dbs (cons entry dbs)))
+ (car entry))
+ (else #f)))))
+ (lambda () (and dbs (mdbm:return-dbs dbs))))))
+
+;;@body
+;;Writes the mutable relational-database @1 to @2.
+(define (write-database rdb filename)
+ (let ((dbs #f))
+ (dynamic-wind
+ (lambda () (set! dbs (mdbm:*databases* #f)))
+ (lambda ()
+ (define entry (mdbm:find-db? rdb dbs))
+ (and entry (set! rdb (car entry)))
+ (cond ((and (not entry) (procedure? rdb))
+ (set! entry (list rdb 1 #f (file-lock! filename)))
+ (and dbs (set! dbs (cons entry dbs)))))
+ (cond ((not entry) #f)
+ ((and (not (equal? filename (rdb 'filename)))
+ (mdbm:find-db? filename dbs))
+ (slib:warn filename 'already 'open) #f)
+ (else (let ((dbwrite (rdb 'write-database)))
+ (and dbwrite (dbwrite filename))))))
+ (lambda () (and dbs (mdbm:return-dbs dbs))))))
+
+;;@args rdb
+;;Writes the mutable relational-database @1 to the filename it was
+;;opened with.
+(define (sync-database rdb)
+ (let ((dbs #f))
+ (dynamic-wind
+ (lambda () (set! dbs (mdbm:*databases* #f)))
+ (lambda ()
+ (define entry (mdbm:find-db? rdb dbs))
+ (and entry (set! rdb (car entry)))
+ (cond ((and (not entry) (procedure? rdb))
+ (set! entry (list rdb 1 #f (file-lock! (rdb 'filename))))
+ (and dbs (set! dbs (cons entry dbs)))))
+ (cond (entry (let ((db-op (rdb 'sync-database)))
+ (and db-op (db-op))))
+ (else #f)))
+ (lambda () (and dbs (mdbm:return-dbs dbs))))))
+
+;;@args rdb
+;;Syncs @1 and makes it immutable.
+(define (solidify-database rdb) ;
+ (let ((dbs #f))
+ (dynamic-wind
+ (lambda () (set! dbs (mdbm:*databases* #f)))
+ (lambda ()
+ (define entry (mdbm:find-db? rdb dbs))
+ (define certificate #f)
+ (cond (entry (set! rdb (car entry))
+ (set! certificate (cadddr entry)))
+ ((procedure? rdb)
+ (set! entry (list rdb 1 #f (file-lock! (rdb 'filename))))
+ (and dbs (set! dbs (cons entry dbs)))
+ (set! certificate (cadddr entry))))
+ (cond ((or (not certificate) (not (procedure? rdb))) #f)
+ (else
+ (let* ((filename (rdb 'filename))
+ (dbsolid (rdb 'solidify-database))
+ (ret (and dbsolid (dbsolid))))
+ (if (file-unlock! filename certificate)
+ (set-car! (cdddr entry) #f)
+ (slib:warn 'file-unlock! filename certificate 'failed))
+ ret))))
+ (lambda () (and dbs (mdbm:return-dbs dbs))))))
+
+;;@body
+;;@1 will only be closed when the count of @code{open-database} - @0
+;;calls for @1 (and its filename) is 0. @0 returns #t if successful;
+;;and #f otherwise.
+(define (close-database rdb)
+ (let ((dbs #f))
+ (dynamic-wind
+ (lambda () (set! dbs (mdbm:*databases* #f)))
+ (lambda ()
+ (define entry (mdbm:find-db? rdb dbs))
+ (define certificate #f)
+ (and entry (set! rdb (car entry)))
+ (and (procedure? rdb)
+ (set! certificate (or (and entry (cadddr entry))
+ (and (rdb 'filename)
+ (file-lock! (rdb 'filename))))))
+ (cond ((and entry (not (eqv? 1 (cadr entry))))
+ (set-car! (cdr entry) (+ -1 (cadr entry)))
+ #f)
+ ((or (not certificate) (not (procedure? rdb)))
+ #f)
+ (else
+ (let* ((filename (rdb 'filename))
+ (dbclose (rdb 'close-database))
+ (ret (and dbclose (dbclose))))
+ (if (not (file-unlock! filename certificate))
+ (slib:warn 'file-unlock! filename certificate 'failed))
+ (cond ((not dbclose) (slib:warn 'database? rdb))
+ ((not entry))
+ (dbs (set! dbs (mdbm:remove-entry dbs entry))))
+ ret))))
+ (lambda () (and dbs (mdbm:return-dbs dbs))))))
+
+;;@body
+;;Prints a table of open database files. The columns are the
+;;base-table type, number of opens, @samp{!} for mutable, the
+;;filename, and the lock certificate (if locked).
+(define (mdbm:report)
+ (require 'printf)
+ (let ((dbs #f))
+ (dynamic-wind
+ (lambda () (set! dbs (mdbm:*databases* #f)))
+ (lambda ()
+ (cond (dbs (for-each (lambda (entry)
+ (printf "%15s %03d %1s %s %s\\n"
+ (or (caddr entry) "?")
+ (cadr entry)
+ (if ((car entry) 'delete-table) '! "")
+ (or ((car entry) 'filename) '-)
+ (or (cadddr entry) "")))
+ dbs))
+ (else (printf "%s lock broken.\\n" 'mdbm:*databases*))))
+ (lambda () (and dbs (mdbm:return-dbs dbs))))))
+;;@example
+;;(mdbm:report)
+;;@print{}
+;; alist-table 003 /usr/local/lib/slib/clrnamdb.scm
+;; alist-table 001 ! sdram.db jaffer@@aubrey.jaffer.3166:1038628199
+;;@end example
+
+
+;;@subsubheading Opening Tables
+
+;;@body
+;;@1 must be a relational database and @2 a symbol.
+;;
+;;@0 returns a "methods" procedure for an existing relational table in
+;;@1 if it exists and can be opened for reading, otherwise returns
+;;@code{#f}.
+(define (open-table rdb table-name)
+ ((rdb 'open-table) table-name #f))
+
+;;@body
+;;@1 must be a relational database and @2 a symbol.
+;;
+;;@0 returns a "methods" procedure for an existing relational table in
+;;@1 if it exists and can be opened in mutable mode, otherwise returns
+;;@code{#f}.
+(define (open-table! rdb table-name)
+ ((rdb 'open-table) table-name #t))
+
+
+;;@subsubheading Defining Tables
+
+;;@body
+;;Adds the domain rows @2 @dots{} to the @samp{*domains-data*} table
+;;in @1. The format of the row is given in @ref{Catalog
+;;Representation}.
+;;
+;;@example
+;;(define-domains rdb '(permittivity #f complex? c64 #f))
+;;@end example
+(define (define-domains rdb . row5)
+ (define add-domain (((rdb 'open-table) '*domains-data* #t) 'row:update))
+ (for-each add-domain row5))
+
+;;@body
+;;Use @code{define-domains} instead.
+(define (add-domain rdb row5)
+ ((((rdb 'open-table) '*domains-data* #t) 'row:update)
+ row5))
+
+;;@args rdb spec-0 @dots{}
+;;Adds tables as specified in @var{spec-0} @dots{} to the open
+;;relational-database @1. Each @var{spec} has the form:
+;;
+;;@lisp
+;;(@r{<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
diff --git a/debian/changelog b/debian/changelog
index 411c3c4..99d04fa 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,73 @@
+slib (3a1-4.2) unstable; urgency=low
+
+ * Non-maintainer upload.
+ * Add guile.init.local for use within the build dir, since otherwise we
+ have an (earlier unnoticed) circular build-dep due to a difference
+ between scm and guile.
+
+ -- Steve Langasek <vorlon@debian.org> Mon, 10 Jan 2005 08:53:33 +0000
+
+slib (3a1-4.1) unstable; urgency=low
+
+ * Non-maintainer upload.
+ * Build-depend on guile-1.6 instead of scm, since the new version of
+ scm is wedged in unstable (closes: #281809).
+
+ -- Steve Langasek <vorlon@debian.org> Sat, 8 Jan 2005 17:56:08 -0800
+
+slib (3a1-4) unstable; urgency=low
+
+ * Also check for expected creation on slibcat. (Closes: #240096)
+
+ -- James LewisMoss <dres@debian.org> Sun, 28 Mar 2004 17:29:19 -0500
+
+slib (3a1-3) unstable; urgency=low
+
+ * Also check for /usr/share/guile/1.6/slib before installing for guile
+ 1.6. (Closes: #239267)
+
+ -- James LewisMoss <dres@debian.org> Mon, 22 Mar 2004 20:53:40 -0500
+
+slib (3a1-2) unstable; urgency=low
+
+ * Add format.scm back into slib until gnucash stops using it.
+ * Call guile-1.6 new-catalog (Closes: #238231)
+
+ -- James LewisMoss <dres@debian.org> Sat, 20 Mar 2004 16:51:07 -0500
+
+slib (3a1-1) unstable; urgency=low
+
+ * New upstream release
+ * Remove Info section from doc-base file (Closes: #186950)
+ * Remove period from end of description (linda, lintian)
+ * html gen fixed upstream (Closes: #111778)
+
+ -- James LewisMoss <dres@debian.org> Sun, 14 Mar 2004 11:56:11 -0500
+
+slib (2d4-2) unstable; urgency=low
+
+ * Fix url for upstream source (Closes: #144981)
+ * Fix typo in slib.texi (enquque->enqueue) (Closes: #147475)
+ * Add build depends.
+
+ -- James LewisMoss <dres@debian.org> Thu, 23 May 2002 13:33:33 -0400
+
+slib (2d4-1) unstable; urgency=low
+
+ * New upstream.
+
+ -- James LewisMoss <dres@debian.org> Fri, 17 May 2002 11:23:06 -0400
+
+slib (2d3-1) unstable; urgency=low
+
+ * New upstream.
+ * Remove texi2html call in debian/rules. Now done upstream. Add make
+ html instead.
+ * Changes to rules and doc-base to conform to upstream html gen
+ * Clean up upstream makefile to make sure it cleans up after itself.
+
+ -- James LewisMoss <dres@debian.org> Sat, 6 Apr 2002 16:27:35 -0500
+
slib (2d2-1) unstable; urgency=low
* New upstream version
@@ -52,7 +122,7 @@ slib (2c7-1) unstable; urgency=low
slib (2c6-2) unstable; urgency=low
* Remove the slib$(VERSION).info file. Cut the diff back down to
- size.
+ size.
-- James LewisMoss <dres@debian.org> Sat, 13 Nov 1999 14:10:38 -0500
@@ -95,7 +165,7 @@ slib (2c5-3) unstable; urgency=low
slib (2c5-2) unstable; urgency=low
* Link mklibcat.scm to mklibcat. Fixes a problem with using slib with
- guile.
+ guile.
-- James LewisMoss <dres@debian.org> Sun, 7 Mar 1999 21:51:35 -0500
@@ -159,5 +229,3 @@ slib (2a6-1) unstable; urgency=low
* First Debian release.
-- Karl Sackett <krs@debian.org> Mon, 16 Dec 1996 09:23:46 -0600
-
-
diff --git a/debian/control b/debian/control
index d4392b7..084f82f 100644
--- a/debian/control
+++ b/debian/control
@@ -2,13 +2,14 @@ Source: slib
Section: devel
Priority: optional
Maintainer: James LewisMoss <dres@debian.org>
-Standards-Version: 3.0.0
+Build-Depends-Indep: guile-1.6, texi2html, texinfo
+Standards-Version: 3.1.0
Package: slib
Section: devel
Priority: optional
Architecture: all
-Description: Portable Scheme library.
+Description: Portable Scheme library
SLIB is a portable scheme library meant to provide compatibility and
utility functions for all standard scheme implementations. SLIB
includes initialization files for Chez, ELK 2.1, GAMBIT, MacScheme,
diff --git a/debian/copyright b/debian/copyright
index 2a18aa9..0445f9e 100644
--- a/debian/copyright
+++ b/debian/copyright
@@ -1,9 +1,10 @@
This is the Debian GNU/Linux prepackaged version of slib.
-This package was put together by Rob Browning <rlb@cs.utexas.edu>
-from sources obtained from:
+This package was put together by Rob Browning <rlb@cs.utexas.edu> and
+continued by James LewisMoss <dres@debian.org> from sources obtained
+from:
- ftp://swiss-ftp.ai.mit.edu/archive/scm/slib2d1.zip
+ http://swissnet.ai.mit.edu/ftpdir/scm/slib2d4.zip
For more information see:
diff --git a/debian/doc-base b/debian/doc-base
index 72e6327..dc4d265 100644
--- a/debian/doc-base
+++ b/debian/doc-base
@@ -5,11 +5,6 @@ Abstract: This manual describes the facilities and functions
provided by the slib scheme library.
Section: Apps/Programming
-Format: Info
-Section: The Algorithmic Language Scheme
-Index: /usr/share/info/slib.info.gz
-Files: /usr/share/info/slib.info.gz
-
Format: HTML
-Index: /usr/share/doc/slib/slib.html
-Files: /usr/share/doc/slib/slib.html
+Index: /usr/share/doc/slib/slib_toc.html
+Files: /usr/share/doc/slib/slib_*.html
diff --git a/debian/postinst b/debian/postinst
index 847a44a..88aa502 100644
--- a/debian/postinst
+++ b/debian/postinst
@@ -15,10 +15,12 @@ if [ -x /usr/sbin/guile1.4-slibconfig ] ; then
/usr/sbin/guile1.4-slibconfig
fi
-if [ "$1" = "configure" ]; then
- if [ -d /usr/doc -a ! -e /usr/doc/slib -a -d /usr/share/doc/slib ]; then
- ln -sf ../share/doc/slib /usr/doc/slib
- fi
+if [ -x /usr/bin/guile-1.6 -a -e /usr/share/guile/1.6/slib ] ; then
+ rm -f /usr/share/guile/1.6/slibcat
+ /usr/bin/guile-1.6 -c "(use-modules (ice-9 slib)) (require 'new-catalog)"
+ if [ -e /usr/share/guile/1.6/slibcat ] ; then
+ chmod 644 /usr/share/guile/1.6/slibcat
+ fi
fi
# doc base support
diff --git a/debian/rules b/debian/rules
index f690acd..ed0da6b 100755
--- a/debian/rules
+++ b/debian/rules
@@ -1,6 +1,9 @@
#! /usr/bin/make -f
# -*-Makefile-*-
+SCHEME_LIBRARY_PATH=./
+export SCHEME_LIBRARY_PATH
+
CC =gcc
CFLAGS =-O2 -g -Wall
LDFLAGS =
@@ -17,12 +20,11 @@ INSTALL_MAN =$(INSTALL) -m 444 -o root -g root
build:
$(checkdir)
make
- texi2html -monolithic slib.texi
+ make html
touch build
clean:
$(checkdir)
- -rm slib.html
-rm slib.info*
make clean
-rm -f build
@@ -60,7 +62,7 @@ binary-indep: checkroot build
gzip -9v debian/tmp/usr/share/doc/slib/README
$(INSTALL_DATA) FAQ debian/tmp/usr/share/doc/slib
gzip -9v debian/tmp/usr/share/doc/slib/FAQ
- $(INSTALL_DATA) slib.html debian/tmp/usr/share/doc/slib
+ $(INSTALL_DATA) slib_html/*.html debian/tmp/usr/share/doc/slib
$(INSTALL_DIR) debian/tmp/usr/share/slib/init
$(INSTALL_DATA) *.init debian/tmp/usr/share/slib/init
diff --git a/debug.scm b/debug.scm
index 0a913b4..73acc0b 100644
--- a/debug.scm
+++ b/debug.scm
@@ -8,7 +8,7 @@
;1. Any copy made of this software must include this copyright notice
;in full.
;
-;2. I have made no warrantee or representation that the operation of
+;2. I have made no warranty or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
@@ -62,7 +62,7 @@
(let ((sym (get-defined-symbol (cadr form))))
(cond ((procedure? (slib:eval sym))
(proc sym)))))))))
-
+;@
(define (trace-all file . ...)
(for-each
(lambda (file)
@@ -87,7 +87,7 @@
(lambda (sym)
(slib:eval `(set! ,sym (trace:trace-procedure 'stack ,sym ',sym))))))
(cons file ...)))
-
+;@
(define (break-all file . ...)
(for-each
(lambda (file)
diff --git a/defmacex.scm b/defmacex.scm
index 5863c94..71d7b6c 100644
--- a/defmacex.scm
+++ b/defmacex.scm
@@ -8,7 +8,7 @@
;1. Any copy made of this software must include this copyright notice
;in full.
;
-;2. I have made no warrantee or representation that the operation of
+;2. I have made no warranty or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
@@ -38,7 +38,7 @@
(else (map1 (lambda (e) (iqq e depth)) e)))
e))))
(iqq e depth)))
-
+;@
(define (defmacro:expand* e)
(if (pair? e)
(let* ((c (macroexpand-1 e)))
diff --git a/determ.scm b/determ.scm
index 4b53e5f..1078750 100644
--- a/determ.scm
+++ b/determ.scm
@@ -1,14 +1,147 @@
-;"determ.scm" Determinant
+;;; "determ.scm" Matrix Algebra
+;Copyright 2002 Aubrey Jaffer
+;
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
+;
+;1. Any copy made of this software must include this copyright notice
+;in full.
+;
+;2. I have made no warranty or representation that the operation of
+;this software will be error-free, and I am under no obligation to
+;provide any services, by way of maintenance, update, or otherwise.
+;
+;3. In conjunction with products arising from the use of this
+;material, there shall be no use of my name in any advertising,
+;promotional, or sales literature without prior written consent in
+;each case.
-(define (determinant m)
+(require 'array)
+
+;;@code{(require 'determinant)}
+;;@ftindex determinant
+
+;;@noindent
+;;A Matrix can be either a list of lists (rows) or an array.
+;;As with linear-algebra texts, this package uses 1-based coordinates.
+
+;;; Internal conversion routines
+(define (matrix2array matrix prototype)
+ (let* ((shp (list (list 1 (length matrix))
+ (list 1 (length (car matrix)))))
+ (mat (apply create-array '#() shp)))
+ (do ((idx 1 (+ 1 idx))
+ (rows matrix (cdr rows)))
+ ((> idx (cadar shp)) rows)
+ (do ((jdx 1 (+ 1 jdx))
+ (row (car rows) (cdr row)))
+ ((> jdx (cadadr shp)))
+ (array-set! mat (car row) idx jdx)))
+ mat))
+(define (matrix2lists matrix)
+ (let ((shp (array-shape matrix)))
+ (do ((idx (cadar shp) (+ -1 idx))
+ (rows '()
+ (cons (do ((jdx (cadadr shp) (+ -1 jdx))
+ (row '() (cons (array-ref matrix idx jdx) row)))
+ ((< jdx (caadr shp)) row))
+ rows)))
+ ((< idx (caar shp)) rows))))
+(define (coerce-like-arg matrix arg)
+ (cond ((array? arg) (matrix2array matrix arg))
+ (else matrix)))
+
+;;@body
+;;Returns the list-of-lists form of @1.
+(define (matrix->lists matrix)
+ (cond ((array? matrix)
+ (if (not (eqv? 2 (array-rank matrix)))
+ (slib:error 'not 'matrix matrix))
+ (matrix2lists matrix))
+ ((and (pair? matrix) (list? (car matrix))) matrix)
+ ((vector? matrix) (list (vector->list matrix)))
+ (else (slib:error 'not 'matrix matrix))))
+
+;;@body
+;;Returns the (ones-based) array form of @1.
+(define (matrix->array matrix)
+ (cond ((array? matrix)
+ (if (not (eqv? 2 (array-rank matrix)))
+ (slib:error 'not 'matrix matrix))
+ matrix)
+ ((and (pair? matrix) (list? (car matrix)))
+ (matrix2array matrix '#()))
+ ((vector? matrix) matrix)
+ (else (slib:error 'not 'matrix matrix))))
+
+(define (matrix:cofactor matrix i j)
+ (define mat (matrix->lists matrix))
(define (butnth n lst)
- (if (zero? n) (cdr lst) (cons (car lst) (butnth (+ -1 n) (cdr lst)))))
- (define (minor m i j)
- (map (lambda (x) (butnth j x)) (butnth i m)))
- (define (cofactor m i j)
- (* (if (odd? (+ i j)) -1 1) (determinant (minor m i j))))
- (define n (length m))
- (if (eqv? 1 n) (caar m)
- (do ((j (+ -1 n) (+ -1 j))
- (ans 0 (+ ans (* (list-ref (car m) j) (cofactor m 0 j)))))
- ((negative? j) ans))))
+ (if (<= n 1) (cdr lst) (cons (car lst) (butnth (+ -1 n) (cdr lst)))))
+ (define (minor matrix i j)
+ (map (lambda (x) (butnth j x)) (butnth i mat)))
+ (coerce-like-arg
+ (* (if (odd? (+ i j)) -1 1) (determinant (minor mat i j)))
+ matrix))
+
+;;@body
+;;@1 must be a square matrix.
+;;@0 returns the determinant of @1.
+;;
+;;@example
+;;(require 'determinant)
+;;(determinant '((1 2) (3 4))) @result{} -2
+;;(determinant '((1 2 3) (4 5 6) (7 8 9))) @result{} 0
+;;@end example
+(define (determinant matrix)
+ (define mat (matrix->lists matrix))
+ (let ((n (length mat)))
+ (if (eqv? 1 n) (caar mat)
+ (do ((j n (+ -1 j))
+ (ans 0 (+ ans (* (list-ref (car mat) (+ -1 j))
+ (matrix:cofactor mat 1 j)))))
+ ((<= j 0) ans)))))
+
+;;@body
+;;Returns a copy of @1 flipped over the diagonal containing the 1,1
+;;element.
+(define (transpose matrix)
+ (if (number? matrix)
+ matrix
+ (let ((mat (matrix->lists matrix)))
+ (coerce-like-arg (apply map list mat)
+ matrix))))
+
+;;@body
+;;Returns the product of matrices @1 and @2.
+(define (matrix:product m1 m2)
+ (define mat1 (matrix->lists m1))
+ (define mat2 (matrix->lists m2))
+ (define (dot-product v1 v2) (apply + (map * v1 v2)))
+ (coerce-like-arg
+ (map (lambda (arow)
+ (apply map
+ (lambda bcol (dot-product bcol arow))
+ mat2))
+ mat1)
+ m1))
+
+;;@body
+;;@1 must be a square matrix.
+;;If @1 is singlar, then @0 returns #f; otherwise @0 returns the
+;;@code{matrix:product} inverse of @1.
+(define (matrix:inverse matrix)
+ (let* ((mat (matrix->lists matrix))
+ (det (determinant mat))
+ (rank (length mat)))
+ (and (not (zero? det))
+ (do ((i rank (+ -1 i))
+ (inv '() (cons
+ (do ((j rank (+ -1 j))
+ (row '()
+ (cons (/ (matrix:cofactor mat j i) det) row)))
+ ((<= j 0) row))
+ inv)))
+ ((<= i 0)
+ (coerce-like-arg inv matrix))))))
diff --git a/determ.txi b/determ.txi
new file mode 100644
index 0000000..30eef3d
--- /dev/null
+++ b/determ.txi
@@ -0,0 +1,47 @@
+@code{(require 'determinant)}
+@ftindex determinant
+
+@noindent
+A Matrix can be either a list of lists (rows) or an array.
+As with linear-algebra texts, this package uses 1-based coordinates.
+
+
+@defun matrix->lists matrix
+
+Returns the list-of-lists form of @var{matrix}.
+@end defun
+
+@defun matrix->array matrix
+
+Returns the (ones-based) array form of @var{matrix}.
+@end defun
+
+@defun determinant matrix
+
+@var{matrix} must be a square matrix.
+@code{determinant} returns the determinant of @var{matrix}.
+
+@example
+(require 'determinant)
+(determinant '((1 2) (3 4))) @result{} -2
+(determinant '((1 2 3) (4 5 6) (7 8 9))) @result{} 0
+@end example
+@end defun
+
+@defun transpose matrix
+
+Returns a copy of @var{matrix} flipped over the diagonal containing the 1,1
+element.
+@end defun
+
+@defun matrix:product m1 m2
+
+Returns the product of matrices @var{m1} and @var{m2}.
+@end defun
+
+@defun matrix:inverse matrix
+
+@var{matrix} must be a square matrix.
+If @var{matrix} is singlar, then @code{matrix:inverse} returns #f; otherwise @code{matrix:inverse} returns the
+@code{matrix:product} inverse of @var{matrix}.
+@end defun
diff --git a/differ.scm b/differ.scm
index 53e0eaf..23b0e91 100644
--- a/differ.scm
+++ b/differ.scm
@@ -1,5 +1,5 @@
;;;; "differ.scm" O(NP) Sequence Comparison Algorithm.
-;;; Copyright (C) 2001 Aubrey Jaffer
+;;; Copyright (C) 2001, 2002, 2003 Aubrey Jaffer
;
;Permission to copy this software, to modify it, to redistribute it,
;to distribute modified versions, and to use it for any purpose is
@@ -8,7 +8,7 @@
;1. Any copy made of this software must include this copyright notice
;in full.
;
-;2. I have made no warrantee or representation that the operation of
+;2. I have made no warranty or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
@@ -18,7 +18,7 @@
;each case.
;;@noindent
-;;This package implements the algorithm:
+;;@code{diff:edit-length} implements the algorithm:
;;
;;@ifinfo
;;@example
@@ -37,186 +37,403 @@
;;@end ifset
;;
;;@noindent
-;;If the items being sequenced are text lines, then the computed
-;;edit-list is equivalent to the output of the @dfn{diff} utility
-;;program. If the items being sequenced are words, then it is like the
-;;lesser known @dfn{spiff} program.
-;;
-;;@noindent
;;The values returned by @code{diff:edit-length} can be used to gauge
;;the degree of match between two sequences.
;;
;;@noindent
-;;I believe that this algorithm is currently the fastest for these
-;;tasks, but genome sequencing applications fuel extensive research in
-;;this area.
+;;Surprisingly, "An O(NP) Sequence Comparison Algorithm" does not
+;;derive the edit sequence; only the sequence length. Developing this
+;;linear-space sub-quadratic-time algorithm for computing the edit
+;;sequence required hundreds of hours of work. I have submitted a
+;;paper describing the algorithm to the Journal of Computational
+;;Biology.
+;;
+;;@noindent
+;;If the items being sequenced are text lines, then the computed
+;;edit-list is equivalent to the output of the @dfn{diff} utility
+;;program. If the items being sequenced are words, then it is like the
+;;lesser known @dfn{spiff} program.
(require 'array)
+(require 'sort)
-(define (fp:compare fp Delta snake len2)
+;;; p-lim is half the number of gratuitous edits for strings of given
+;;; lengths.
+;;; When passed #f CC, fp:compare returns edit-distance if successful;
+;;; #f otherwise (p > p-lim). When passed CC, fp:compare returns #f.
+(define (fp:compare fp CC A M B N =? p-lim)
+ (define Delta (- N M))
+ ;;(if (negative? Delta) (slib:error 'fp:compare (fp:subarray A 0 M) '> (fp:subarray B 0 N)))
+ ;;(set! compares (+ 1 compares)) ;(print 'fp:compare M N p-lim)
(let loop ((p 0))
(do ((k (- p) (+ 1 k)))
- ((> k (+ -1 Delta)))
- (array-set! fp (snake k (max (+ 1 (array-ref fp (+ -1 k)))
- (array-ref fp (+ 1 k))))
- k))
+ ((>= k Delta))
+ (fp:run fp k A M B N =? CC p))
(do ((k (+ Delta p) (+ -1 k)))
- ((< k (+ 1 Delta)))
- (array-set! fp (snake k (max (+ 1 (array-ref fp (+ -1 k)))
- (array-ref fp (+ 1 k))))
- k))
- (array-set! fp (snake Delta (max (+ 1 (array-ref fp (+ -1 Delta)))
- (array-ref fp (+ 1 Delta))))
- Delta)
- (if (= (array-ref fp Delta) len2)
- (+ Delta (* 2 p))
- (loop (+ 1 p)))))
-
-(define (fp->edits fp Delta)
- (let loop ((idx (+ -1 Delta))
- (ddx (+ 1 Delta))
- (edits '()))
- (define ivl (array-ref fp idx))
- (define dvl (array-ref fp ddx))
- (if (not (= -1 dvl)) (set! dvl (- dvl ddx)))
- ;;(print idx '-> ivl ddx '-> dvl)
- (cond ((= ivl -1) edits)
- ((= dvl -1) (loop (+ -1 idx) ddx (cons (list ivl 'insert) edits)))
- ((> dvl ivl) (loop idx (+ 1 ddx) (cons (list dvl 'delete) edits)))
- (else (loop (+ -1 idx) ddx (cons (list ivl 'insert) edits))))))
-
-(define (fp->lcs fp Delta array1 len)
- (define len1 (car (array-dimensions array1)))
- (define lcs (make-array #f len))
- (define (subarray-copy! array1 start1 end1 array2 start2)
- (do ((i start1 (+ i 1))
- (j start2 (+ j 1))
- (l (- end1 start1) (- l 1)))
- ((<= l 0))
- (array-set! array2 (array-ref array1 i) j)))
- (let loop ((ddx (+ 1 Delta))
- (pos len1)
- (dpos len))
- (let* ((dvl (array-ref fp ddx))
- (sublen (- pos (- dvl ddx -1))))
- (cond ((= dvl -1)
- (subarray-copy! array1 0 pos lcs 0)
- lcs)
+ ((<= k Delta))
+ (fp:run fp k A M B N =? CC p))
+ (let ((fpval (fp:run fp Delta A M B N =? CC p)))
+ ;; At this point, the cost to (fpval-Delta, fpval) is Delta + 2*p
+ (cond ((and (not CC) (<= N fpval)) (+ Delta (* 2 p)))
+ ((and (not (negative? p-lim)) (>= p p-lim)) #f)
+ (else (loop (+ 1 p)))))))
+
+;;; Traces runs of matches until they end; then set fp[k]=y.
+;;; If CC is supplied, set each CC[y] = min(CC[y], cost) for run.
+;;; Returns furthest y reached.
+(define (fp:run fp k A M B N =? CC p)
+ (define y (max (+ 1 (array-ref fp (+ -1 k))) (array-ref fp (+ 1 k))))
+ (define cost (+ k p p))
+ (let snloop ((x (- y k))
+ (y y))
+ (and CC (<= y N)
+ (let ((xcst (- M x)))
+ (cond ((negative? xcst))
+ (else (array-set! CC
+ (min (+ xcst cost) (array-ref CC y))
+ y)))))
+ ;;(set! tick (+ 1 tick))
+ (cond ((and (< x M) (< y N)
+ (=? (array-ref A x) (array-ref B y)))
+ (snloop (+ 1 x) (+ 1 y)))
+ (else (array-set! fp y k)
+ y))))
+
+;;; Check that only 1 and -1 steps between adjacent CC entries.
+;;(define (fp:step-check A M B N CC)
+;; (do ((cdx (+ -1 N) (+ -1 cdx)))
+;; ((negative? cdx))
+;; (case (- (array-ref CC cdx) (array-ref CC (+ 1 cdx)))
+;; ((1 -1) #t)
+;; (else (cond ((> 30 (car (array-dimensions CC)))
+;; (display "A: ") (print A)
+;; (display "B: ") (print B)))
+;; (slib:warn
+;; "CC" (append (list (max 0 (+ -5 cdx)) ': (min (+ 1 N) (+ 5 cdx))
+;; 'of)
+;; (array-dimensions CC))
+;; (fp:subarray CC (max 0 (+ -5 cdx)) (min (+ 1 N) (+ 5 cdx))))))))
+
+;;; Correct cost jumps left by fp:compare [which visits only a few (x,y)].
+;;(define (smooth-costs CC N)
+;; (do ((cdx (+ -1 N) (+ -1 cdx))) ; smooth from end
+;; ((negative? cdx))
+;; (array-set! CC (min (array-ref CC cdx) (+ 1 (array-ref CC (+ 1 cdx))))
+;; cdx))
+;; (do ((cdx 1 (+ 1 cdx))) ; smooth toward end
+;; ((> cdx N))
+;; (array-set! CC (min (array-ref CC cdx) (+ 1 (array-ref CC (+ -1 cdx))))
+;; cdx))
+;; CC)
+
+(define (diff:mid-split M N RR CC cost)
+ (define b-splt N) ;Default
+ (define bestrun 0)
+ (define thisrun 0)
+ ;; RR is not longer than CC. So do for each element of RR.
+ (let loop ((cdx (+ 1 (quotient N 2)))
+ (rdx (quotient N 2)))
+ ;;(if (negative? rdx) (slib:error 'negative? 'rdx))
+ (cond ((eqv? cost (+ (array-ref CC rdx) (array-ref RR (- N rdx)))) rdx)
+ ((eqv? cost (+ (array-ref CC cdx) (array-ref RR (- N cdx)))) cdx)
+ (else (loop (+ 1 cdx) (+ -1 rdx))))))
+
+;;; Return 0-based shared array.
+;;; Reverse RA if END < START.
+(define (fp:subarray RA start end)
+ (define n-len (abs (- end start)))
+ (if (< end start)
+ (make-shared-array RA (lambda (idx) (list (- start 1 idx))) n-len)
+ (make-shared-array RA (lambda (idx) (list (+ start idx))) n-len)))
+
+(define (fp:init! fp fill mindx maxdx)
+ (do ((idx maxdx (+ -1 idx)))
+ ((< idx mindx))
+ (array-set! fp fill idx)))
+
+;;; Split A[start-a..end-a] (shorter array) into smaller and smaller chunks.
+;;; EDX is index into EDITS.
+;;; EPO is insert/delete polarity (+1 or -1)
+(define (diff:divide-and-conquer fp CCRR A start-a end-a B start-b end-b edits edx epo =? p-lim)
+ (define mid-a (quotient (+ start-a end-a) 2))
+ (define len-b (- end-b start-b))
+ (define len-a (- end-a start-a))
+ (let ((tcst (+ p-lim p-lim (- len-b len-a))))
+ (define CC (fp:subarray CCRR 0 (+ len-b 1)))
+ (define RR (fp:subarray CCRR (+ len-b 1) (* 2 (+ len-b 1))))
+ (define M2 (- end-a mid-a))
+ (define M1 (- mid-a start-a))
+ (fp:init! CC (+ len-a len-b) 0 len-b)
+ (fp:init! fp -1 (- (+ 1 p-lim)) (+ 1 p-lim (- len-b M1)))
+ (fp:compare fp CC
+ (fp:subarray A start-a mid-a) M1
+ (fp:subarray B start-b end-b) len-b =? (min p-lim len-a))
+ (fp:init! RR (+ len-a len-b) 0 len-b)
+ (fp:init! fp -1 (- (+ 1 p-lim)) (+ 1 p-lim (- len-b M2)))
+ (fp:compare fp RR
+ (fp:subarray A end-a mid-a) M2
+ (fp:subarray B end-b start-b) len-b =? (min p-lim len-a))
+ ;;(smooth-costs CC len-b) (smooth-costs RR len-b)
+ (let ((b-splt (diff:mid-split len-a len-b RR CC tcst)))
+ (define est-c (array-ref CC b-splt))
+ (define est-r (array-ref RR (- len-b b-splt)))
+ ;;(set! splts (cons (/ b-splt (max .1 len-b)) splts))
+ ;;(display "A: ") (array-for-each display (fp:subarray A start-a mid-a)) (display " + ") (array-for-each display (fp:subarray A mid-a end-a)) (newline)
+ ;;(display "B: ") (array-for-each display (fp:subarray B start-b end-b)) (newline)
+ ;;(print 'cc cc) (print 'rr (fp:subarray RR (+ 1 len-b) 0))
+ ;;(print (make-string (+ 7 (* 2 b-splt)) #\-) '^ (list b-splt))
+ (check-cost! 'CC est-c
+ (diff2et fp CCRR
+ A start-a mid-a
+ B start-b (+ start-b b-splt)
+ edits edx epo =?
+ (quotient (- est-c (- b-splt (- mid-a start-a)))
+ 2)))
+ (check-cost! 'RR est-r
+ (diff2et fp CCRR
+ A mid-a end-a
+ B (+ start-b b-splt) end-b
+ edits (+ est-c edx) epo =?
+ (quotient (- est-r (- (- len-b b-splt)
+ (- end-a mid-a)))
+ 2)))
+ (+ est-c est-r))))
+
+;;; Trim; then diff sub-arrays; either one longer. Returns edit-length
+(define (diff2et fp CCRR A start-a end-a B start-b end-b edits edx epo =? p-lim)
+ ;; (if (< (- end-a start-a) p-lim) (slib:warn 'diff2et 'len-a (- end-a start-a) 'len-b (- end-b start-b) 'p-lim p-lim))
+ (do ((bdx (+ -1 end-b) (+ -1 bdx))
+ (adx (+ -1 end-a) (+ -1 adx)))
+ ((not (and (<= start-b bdx)
+ (<= start-a adx)
+ (=? (array-ref A adx) (array-ref B bdx))))
+ (do ((bsx start-b (+ 1 bsx))
+ (asx start-a (+ 1 asx)))
+ ((not (and (< bsx bdx)
+ (< asx adx)
+ (=? (array-ref A asx) (array-ref B bsx))))
+ ;;(print 'trim-et (- asx start-a) '+ (- end-a adx))
+ (let ((delta (- (- bdx bsx) (- adx asx))))
+ (if (negative? delta)
+ (diff2ez fp CCRR B bsx (+ 1 bdx) A asx (+ 1 adx)
+ edits edx (- epo) =? (+ delta p-lim))
+ (diff2ez fp CCRR A asx (+ 1 adx) B bsx (+ 1 bdx)
+ edits edx epo =? p-lim))))
+ ;;(set! tick (+ 1 tick))
+ ))
+ ;;(set! tick (+ 1 tick))
+ ))
+
+;;; Diff sub-arrays, A not longer than B. Returns edit-length
+(define (diff2ez fp CCRR A start-a end-a B start-b end-b edits edx epo =? p-lim)
+ (define len-a (- end-a start-a))
+ (define len-b (- end-b start-b))
+ ;;(if (> len-a len-b) (slib:error 'diff2ez len-a '> len-b))
+ (cond ((zero? p-lim) ; B inserts only
+ (if (= len-b len-a)
+ 0 ; A = B; no edits
+ (let loop ((adx start-a)
+ (bdx start-b)
+ (edx edx))
+ (cond ((>= bdx end-b) (- len-b len-a))
+ ((>= adx end-a)
+ (do ((idx bdx (+ 1 idx))
+ (edx edx (+ 1 edx)))
+ ((>= idx end-b) (- len-b len-a))
+ (array-set! edits (* epo (+ 1 idx)) edx)))
+ ((=? (array-ref A adx) (array-ref B bdx))
+ ;;(set! tick (+ 1 tick))
+ (loop (+ 1 adx) (+ 1 bdx) edx))
+ (else (array-set! edits (* epo (+ 1 bdx)) edx)
+ ;;(set! tick (+ 1 tick))
+ (loop adx (+ 1 bdx) (+ 1 edx)))))))
+ ((<= len-a p-lim) ; delete all A; insert all B
+ ;;(if (< len-a p-lim) (slib:error 'diff2ez len-a len-b 'p-lim p-lim))
+ (do ((idx start-a (+ 1 idx))
+ (edx edx (+ 1 edx)))
+ ((>= idx end-a)
+ (do ((jdx start-b (+ 1 jdx))
+ (edx edx (+ 1 edx)))
+ ((>= jdx end-b))
+ (array-set! edits (* epo (+ 1 jdx)) edx)))
+ (array-set! edits (* epo (- -1 idx)) edx))
+ (+ len-a len-b))
+ (else (diff:divide-and-conquer
+ fp CCRR A start-a end-a B start-b end-b
+ edits edx epo =? p-lim))))
+
+;;;Return new vector of edits in correct sequence
+(define (diff:order-edits edits cost sign)
+ (if (negative? sign)
+ (do ((idx (+ -1 cost) (+ -1 idx)))
+ ((negative? idx))
+ (array-set! edits (- (array-ref edits idx)) idx)))
+ (if (zero? cost)
+ edits
+ (let ((sedits (sort! edits <))
+ (nedits (create-array (As32) cost)))
+ ;; Find -/+ boundary
+ (define len-a (max 0 (- (array-ref sedits 0))))
+ (define len-b (array-ref sedits (+ -1 cost)))
+ (do ((idx 0 (+ 1 idx)))
+ ((or (>= idx cost) (positive? (array-ref sedits idx)))
+ (let loop ((ddx (+ -1 idx))
+ (idx idx)
+ (ndx 0)
+ (adx 0)
+ (bdx 0))
+ (define del (if (negative? ddx) 0 (array-ref sedits ddx)))
+ (define ins (if (>= idx cost) 0 (array-ref sedits idx)))
+ (cond ((and (>= bdx len-b) (>= adx len-a)) nedits)
+ ((and (negative? del) (>= adx (- -1 del))
+ (positive? ins) (>= bdx (+ -1 ins)))
+ (array-set! nedits del ndx)
+ (array-set! nedits ins (+ 1 ndx))
+ (loop (+ -1 ddx) (+ 1 idx) (+ 2 ndx)
+ (+ 1 adx) (+ 1 bdx)))
+ ((and (negative? del) (>= adx (- -1 del)))
+ (array-set! nedits del ndx)
+ (loop (+ -1 ddx) idx (+ 1 ndx) (+ 1 adx) bdx))
+ ((and (positive? ins) (>= bdx (+ -1 ins)))
+ (array-set! nedits ins ndx)
+ (loop ddx (+ 1 idx) (+ 1 ndx) adx (+ 1 bdx)))
+ (else
+ (loop ddx idx ndx (+ 1 adx) (+ 1 bdx))))))))))
+
+;;; len-a < len-b
+(define (edits2lcs lcs edits cost A len-a len-b)
+ (let loop ((edx 0)
+ (sdx 0)
+ (adx 0))
+ (let ((edit (if (< edx cost)
+ (array-ref edits edx)
+ 0)))
+ (cond ((>= adx len-a) lcs)
+ ((positive? edit)
+ (loop (+ 1 edx) sdx adx))
+ ((zero? edit)
+ (array-set! lcs (array-ref A adx) sdx)
+ (loop edx (+ 1 sdx) (+ 1 adx)))
+ ((>= adx (- -1 edit))
+ (loop (+ 1 edx) sdx (+ 1 adx)))
(else
- (subarray-copy! array1 (- dvl ddx -1) pos lcs (- dpos sublen))
- (loop (+ 1 ddx) (- dvl ddx) (- dpos sublen)))))))
+ (array-set! lcs (array-ref A adx) sdx)
+ (loop edx (+ 1 sdx) (+ 1 adx)))))))
+
+;; A not longer than B (M <= N)
+(define (diff2edits A M B N =? p-lim)
+ (define maxdx (if (negative? p-lim) (+ 2 N) (+ 1 p-lim (- N M))))
+ (define mindx (if (negative? p-lim) (- (+ 1 M)) (- (+ 1 p-lim))))
+ ;;(if (> M N) (slib:error 'diff2edits M '> N))
+ (let ((fp (create-array (As32) (list mindx maxdx)))
+ (CCRR (create-array (As32) (* 2 (+ N 1)))))
+ (fp:init! fp -1 mindx maxdx)
+ (let ((est (fp:compare fp #f A M B N =? p-lim)))
+ (and est
+ (let ((edits (create-array (As32) est)))
+ (check-cost! 'diff2edits
+ est
+ (diff2et fp CCRR A 0 M B 0 N edits 0 1 =?
+ (quotient (- est (- N M)) 2)))
+ edits)))))
+;; A not longer than B (M <= N)
+(define (diff2editlen A M B N =? p-lim)
+ (define maxdx (if (negative? p-lim) (+ 1 N) (+ 1 p-lim (- N M))))
+ (define mindx (if (negative? p-lim) (- (+ 1 M)) (- (+ 1 p-lim))))
+ (let ((fp (create-array (As32) (list mindx maxdx))))
+ (fp:init! fp -1 mindx maxdx)
+ (fp:compare fp #f A M B N =? p-lim)))
+
+(define (check-cost! name est cost)
+ (if (not (eqv? est cost))
+ (slib:warn "%s: cost check failed %d != %d\\n" name est cost)))
+
+;;@args array1 array2 =? p-lim
;;@args array1 array2 =?
-;;@args array1 array2
;;@1 and @2 are one-dimensional arrays. The procedure @3 is used
-;;to compare sequence tokens for equality. @3 defaults to @code{eqv?}.
+;;to compare sequence tokens for equality.
+;;
+;;The non-negative integer @4, if provided, is maximum number of
+;;deletions of the shorter sequence to allow. @0 will return @code{#f}
+;;if more deletions would be necessary.
+;;
;;@0 returns a one-dimensional array of length @code{(quotient (- (+
-;;len1 len2) (fp:edit-length @1 @2)) 2)} holding the longest sequence
+;;len1 len2) (diff:edit-length @1 @2)) 2)} holding the longest sequence
;;common to both @var{array}s.
-(define (diff:longest-common-subsequence array1 array2 . =?)
- (define len1 (car (array-dimensions array1)))
- (define len2 (car (array-dimensions array2)))
- (define (snake k y)
- (let snloop ((x (- y k))
- (y y))
- (if (and (< x len1) (< y len2) (=? (array-ref array1 x)
- (array-ref array2 y)))
- (snloop (+ 1 x) (+ 1 y))
- y)))
- (set! =? (if (null? =?) eqv? (car =?)))
- (if (> len1 len2)
- (diff:longest-common-subsequence array2 array1)
- (let ((Delta (- len2 len1))
- (fp (make-array -1 (list (- (+ 1 len1)) (+ 1 len2)))))
- (fp->lcs fp Delta array1
- (quotient (- (+ len1 len2) (fp:compare fp Delta snake len2))
- 2)))))
+(define (diff:longest-common-subsequence A B =? . p-lim)
+ (define len-a (car (array-dimensions a)))
+ (define len-b (car (array-dimensions b)))
+ (set! p-lim (if (null? p-lim) -1 (car p-lim)))
+ (let ((edits (if (< len-b len-a)
+ (diff2edits B len-b A len-a =? p-lim)
+ (diff2edits A len-a B len-b =? p-lim))))
+ (and edits
+ (let* ((cost (car (array-dimensions edits)))
+ (sedit (diff:order-edits edits cost (if (< len-b len-a) -1 1)))
+ (lcs (create-array A (/ (- (+ len-b len-a) cost) 2))))
+ (if (< len-b len-a)
+ (edits2lcs lcs sedit cost B len-b len-a)
+ (edits2lcs lcs sedit cost A len-a len-b))))))
+;;@args array1 array2 =? p-lim
;;@args array1 array2 =?
-;;@args array1 array2
;;@1 and @2 are one-dimensional arrays. The procedure @3 is used
-;;to compare sequence tokens for equality. @3 defaults to @code{eqv?}.
-;;@0 returns a list of length @code{(fp:edit-length @1 @2)} composed of
-;;a shortest sequence of edits transformaing @1 to @2.
+;;to compare sequence tokens for equality.
;;
-;;Each edit is a list of an integer and a symbol:
+;;The non-negative integer @4, if provided, is maximum number of
+;;deletions of the shorter sequence to allow. @0 will return @code{#f}
+;;if more deletions would be necessary.
+;;
+;;@0 returns a vector of length @code{(diff:edit-length @1 @2)} composed
+;;of a shortest sequence of edits transformaing @1 to @2.
+;;
+;;Each edit is an integer:
;;@table @asis
-;;@item (@var{j} insert)
-;;Inserts @code{(array-ref @1 @var{j})} into the sequence.
-;;@item (@var{k} delete)
-;;Deletes @code{(array-ref @2 @var{k})} from the sequence.
+;;@item @var{k} > 0
+;;Inserts @code{(array-ref @1 (+ -1 @var{j}))} into the sequence.
+;;@item @var{k} < 0
+;;Deletes @code{(array-ref @2 (- -1 @var{k}))} from the sequence.
;;@end table
-(define (diff:edits array1 array2 . =?)
- (define len1 (car (array-dimensions array1)))
- (define len2 (car (array-dimensions array2)))
- (define (snake k y)
- (let snloop ((x (- y k))
- (y y))
- (if (and (< x len1) (< y len2) (=? (array-ref array1 x)
- (array-ref array2 y)))
- (snloop (+ 1 x) (+ 1 y)) y)))
- (set! =? (if (null? =?) eqv? (car =?)))
- (if (> len1 len2)
- (diff:reverse-edits (diff:edits array2 array1))
- (let ((Delta (- len2 len1))
- (fp (make-array -1 (list (- (+ 1 len1)) (+ 1 len2)))))
- (fp:compare fp Delta snake len2)
- ;;(do ((idx (- -1 len1) (+ 1 idx))) ((>= idx (+ 1 len2)) (newline)) (printf "%3d" idx))
- ;;(do ((idx (- -1 len1) (+ 1 idx))) ((>= idx (+ 1 len2)) (newline)) (printf "%3d" (array-ref fp idx)))
- (fp->edits fp Delta))))
-
-(define (diff:reverse-edits edits)
- (map (lambda (edit)
- (list (car edit)
- (case (cadr edit)
- ((delete) 'insert)
- ((insert) 'delete))))
- edits))
+(define (diff:edits A B =? . p-lim)
+ (define len-a (car (array-dimensions a)))
+ (define len-b (car (array-dimensions b)))
+ (set! p-lim (if (null? p-lim) -1 (car p-lim)))
+ (let ((edits (if (< len-b len-a)
+ (diff2edits B len-b A len-a =? p-lim)
+ (diff2edits A len-a B len-b =? p-lim))))
+ (and edits (diff:order-edits edits (car (array-dimensions edits))
+ (if (< len-b len-a) -1 1)))))
+;;@args array1 array2 =? p-lim
;;@args array1 array2 =?
-;;@args array1 array2
;;@1 and @2 are one-dimensional arrays. The procedure @3 is used
-;;to compare sequence tokens for equality. @3 defaults to @code{eqv?}.
+;;to compare sequence tokens for equality.
+;;
+;;The non-negative integer @4, if provided, is maximum number of
+;;deletions of the shorter sequence to allow. @0 will return @code{#f}
+;;if more deletions would be necessary.
+;;
;;@0 returns the length of the shortest sequence of edits transformaing
;;@1 to @2.
-(define (diff:edit-length array1 array2 . =?)
- (define len1 (car (array-dimensions array1)))
- (define len2 (car (array-dimensions array2)))
- (define (snake k y)
- (let snloop ((x (- y k))
- (y y))
- (if (and (< x len1) (< y len2) (=? (array-ref array1 x)
- (array-ref array2 y)))
- (snloop (+ 1 x) (+ 1 y))
- y)))
- (set! =? (if (null? =?) eqv? (car =?)))
- (if (> len1 len2)
- (diff:edit-length array2 array1)
- (let ((Delta (- len2 len1))
- (fp (make-array -1 (list (- (+ 1 len1)) (+ 1 len2)))))
- (fp:compare fp Delta snake len2))))
+(define (diff:edit-length A B =? . p-lim)
+ (define M (car (array-dimensions a)))
+ (define N (car (array-dimensions b)))
+ (set! p-lim (if (null? p-lim) -1 (car p-lim)))
+ (if (< N M)
+ (diff2editlen B N A M =? p-lim)
+ (diff2editlen A M B N =? p-lim)))
;;@example
-;;(diff:longest-common-subsequence '#(f g h i e j c k l m)
-;; '#(f g e h i j k p q r l m))
-;; @result{} #(f g h i j k l m)
+;;(diff:longest-common-subsequence "fghiejcklm" "fgehijkpqrlm" eqv?)
+;;@result{} "fghijklm"
;;
-;;(diff:edit-length '#(f g h i e j c k l m)
-;; '#(f g e h i j k p q r l m))
+;;(diff:edit-length "fghiejcklm" "fgehijkpqrlm" eqv?)
;;@result{} 6
;;
-;;(pretty-print (diff:edits '#(f g h i e j c k l m)
-;; '#(f g e h i j k p q r l m)))
-;;@print{}
-;;((3 insert) ; e
-;; (4 delete) ; c
-;; (6 delete) ; h
-;; (7 insert) ; p
-;; (8 insert) ; q
-;; (9 insert)) ; r
+;;(diff:edits "fghiejcklm" "fgehijkpqrlm" eqv?)
+;;@result{} #As32(3 -5 -7 8 9 10)
+;; ; e c h p q r
;;@end example
-;; 12 - 10 = 2
-;; -11-10 -9 -8 -7 -6 -5 -4 -3 -2 -1 0 1 2 3 4 5 6 7 8 9 10 11 12
-;; -1 -1 -1 -1 -1 -1 -1 -1 -1 3 7 8 9 12 9 8 -1 -1 -1 -1 -1 -1 -1 -1
-;; edit-distance = 6
+;;(trace-all "/home/jaffer/slib/differ.scm")(set! *qp-width* 333)(untrace fp:run fp:subarray)
diff --git a/differ.txi b/differ.txi
index f7b1f75..c46fc2a 100644
--- a/differ.txi
+++ b/differ.txi
@@ -1,5 +1,5 @@
@noindent
-This package implements the algorithm:
+@code{diff:edit-length} implements the algorithm:
@ifinfo
@example
@@ -18,6 +18,18 @@ 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
@@ -25,71 +37,69 @@ program. If the items being sequenced are words, then it is like the
lesser known @dfn{spiff} program.
@cindex spiff
-@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.
+@defun diff:longest-common-subsequence array1 array2 =? p-lim
-@defun diff:longest-common-subsequence array1 array2 =?
+@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.
-@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. @var{=?} defaults to @code{eqv?}.
@code{diff:longest-common-subsequence} returns a one-dimensional array of length @code{(quotient (- (+
-len1 len2) (fp:edit-length @var{array1} @var{array2})) 2)} holding the longest sequence
+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 =?
+@defun diff:edits array1 array2 =? p-lim
-@defunx diff:edits array1 array2
+@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. @var{=?} defaults to @code{eqv?}.
-@code{diff:edits} returns a list of length @code{(fp:edit-length @var{array1} @var{array2})} composed of
-a shortest sequence of edits transformaing @var{array1} to @var{array2}.
+to compare sequence tokens for equality.
-Each edit is a list of an integer and a symbol:
+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{j} insert)
-Inserts @code{(array-ref @var{array1} @var{j})} into the sequence.
-@item (@var{k} delete)
-Deletes @code{(array-ref @var{array2} @var{k})} from the sequence.
+@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 =?
+@defun diff:edit-length array1 array2 =? p-lim
-@defunx diff:edit-length array1 array2
+@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. @var{=?} defaults to @code{eqv?}.
+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 '#(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
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)
diff --git a/elk.init b/elk.init
index 598b935..13fde42 100644
--- a/elk.init
+++ b/elk.init
@@ -1,4 +1,4 @@
-;;;"elk.init" Initialisation file for SLIB for ELK 2.1 -*- Scheme -*-
+;;;"elk.init" Initialisation file for SLIB for ELK 3.0 -*- Scheme -*-
;;; Author: Aubrey Jaffer
;;;
;;; This code is in the public domain.
@@ -16,39 +16,33 @@
;;; (software-type) should be set to the generic operating system type.
;;; UNIX, VMS, MACOS, AMIGA and MS-DOS are supported.
-
(define (software-type) 'UNIX)
;;; (scheme-implementation-type) should return the name of the scheme
;;; implementation loading this file.
-
(define (scheme-implementation-type) 'Elk)
;;; (scheme-implementation-home-page) should return a (string) URI
;;; (Uniform Resource Identifier) for this scheme implementation's home
;;; page; or false if there isn't one.
-
(define (scheme-implementation-home-page)
"http://www.informatik.uni-bremen.de/~net/elk/")
;;; (scheme-implementation-version) should return a string describing
;;; the version the scheme implementation loading this file.
-
(define (scheme-implementation-version) "3.0")
;;; (implementation-vicinity) should be defined to be the pathname of
;;; the directory where any auxillary files to your Scheme
;;; implementation reside.
-
(define (implementation-vicinity)
(case (software-type)
- ((UNIX) "/usr/local/lib/elk-2.1/scm/")
+ ((UNIX) "/usr/local/lib/elk/runtime/scm/")
((VMS) "scheme$src:")
((MS-DOS) "C:\\scheme\\")))
;;; (library-vicinity) should be defined to be the pathname of the
;;; directory where files of Scheme library functions reside.
-
(require 'unix)
(define getenv unix-getenv)
(define system unix-system)
@@ -67,14 +61,18 @@
;;; (home-vicinity) should return the vicinity of the user's HOME
;;; directory, the directory which typically contains files which
;;; customize a computer environment for a user.
-
-(define home-vicinity
- (let ((home-path (getenv "HOME")))
- (lambda () home-path)))
+(define (home-vicinity)
+ (let ((home (getenv "HOME")))
+ (and home
+ (case (software-type)
+ ((UNIX COHERENT MS-DOS) ;V7 unix has a / on HOME
+ (if (eqv? #\/ (string-ref home (+ -1 (string-length home))))
+ home
+ (string-append home "/")))
+ (else home)))))
;;; *features* should be set to a list of symbols describing features
;;; of this implementation. Suggestions for features are:
-
(define *features*
'(
source ;can load scheme source files
@@ -84,7 +82,7 @@
;; Scheme report features
-; rev5-report ;conforms to
+; r5rs ;conforms to
; eval ;R5RS two-argument eval
; values ;R5RS multiple values
; dynamic-wind ;R5RS dynamic-wind
@@ -98,11 +96,11 @@
;STRING-FILL!, LIST->VECTOR,
;VECTOR->LIST, and VECTOR-FILL!
- rev4-report ;conforms to
+ r4rs ;conforms to
ieee-p1178 ;conforms to
-; rev3-report ;conforms to
+; r3rs ;conforms to
rev2-procedures ;SUBSTRING-MOVE-LEFT!,
;SUBSTRING-MOVE-RIGHT!,
@@ -113,7 +111,7 @@
multiarg/and- ;/ and - can take more than 2 args.
; with-file ;has WITH-INPUT-FROM-FILE and
- ;WITH-OUTPUT-FROM-FILE
+ ;WITH-OUTPUT-TO-FILE
transcript ;TRANSCRIPT-ON and TRANSCRIPT-OFF
; ieee-floating-point ;conforms to IEEE Standard 754-1985
;IEEE Standard for Binary
@@ -152,7 +150,6 @@
; EXACT? appears to always return #f which isn't very useful.
; Approximating it with INTEGER? at least means that some
; of the code in the library will work correctly
-
(define exact? integer?) ; WARNING: redefining EXACT?
(define (inexact? arg)
@@ -202,6 +199,37 @@
(close-input-port insp)
res))
+(define (make-exchanger obj)
+ (lambda (rep) (let ((old obj)) (set! obj rep) old)))
+(define (open-file filename modes)
+ (case modes
+ ((r rb) (open-input-file filename))
+ ((w wb) (open-output-file filename))
+ (else (slib:error 'open-file 'mode? modes))))
+(define (port? obj) (or (input-port? port) (output-port? port)))
+(define (call-with-open-ports . ports)
+ (define proc (car ports))
+ (cond ((procedure? proc) (set! ports (cdr ports)))
+ (else (set! ports (reverse ports))
+ (set! proc (car ports))
+ (set! ports (reverse (cdr ports)))))
+ (let ((ans (apply proc ports)))
+ (for-each close-port ports)
+ ans))
+(define (close-port port)
+ (cond ((input-port? port)
+ (close-input-port port)
+ (if (output-port? port) (close-output-port port)))
+ ((output-port? port) (close-output-port port))
+ (else (slib:error 'close-port 'port? port))))
+
+(define (browse-url url)
+ (define (try cmd end) (zero? (system (string-append cmd url end))))
+ (or (try "netscape-remote -remote 'openURL(" ")'")
+ (try "netscape -remote 'openURL(" ")'")
+ (try "netscape '" "'&")
+ (try "netscape '" "'")))
+
;;; CHAR-CODE-LIMIT is one greater than the largest integer which can
;;; be returned by CHAR->INTEGER.
(define char-code-limit 256)
@@ -268,7 +296,7 @@
(let ((cep (current-error-port)))
(if (provided? 'trace) (print-call-stack cep))
(display "Warn: " cep)
- (for-each (lambda (x) (display x cep)) args))))
+ (for-each (lambda (x) (display #\ cep) (write x cep)) args))))
;;; define an error procedure for the library
(define slib:error
@@ -323,7 +351,6 @@
; _(global-environment)_ if none is explicitly specified.
; If this is not done, definitions in files loaded by other files will
; not be loaded in the correct environment.
-
(define slib:load-source
(let ((primitive-load load))
(lambda (<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"))
diff --git a/eval.scm b/eval.scm
index a5e7e19..ae716f6 100644
--- a/eval.scm
+++ b/eval.scm
@@ -8,7 +8,7 @@
;1. Any copy made of this software must include this copyright notice
;in full.
;
-;2. I have made no warrantee or representation that the operation of
+;2. I have made no warranty or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
@@ -45,15 +45,15 @@
(apply (lambda (environment-values identifiers procedure)
(eval-1 `((lambda args args) ,@identifiers)))
environment)))))
-
+;@
(define interaction-environment
(let ((env (eval:make-environment '())))
(lambda () env)))
-;;; null-environment is set by first call to scheme-report-environment at
+;;;@ null-environment is set by first call to scheme-report-environment at
;;; the end of this file.
(define null-environment #f)
-
+;@
(define scheme-report-environment
(let* ((r4rs-procedures
(append
@@ -111,7 +111,7 @@
null-environment scheme-report-environment values)
r4rs-procedures))
(r4rs-environment (eval:make-environment r4rs-procedures))
- (r5rs-environment (eval:make-environment r4rs-procedures)))
+ (r5rs-environment (eval:make-environment r5rs-procedures)))
(let ((car car))
(lambda (version)
(cond ((car r5rs-environment))
@@ -125,7 +125,7 @@
((4) r4rs-environment)
((5) r5rs-environment)
(else (slib:error 'eval 'version version 'not 'available)))))))
-
+;@
(define eval
(let ((eval-1 slib:eval)
(apply apply)
diff --git a/factor.scm b/factor.scm
index 3b9fb5e..c445004 100644
--- a/factor.scm
+++ b/factor.scm
@@ -8,7 +8,7 @@
;1. Any copy made of this software must include this copyright notice
;in full.
;
-;2. I have made no warrantee or representation that the operation of
+;2. I have made no warranty or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
@@ -17,7 +17,6 @@
;promotional, or sales literature without prior written consent in
;each case.
-(require 'common-list-functions)
(require 'modular)
(require 'random)
(require 'byte)
@@ -82,8 +81,10 @@
(if (positive? i) #f #t))))
;;; prime:products are products of small primes.
+;;; was (comlist:notevery (lambda (prd) (= 1 (gcd n prd))) comps))
(define (primes-gcd? n comps)
- (comlist:notevery (lambda (prd) (= 1 (gcd n prd))) comps))
+ (not (let mapf ((lst comps))
+ (or (null? lst) (and (= 1 (gcd n (car lst))) (mapf (cdr lst)))))))
(define prime:prime-sqr 121)
(define prime:products '(105))
(define prime:sieve (bytes 0 0 1 1 0 1 0 1 0 0 0))
@@ -122,40 +123,37 @@
;;There is a slight chance @code{(expt 2 (- prime:trials))} that a
;;composite will return @code{#t}.
(define prime? prime:prime?)
-(define probably-prime? prime:prime?) ;legacy
(define (prime:prime< start)
(do ((nbr (+ -1 start) (+ -1 nbr)))
((or (negative? nbr) (prime:prime? nbr))
(if (negative? nbr) #f nbr))))
-(define (prime:primes< start count)
+;;@body
+;;Returns a list of the first @2 prime numbers less than
+;;@1. If there are fewer than @var{count} prime numbers
+;;less than @var{start}, then the returned list will have fewer than
+;;@var{start} elements.
+(define (primes< start count)
(do ((cnt (+ -2 count) (+ -1 cnt))
(lst '() (cons prime lst))
(prime (prime:prime< start) (prime:prime< prime)))
((or (not prime) (negative? cnt))
(if prime (cons prime lst) lst))))
-;;@args start count
-;;Returns a list of the first @2 prime numbers less than
-;;@1. If there are fewer than @var{count} prime numbers
-;;less than @var{start}, then the returned list will have fewer than
-;;@var{start} elements.
-(define primes< prime:primes<)
(define (prime:prime> start)
(do ((nbr (+ 1 start) (+ 1 nbr)))
((prime:prime? nbr) nbr)))
-(define (prime:primes> start count)
+;;@body
+;;Returns a list of the first @2 prime numbers greater than @1.
+(define (primes> start count)
(set! start (max 0 start))
(do ((cnt (+ -2 count) (+ -1 cnt))
(lst '() (cons prime lst))
(prime (prime:prime> start) (prime:prime> prime)))
((negative? cnt)
(reverse (cons prime lst)))))
-;;@args start count
-;;Returns a list of the first @2 prime numbers greater than @1.
-(define primes> prime:primes>)
;;;;Lankinen's recursive factoring algorithm:
;From: ld231782@longs.LANCE.ColoState.EDU (L. Detweiler)
@@ -232,14 +230,13 @@
'()
(prime:fo m))))
-(define (prime:factor k)
+;;@body
+;;Returns a list of the prime factors of @1. The order of the
+;;factors is unspecified. In order to obtain a sorted list do
+;;@code{(sort! (factor @var{k}) <)}.
+(define (factor k)
(case k
((-1 0 1) (list k))
(else (if (negative? k)
(cons -1 (prime:fe (- k)))
(prime:fe k)))))
-;;@args k
-;;Returns a list of the prime factors of @1. The order of the
-;;factors is unspecified. In order to obtain a sorted list do
-;;@code{(sort! (factor @var{k}) <)}.
-(define factor prime:factor)
diff --git a/fft.scm b/fft.scm
index 9537e9c..2257e30 100644
--- a/fft.scm
+++ b/fft.scm
@@ -1,5 +1,5 @@
;;;"fft.scm" Fast Fourier Transform
-;Copyright (C) 1999 Aubrey Jaffer
+;Copyright (C) 1999, 2003 Aubrey Jaffer
;
;Permission to copy this software, to modify it, to redistribute it,
;to distribute modified versions, and to use it for any purpose is
@@ -8,7 +8,7 @@
;1. Any copy made of this software must include this copyright notice
;in full.
;
-;2. I have made no warrantee or representation that the operation of
+;2. I have made no warranty or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
@@ -28,14 +28,13 @@
;;; differs in the direction of rotation of the complex unit vectors.
(require 'array)
+(require 'logical)
-(define (fft:shuffled&scaled ara n scale)
+;;@code{(require 'fft)}
+;;@ftindex fft
+
+(define (fft:shuffle&scale new ara n scale)
(define lgn (integer-length (+ -1 n)))
- (define new (apply make-array 0 (array-dimensions ara)))
- (define bit-reverse (lambda (width in)
- (if (zero? width) 0
- (+ (bit-reverse (+ -1 width) (quotient in 2))
- (ash (modulo in 2) (+ -1 width))))))
(if (not (eqv? n (expt 2 lgn)))
(slib:error 'fft "array length not power of 2" n))
(do ((k 0 (+ 1 k)))
@@ -61,10 +60,35 @@
(array-set! ara (+ u t) k)
(array-set! ara (- u t) k+m/2)))))))
+;;@args array
+;;@var{array} is an array of @code{(expt 2 n)} numbers. @code{fft}
+;;returns an array of complex numbers comprising the
+;;@dfn{Discrete Fourier Transform} of @var{array}.
(define (fft ara)
(define n (car (array-dimensions ara)))
- (dft! (fft:shuffled&scaled ara n 1) n 1))
+ (define new (apply create-array ara (array-dimensions ara)))
+ (dft! (fft:shuffle&scale new ara n 1) n 1))
+;;@args array
+;;@code{fft-1} returns an array of complex numbers comprising the
+;;inverse Discrete Fourier Transform of @var{array}.
(define (fft-1 ara)
(define n (car (array-dimensions ara)))
- (dft! (fft:shuffled&scaled ara n (/ n)) n -1))
+ (define new (apply create-array ara (array-dimensions ara)))
+ (dft! (fft:shuffle&scale new ara n (/ n)) n -1))
+
+;;@noindent
+;;@code{(fft-1 (fft @var{array}))} will return an array of values close to
+;;@var{array}.
+;;
+;;@example
+;;(fft '#(1 0+i -1 0-i 1 0+i -1 0-i)) @result{}
+;;
+;;#(0.0 0.0 0.0+628.0783185208527e-18i 0.0
+;; 0.0 0.0 8.0-628.0783185208527e-18i 0.0)
+;;
+;;(fft-1 '#(0 0 0 0 0 0 8 0)) @result{}
+;;
+;;#(1.0 -61.23031769111886e-18+1.0i -1.0 61.23031769111886e-18-1.0i
+;; 1.0 -61.23031769111886e-18+1.0i -1.0 61.23031769111886e-18-1.0i)
+;;@end example
diff --git a/fft.txi b/fft.txi
new file mode 100644
index 0000000..c73f103
--- /dev/null
+++ b/fft.txi
@@ -0,0 +1,32 @@
+@code{(require 'fft)}
+@ftindex fft
+
+
+@defun fft array
+
+@var{array} is an array of @code{(expt 2 n)} numbers. @code{fft}
+returns an array of complex numbers comprising the
+@dfn{Discrete Fourier Transform} of @var{array}.
+@cindex Discrete Fourier Transform
+@end defun
+
+@defun fft-1 array
+
+@code{fft-1} returns an array of complex numbers comprising the
+inverse Discrete Fourier Transform of @var{array}.
+@end defun
+@noindent
+@code{(fft-1 (fft @var{array}))} will return an array of values close to
+@var{array}.
+
+@example
+(fft '#(1 0+i -1 0-i 1 0+i -1 0-i)) @result{}
+
+#(0.0 0.0 0.0+628.0783185208527e-18i 0.0
+ 0.0 0.0 8.0-628.0783185208527e-18i 0.0)
+
+(fft-1 '#(0 0 0 0 0 0 8 0)) @result{}
+
+#(1.0 -61.23031769111886e-18+1.0i -1.0 61.23031769111886e-18-1.0i
+ 1.0 -61.23031769111886e-18+1.0i -1.0 61.23031769111886e-18-1.0i)
+@end example
diff --git a/fluidlet.scm b/fluidlet.scm
index 983bfdb..06d4630 100644
--- a/fluidlet.scm
+++ b/fluidlet.scm
@@ -1,5 +1,5 @@
; "fluidlet.scm", FLUID-LET for Scheme
-; Copyright (c) 1998, Aubrey Jaffer
+; Copyright (c) 1998 Aubrey Jaffer
;
;Permission to copy this software, to modify it, to redistribute it,
;to distribute modified versions, and to use it for any purpose is
@@ -8,7 +8,7 @@
;1. Any copy made of this software must include this copyright notice
;in full.
;
-;2. I have made no warrantee or representation that the operation of
+;2. I have made no warranty or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
@@ -18,14 +18,13 @@
;each case.
(require 'dynamic-wind)
-(require 'common-list-functions) ;MAKE-LIST
-
+;@
(defmacro fluid-let (clauses . body)
(let ((ids (map car clauses))
(new-tmps (map (lambda (x) (gentemp)) clauses))
(old-tmps (map (lambda (x) (gentemp)) clauses)))
`(let (,@(map list new-tmps (map cadr clauses))
- ,@(map list old-tmps (make-list (length clauses) #f)))
+ ,@(map list old-tmps (map (lambda (x) #f) clauses)))
(dynamic-wind
(lambda ()
,@(map (lambda (ot id) `(set! ,ot ,id))
diff --git a/fmtdoc.txi b/fmtdoc.txi
deleted file mode 100644
index 3e2adb7..0000000
--- a/fmtdoc.txi
+++ /dev/null
@@ -1,434 +0,0 @@
-
-@menu
-* Format Interface::
-* Format Specification::
-@end menu
-
-@node Format Interface, Format Specification, Format, Format
-@subsection Format Interface
-
-@defun format destination format-string . arguments
-An almost complete implementation of Common LISP format description
-according to the CL reference book @cite{Common LISP} from Guy L.
-Steele, Digital Press. Backward compatible to most of the available
-Scheme format implementations.
-
-Returns @code{#t}, @code{#f} or a string; has side effect of printing
-according to @var{format-string}. If @var{destination} is @code{#t},
-the output is to the current output port and @code{#t} is returned. If
-@var{destination} is @code{#f}, a formatted string is returned as the
-result of the call. NEW: If @var{destination} is a string,
-@var{destination} is regarded as the format string; @var{format-string} is
-then the first argument and the output is returned as a string. If
-@var{destination} is a number, the output is to the current error port
-if available by the implementation. Otherwise @var{destination} must be
-an output port and @code{#t} is returned.@refill
-
-@var{format-string} must be a string. In case of a formatting error
-format returns @code{#f} and prints a message on the current output or
-error port. Characters are output as if the string were output by the
-@code{display} function with the exception of those prefixed by a tilde
-(~). For a detailed description of the @var{format-string} syntax
-please consult a Common LISP format reference manual. For a test suite
-to verify this format implementation load @file{formatst.scm}. Please
-send bug reports to @code{lutzeb@@cs.tu-berlin.de}.
-
-Note: @code{format} is not reentrant, i.e. only one @code{format}-call
-may be executed at a time.
-
-@end defun
-
-@node Format Specification, , Format Interface, Format
-@subsection Format Specification (Format version 3.0)
-
-Please consult a Common LISP format reference manual for a detailed
-description of the format string syntax. For a demonstration of the
-implemented directives see @file{formatst.scm}.@refill
-
-This implementation supports directive parameters and modifiers
-(@code{:} and @code{@@} characters). Multiple parameters must be
-separated by a comma (@code{,}). Parameters can be numerical parameters
-(positive or negative), character parameters (prefixed by a quote
-character (@code{'}), variable parameters (@code{v}), number of rest
-arguments parameter (@code{#}), empty and default parameters. Directive
-characters are case independent. The general form of a directive
-is:@refill
-
-@noindent
-@var{directive} ::= ~@{@var{directive-parameter},@}[:][@@]@var{directive-character}
-
-@noindent
-@var{directive-parameter} ::= [ [-|+]@{0-9@}+ | '@var{character} | v | # ]
-
-
-@subsubsection Implemented CL Format Control Directives
-
-Documentation syntax: Uppercase characters represent the corresponding
-control directive characters. Lowercase characters represent control
-directive parameter descriptions.
-
-@table @asis
-@item @code{~A}
-Any (print as @code{display} does).
-@table @asis
-@item @code{~@@A}
-left pad.
-@item @code{~@var{mincol},@var{colinc},@var{minpad},@var{padchar}A}
-full padding.
-@end table
-@item @code{~S}
-S-expression (print as @code{write} does).
-@table @asis
-@item @code{~@@S}
-left pad.
-@item @code{~@var{mincol},@var{colinc},@var{minpad},@var{padchar}S}
-full padding.
-@end table
-@item @code{~D}
-Decimal.
-@table @asis
-@item @code{~@@D}
-print number sign always.
-@item @code{~:D}
-print comma separated.
-@item @code{~@var{mincol},@var{padchar},@var{commachar}D}
-padding.
-@end table
-@item @code{~X}
-Hexadecimal.
-@table @asis
-@item @code{~@@X}
-print number sign always.
-@item @code{~:X}
-print comma separated.
-@item @code{~@var{mincol},@var{padchar},@var{commachar}X}
-padding.
-@end table
-@item @code{~O}
-Octal.
-@table @asis
-@item @code{~@@O}
-print number sign always.
-@item @code{~:O}
-print comma separated.
-@item @code{~@var{mincol},@var{padchar},@var{commachar}O}
-padding.
-@end table
-@item @code{~B}
-Binary.
-@table @asis
-@item @code{~@@B}
-print number sign always.
-@item @code{~:B}
-print comma separated.
-@item @code{~@var{mincol},@var{padchar},@var{commachar}B}
-padding.
-@end table
-@item @code{~@var{n}R}
-Radix @var{n}.
-@table @asis
-@item @code{~@var{n},@var{mincol},@var{padchar},@var{commachar}R}
-padding.
-@end table
-@item @code{~@@R}
-print a number as a Roman numeral.
-@item @code{~:@@R}
-print a number as an ``old fashioned'' Roman numeral.
-@item @code{~:R}
-print a number as an ordinal English number.
-@item @code{~R}
-print a number as a cardinal English number.
-@item @code{~P}
-Plural.
-@table @asis
-@item @code{~@@P}
-prints @code{y} and @code{ies}.
-@item @code{~:P}
-as @code{~P but jumps 1 argument backward.}
-@item @code{~:@@P}
-as @code{~@@P but jumps 1 argument backward.}
-@end table
-@item @code{~C}
-Character.
-@table @asis
-@item @code{~@@C}
-prints a character as the reader can understand it (i.e. @code{#\} prefixing).
-@item @code{~:C}
-prints a character as emacs does (eg. @code{^C} for ASCII 03).
-@end table
-@item @code{~F}
-Fixed-format floating-point (prints a flonum like @var{mmm.nnn}).
-@table @asis
-@item @code{~@var{width},@var{digits},@var{scale},@var{overflowchar},@var{padchar}F}
-@item @code{~@@F}
-If the number is positive a plus sign is printed.
-@end table
-@item @code{~E}
-Exponential floating-point (prints a flonum like @var{mmm.nnn}@code{E}@var{ee}).
-@table @asis
-@item @code{~@var{width},@var{digits},@var{exponentdigits},@var{scale},@var{overflowchar},@var{padchar},@var{exponentchar}E}
-@item @code{~@@E}
-If the number is positive a plus sign is printed.
-@end table
-@item @code{~G}
-General floating-point (prints a flonum either fixed or exponential).
-@table @asis
-@item @code{~@var{width},@var{digits},@var{exponentdigits},@var{scale},@var{overflowchar},@var{padchar},@var{exponentchar}G}
-@item @code{~@@G}
-If the number is positive a plus sign is printed.
-@end table
-@item @code{~$}
-Dollars floating-point (prints a flonum in fixed with signs separated).
-@table @asis
-@item @code{~@var{digits},@var{scale},@var{width},@var{padchar}$}
-@item @code{~@@$}
-If the number is positive a plus sign is printed.
-@item @code{~:@@$}
-A sign is always printed and appears before the padding.
-@item @code{~:$}
-The sign appears before the padding.
-@end table
-@item @code{~%}
-Newline.
-@table @asis
-@item @code{~@var{n}%}
-print @var{n} newlines.
-@end table
-@item @code{~&}
-print newline if not at the beginning of the output line.
-@table @asis
-@item @code{~@var{n}&}
-prints @code{~&} and then @var{n-1} newlines.
-@end table
-@item @code{~|}
-Page Separator.
-@table @asis
-@item @code{~@var{n}|}
-print @var{n} page separators.
-@end table
-@item @code{~~}
-Tilde.
-@table @asis
-@item @code{~@var{n}~}
-print @var{n} tildes.
-@end table
-@item @code{~}<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
index 709acf7..c9e1d12 100644
--- a/format.scm
+++ b/format.scm
@@ -31,6 +31,13 @@
(define format:expch #\E)
;; The character prefixing the exponent value in ~e printing.
+(define format:iteration-bounded #t)
+;; If #t, "~{...~}" iterates no more than format:max-iterations times;
+;; if #f, there is no bound.
+
+(define format:max-iterations 100)
+;; Compatible with previous versions.
+
(define format:floats (provided? 'inexact))
;; Detects if the scheme system implements flonums (see at eof).
@@ -605,7 +612,8 @@
((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))))
+ (else (if (not max-iterations)
+ (set! max-iterations format:max-iterations))))
(if (not (null? params))
(format:error "no parameters allowed in ~~}"))
(if (zero? iteration-nest)
@@ -627,7 +635,8 @@
(list-tail args arg-pos))))
(i 0 (+ i 1)))
((or (>= arg-pos args-len)
- (>= i max-iterations))))))
+ (and format:iteration-bounded
+ (>= i max-iterations)))))))
((sublists)
(let ((args (next-arg))
(args-len 0))
@@ -636,7 +645,8 @@
(set! args-len (length args))
(do ((arg-pos 0 (+ arg-pos 1)))
((or (>= arg-pos args-len)
- (>= arg-pos max-iterations)))
+ (and format:iteration-bounded
+ (>= arg-pos max-iterations))))
(let ((sublist (list-ref args arg-pos)))
(if (not (list? sublist))
(format:error
@@ -653,7 +663,8 @@
args arg-pos))))
(i 0 (+ i 1)))
((or (>= arg-pos args-len)
- (>= i max-iterations))
+ (and format:iteration-bounded
+ (>= i max-iterations)))
arg-pos))))
(add-arg-pos usedup-args)))
((rest-sublists)
@@ -662,7 +673,8 @@
(usedup-args
(do ((arg-pos 0 (+ arg-pos 1)))
((or (>= arg-pos args-len)
- (>= arg-pos max-iterations))
+ (and format:iteration-bounded
+ (>= arg-pos max-iterations)))
arg-pos)
(let ((sublist (list-ref args arg-pos)))
(if (not (list? sublist))
diff --git a/formatst.scm b/formatst.scm
index 3f19130..77a46c4 100644
--- a/formatst.scm
+++ b/formatst.scm
@@ -66,6 +66,8 @@
(set! format:symbol-case-conv #f)
(set! format:iobj-case-conv #f)
(set! format:read-proof #f)
+(set! format:iteration-bounded #t)
+(set! format:max-iterations 100)
(format #t "~q")
@@ -426,6 +428,23 @@ def")
(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")
+(let ((nums (let iter ((ns '()) (l 0))
+ (if (> l 105) (reverse ns) (iter (cons l ns) (+ l 1))))))
+ ;; Test default, only 100 items formatted out:
+ (test `("~D~{, ~D~}" ,(car nums) ,(cdr nums))
+ "0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90, 91, 92, 93, 94, 95, 96, 97, 98, 99, 100")
+ ;; Test control of number of items formatted out:
+ (set! format:max-iterations 90)
+ (test `("~D~{, ~D~}" ,(car nums) ,(cdr nums))
+ "0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90")
+ ;; Test control of imposing bound on number of items formatted out:
+ (set! format:iteration-bounded #f)
+ (test `("~D~{, ~D~}" ,(car nums) ,(cdr nums))
+ "0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90, 91, 92, 93, 94, 95, 96, 97, 98, 99, 100, 101, 102, 103, 104, 105")
+ ;; Restore defaults:
+ (set! format:iteration-bounded #t)
+ (set! format:max-iterations 100)
+ )
; up and out
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)
diff --git a/getopt.scm b/getopt.scm
index bb0b8a8..7b73b58 100644
--- a/getopt.scm
+++ b/getopt.scm
@@ -1,5 +1,5 @@
;;; "getopt.scm" POSIX command argument processing
-;Copyright (C) 1993, 1994 Aubrey Jaffer
+;Copyright (C) 1993, 1994, 2002 Aubrey Jaffer
;
;Permission to copy this software, to modify it, to redistribute it,
;to distribute modified versions, and to use it for any purpose is
@@ -8,7 +8,7 @@
;1. Any copy made of this software must include this copyright notice
;in full.
;
-;2. I have made no warrantee or representation that the operation of
+;2. I have made no warranty or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
@@ -19,19 +19,21 @@
(define getopt:scan #f)
(define getopt:char #\-)
+;@
(define getopt:opt #f)
+(define *argv* *argv*)
(define *optind* 1)
(define *optarg* 0)
-
-(define (getopt argc argv optstring)
+;@
+(define (getopt optstring)
(let ((opts (string->list optstring))
(place #f)
(arg #f)
- (argref (lambda () ((if (vector? argv) vector-ref list-ref)
- argv *optind*))))
+ (argref (lambda () ((if (vector? *argv*) vector-ref list-ref)
+ *argv* *optind*))))
(and
(cond ((and getopt:scan (not (string=? "" getopt:scan))) #t)
- ((>= *optind* argc) #f)
+ ((>= *optind* (length *argv*)) #f)
(else
(set! arg (argref))
(cond ((or (<= (string-length arg) 1)
@@ -42,8 +44,7 @@
(set! *optind* (+ *optind* 1))
#f)
(else
- (set! getopt:scan
- (substring arg 1 (string-length arg)))
+ (set! getopt:scan (substring arg 1 (string-length arg)))
#t))))
(begin
(set! getopt:opt (string-ref getopt:scan 0))
@@ -59,22 +60,21 @@
(set! *optind* (+ *optind* 1))
(set! getopt:scan #f)
getopt:opt)
- ((< *optind* argc)
+ ((< *optind* (length *argv*))
(set! *optarg* (argref))
(set! *optind* (+ *optind* 1))
getopt:opt)
((and (not (null? opts)) (char=? #\: (car opts))) #\:)
(else #\?))))))
-
-(define (getopt-- argc argv optstring)
- (let* ((opt (getopt argc argv (string-append optstring "-:")))
+;@
+(define (getopt-- optstring)
+ (let* ((opt (getopt (string-append optstring "-:")))
(optarg *optarg*))
(cond ((eqv? #\- opt) ;long option
(do ((l (string-length *optarg*))
(i 0 (+ 1 i)))
((or (>= i l) (char=? #\= (string-ref optarg i)))
- (cond
- ((>= i l) (set! *optarg* #f) optarg)
- (else (set! *optarg* (substring optarg (+ 1 i) l))
- (substring optarg 0 i))))))
+ (cond ((>= i l) (set! *optarg* #f) optarg)
+ (else (set! *optarg* (substring optarg (+ 1 i) l))
+ (substring optarg 0 i))))))
(else opt))))
diff --git a/getparam.scm b/getparam.scm
index 3e2d7f1..1e7b7c0 100644
--- a/getparam.scm
+++ b/getparam.scm
@@ -8,7 +8,7 @@
;1. Any copy made of this software must include this copyright notice
;in full.
;
-;2. I have made no warrantee or representation that the operation of
+;2. I have made no warranty or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
@@ -19,12 +19,41 @@
(require 'getopt)
(require 'coerce)
+(require 'parameters)
+(require-if 'compiling 'printf)
+(require-if 'compiling 'common-list-functions)
-(define (getopt->parameter-list argc argv optnames arities types aliases
- . description)
+;;@code{(require 'getopt-parameters)}
+;;@ftindex getopt-parameters
+
+;;@args optnames arities types aliases desc @dots{}
+;;Returns @var{*argv*} converted to a parameter-list. @var{optnames} are
+;;the parameter-names. @var{arities} and @var{types} are lists of symbols
+;;corresponding to @var{optnames}.
+;;
+;;@var{aliases} is a list of lists of strings or integers paired with
+;;elements of @var{optnames}. Each one-character string will be treated
+;;as a single @samp{-} option by @code{getopt}. Longer strings will be
+;;treated as long-named options (@pxref{Getopt, getopt--}).
+;;
+;;If the @var{aliases} association list has only strings as its
+;;@code{car}s, then all the option-arguments after an option (and before
+;;the next option) are adjoined to that option.
+;;
+;;If the @var{aliases} association list has integers, then each (string)
+;;option will take at most one option-argument. Unoptioned arguments are
+;;collected in a list. A @samp{-1} alias will take the last argument in
+;;this list; @samp{+1} will take the first argument in the list. The
+;;aliases -2 then +2; -3 then +3; @dots{} are tried so long as a positive
+;;or negative consecutive alias is found and arguments remain in the list.
+;;Finally a @samp{0} alias, if found, absorbs any remaining arguments.
+;;
+;;In all cases, if unclaimed arguments remain after processing, a warning
+;;is signaled and #f is returned.
+(define (getopt->parameter-list optnames arities types aliases . description)
(define (can-take-arg? opt)
(not (eq? 'boolean (list-ref arities (position opt optnames)))))
- (let ((progname (list-ref argv (+ -1 *optind*)))
+ (let ((progname (list-ref *argv* (+ -1 *optind*)))
(optlist '())
(long-opt-list '())
(optstring #f)
@@ -63,7 +92,8 @@
(for-each (lambda (unc) (adjoin-val unc curopt)) unclaimeds)
(set! unclaimeds '()))))))
(cond ((not (null? unclaimeds))
- (slib:warn 'getopt->parameter-list 'arguments 'unclaimed unclaimeds)
+ (getopt-barf "%s: Unclaimed argument '%s'"
+ progname (car unclaimeds))
(apply parameter-list->getopt-usage
progname optnames arities types aliases description))
(else parameter-list)))
@@ -94,34 +124,34 @@
aliases)
(set! optstring (list->string (cons #\: optlist)))
(let loop ()
- (let ((opt (getopt-- argc argv optstring)))
+ (let ((opt (getopt-- optstring)))
(case opt
((#\: #\?)
- (slib:warn 'getopt->parameter-list
- (case opt
- ((#\:) "argument missing after")
- ((#\?) "unrecognized option"))
- (string #\- getopt:opt))
+ (getopt-barf (case opt
+ ((#\:) "%s: argument missing after '-%c'")
+ ((#\?) "%s: unrecognized option '-%c'"))
+ progname
+ getopt:opt)
(apply parameter-list->getopt-usage
progname optnames arities types aliases description))
((#f)
- (cond ((and (< *optind* argc)
- (string=? "-" (list-ref argv *optind*)))
+ (cond ((and (< *optind* (length *argv*))
+ (string=? "-" (list-ref *argv* *optind*)))
(set! *optind* (+ 1 *optind*))
(finish))
- ((< *optind* argc)
+ ((< *optind* (length *argv*))
(let ((topt (assoc curopt aliases)))
(if topt (set! curopt (cadr topt)))
(cond
((and positional? (not topt))
(set! unclaimeds
- (cons (list-ref argv *optind*) unclaimeds))
+ (cons (list-ref *argv* *optind*) unclaimeds))
(set! *optind* (+ 1 *optind*)) (loop))
((and (member curopt optnames)
- (adjoin-val (list-ref argv *optind*) curopt))
+ (adjoin-val (list-ref *argv* *optind*) curopt))
(set! *optind* (+ 1 *optind*)) (loop))
(else (slib:error 'getopt->parameter-list curopt
- (list-ref argv *optind*)
+ (list-ref *argv* *optind*)
'not 'supported)))))
(else (finish))))
(else
@@ -130,7 +160,7 @@
(if topt (set! topt (cadr topt)))
(cond
((not topt)
- (slib:warn "Option not recognized -" opt)
+ (getopt-barf "%s: '--%s' option not recognized" progname opt)
(apply parameter-list->getopt-usage
progname optnames arities types aliases description))
((not (can-take-arg? topt))
@@ -138,9 +168,15 @@
(loop))
(*optarg* (set! curopt topt) (adjoin-val *optarg* curopt) (loop))
(else
-;;; (slib:warn 'getopt->parameter-list "= missing for option--" opt)
+ ;;(getopt-barf "%s: '--%s' option expects '='" progname opt)
+ ;;(apply parameter-list->getopt-usage progname optnames arities types aliases description)
(set! curopt topt) (loop))))))))))
+(define (getopt-barf . args)
+ (require 'printf)
+ (apply fprintf (current-error-port) args)
+ (newline (current-error-port)))
+
(define (parameter-list->getopt-usage comname optnames arities types aliases
. description)
(require 'printf)
@@ -198,11 +234,17 @@
(for-each (lambda (desc) (fprintf cep " %s\\n" desc)) description))
#f)
-(define (getopt->arglist argc argv optnames positions
+;;@args optnames positions arities types defaulters checks aliases desc @dots{}
+;;Like @code{getopt->parameter-list}, but converts @var{*argv*} to an
+;;argument-list as specified by @var{optnames}, @var{positions},
+;;@var{arities}, @var{types}, @var{defaulters}, @var{checks}, and
+;;@var{aliases}. If the options supplied violate the @var{arities} or
+;;@var{checks} constraints, then a warning is signaled and #f is returned.
+(define (getopt->arglist optnames positions
arities types defaulters checks aliases . description)
- (define progname (list-ref argv (+ -1 *optind*)))
+ (define progname (list-ref *argv* (+ -1 *optind*)))
(let* ((params (apply getopt->parameter-list
- argc argv optnames arities types aliases description))
+ optnames arities types aliases description))
(fparams (and params (fill-empty-parameters defaulters params))))
(cond ((and (list? params)
(check-parameters checks fparams)
@@ -211,3 +253,49 @@
progname optnames arities types aliases description))
(else #f))))
+;;@noindent
+;;These @code{getopt} functions can be used with SLIB relational
+;;databases. For an example, @xref{Using Databases, make-command-server}.
+;;
+;;@noindent
+;;If errors are encountered while processing options, directions for using
+;;the options (and argument strings @var{desc} @dots{}) are printed to
+;;@code{current-error-port}.
+;;
+;;@example
+;;(begin
+;; (set! *optind* 1)
+;; (set! *argv* '("cmd" "-?")
+;; (getopt->parameter-list
+;; '(flag number symbols symbols string flag2 flag3 num2 num3)
+;; '(boolean optional nary1 nary single boolean boolean nary nary)
+;; '(boolean integer symbol symbol string boolean boolean integer integer)
+;; '(("flag" flag)
+;; ("f" flag)
+;; ("Flag" flag2)
+;; ("B" flag3)
+;; ("optional" number)
+;; ("o" number)
+;; ("nary1" symbols)
+;; ("N" symbols)
+;; ("nary" symbols)
+;; ("n" symbols)
+;; ("single" string)
+;; ("s" string)
+;; ("a" num2)
+;; ("Abs" num3))))
+;;@print{}
+;;Usage: cmd [OPTION ARGUMENT ...] ...
+;;
+;; -f, --flag
+;; -o, --optional=<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
diff --git a/glob.scm b/glob.scm
index d6e993b..382bbf3 100644
--- a/glob.scm
+++ b/glob.scm
@@ -8,7 +8,7 @@
;1. Any copy made of this software must include this copyright notice
;in full.
;
-;2. I have made no warrantee or representation that the operation of
+;2. I have made no warranty or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
@@ -17,6 +17,10 @@
;promotional, or sales literature without prior written consent in
;each case.
+;;@code{(require 'filename)} or @code{(require 'glob)}
+;;@ftindex filename
+;;@ftindex glob
+
(define (glob:pattern->tokens pat)
(cond
((string? pat)
@@ -187,31 +191,87 @@
(else
(loop (cdr inds) (cdr wild?) lits res)))))))))
+;;@body
+;;Returns a predicate which returns a non-false value if its string argument
+;;matches (the string) @var{pattern}, false otherwise. Filename matching
+;;is like
+;;@cindex glob
+;;@dfn{glob} expansion described the bash manpage, except that names
+;;beginning with @samp{.} are matched and @samp{/} characters are not
+;;treated specially.
+;;
+;;These functions interpret the following characters specially in
+;;@var{pattern} strings:
+;;@table @samp
+;;@item *
+;;Matches any string, including the null string.
+;;@item ?
+;;Matches any single character.
+;;@item [@dots{}]
+;;Matches any one of the enclosed characters. A pair of characters
+;;separated by a minus sign (-) denotes a range; any character lexically
+;;between those two characters, inclusive, is matched. If the first
+;;character following the @samp{[} is a @samp{!} or a @samp{^} then any
+;;character not enclosed is matched. A @samp{-} or @samp{]} may be
+;;matched by including it as the first or last character in the set.
+;;@end table
+(define (filename:match?? pattern)
+ (glob:make-matcher pattern char=? char<=?))
+(define (filename:match-ci?? pattern)
+ (glob:make-matcher pattern char-ci=? char-ci<=?))
-(define (glob:match?? pat)
- (glob:make-matcher pat char=? char<=?))
-(define (glob:match-ci?? pat)
- (glob:make-matcher pat char-ci=? char-ci<=?))
-(define filename:match?? glob:match??)
-(define filename:match-ci?? glob:match-ci??)
-(define (glob:substitute?? pat templ)
- (cond ((procedure? templ)
- (glob:caller-with-matches pat templ char=? char<=?))
- ((string? templ)
- (glob:make-substituter pat templ char=? char<=?))
+;;@args pattern template
+;;Returns a function transforming a single string argument according to
+;;glob patterns @var{pattern} and @var{template}. @var{pattern} and
+;;@var{template} must have the same number of wildcard specifications,
+;;which need not be identical. @var{pattern} and @var{template} may have
+;;a different number of literal sections. If an argument to the function
+;;matches @var{pattern} in the sense of @code{filename:match??} then it
+;;returns a copy of @var{template} in which each wildcard specification is
+;;replaced by the part of the argument matched by the corresponding
+;;wildcard specification in @var{pattern}. A @code{*} wildcard matches
+;;the longest leftmost string possible. If the argument does not match
+;;@var{pattern} then false is returned.
+;;
+;;@var{template} may be a function accepting the same number of string
+;;arguments as there are wildcard specifications in @var{pattern}. In
+;;the case of a match the result of applying @var{template} to a list
+;;of the substrings matched by wildcard specifications will be returned,
+;;otherwise @var{template} will not be called and @code{#f} will be returned.
+(define (filename:substitute?? pattern template)
+ (cond ((procedure? template)
+ (glob:caller-with-matches pattern template char=? char<=?))
+ ((string? template)
+ (glob:make-substituter pattern template char=? char<=?))
(else
- (slib:error 'glob:substitute "bad second argument" templ))))
-(define (glob:substitute-ci?? pat templ)
- (cond ((procedure? templ)
- (glob:caller-with-matches pat templ char-ci=? char-ci<=?))
- ((string? templ)
- (glob:make-substituter pat templ char-ci=? char-ci<=?))
+ (slib:error 'filename:substitute?? "bad second argument" template))))
+(define (filename:substitute-ci?? pattern template)
+ (cond ((procedure? template)
+ (glob:caller-with-matches pattern template char-ci=? char-ci<=?))
+ ((string? template)
+ (glob:make-substituter pattern template char-ci=? char-ci<=?))
(else
- (slib:error 'glob:substitute "bad second argument" templ))))
-(define filename:substitute?? glob:substitute??)
-(define filename:substitute-ci?? glob:substitute-ci??)
+ (slib:error 'filename:substitute-ci?? "bad second argument" template))))
+
+;;@example
+;;((filename:substitute?? "scm_[0-9]*.html" "scm5c4_??.htm")
+;; "scm_10.html")
+;;@result{} "scm5c4_10.htm"
+;;((filename:substitute?? "??" "beg?mid?end") "AZ")
+;;@result{} "begAmidZend"
+;;((filename:substitute?? "*na*" "?NA?") "banana")
+;;@result{} "banaNA"
+;;((filename:substitute?? "?*?" (lambda (s1 s2 s3) (string-append s3 s1)))
+;; "ABZ")
+;;@result{} "ZA"
+;;@end example
+;;@body
+;;@var{str} can be a string or a list of strings. Returns a new string
+;;(or strings) similar to @code{str} but with the suffix string @var{old}
+;;removed and the suffix string @var{new} appended. If the end of
+;;@var{str} does not match @var{old}, an error is signaled.
(define (replace-suffix str old new)
(let* ((f (glob:make-substituter (list "*" old) (list "*" new)
char=? char<=?))
@@ -222,3 +282,37 @@
(if (pair? str)
(map g str)
(g str))))
+
+;;@example
+;;(replace-suffix "/usr/local/lib/slib/batch.scm" ".scm" ".c")
+;;@result{} "/usr/local/lib/slib/batch.c"
+;;@end example
+
+;;@args proc k
+;;@args proc
+;;Calls @1 with @2 arguments, strings returned by successive calls to
+;;@code{tmpnam}.
+;;If @1 returns, then any files named by the arguments to @1 are
+;;deleted automatically and the value(s) yielded by the @1 is(are)
+;;returned. @2 may be ommited, in which case it defaults to @code{1}.
+;;
+;;@args proc suffix1 ...
+;;Calls @1 with strings returned by successive calls to @code{tmpnam},
+;;each with the corresponding @var{suffix} string appended.
+;;If @1 returns, then any files named by the arguments to @1 are
+;;deleted automatically and the value(s) yielded by the @1 is(are)
+;;returned.
+(define (call-with-tmpnam proc . suffi)
+ (define (do-call paths)
+ (let ((ans (apply proc paths)))
+ (for-each (lambda (path) (if (file-exists? path) (delete-file path)))
+ paths)
+ ans))
+ (cond ((null? suffi) (do-call (list (tmpnam))))
+ ((and (= 1 (length suffi)) (number? (car suffi)))
+ (do ((cnt (if (null? suffi) 0 (+ -1 (car suffi))) (+ -1 cnt))
+ (paths '() (cons (tmpnam) paths)))
+ ((negative? cnt)
+ (do-call paths))))
+ (else (do-call (map (lambda (suffix) (string-append (tmpnam) suffix))
+ suffi)))))
diff --git a/glob.txi b/glob.txi
new file mode 100644
index 0000000..d83b66b
--- /dev/null
+++ b/glob.txi
@@ -0,0 +1,100 @@
+@code{(require 'filename)} or @code{(require 'glob)}
+@ftindex filename
+@ftindex glob
+
+
+@defun filename:match?? pattern
+@defunx filename:match-ci?? pattern
+
+Returns a predicate which returns a non-false value if its string argument
+matches (the string) @var{pattern}, false otherwise. Filename matching
+is like
+@cindex glob
+@dfn{glob} expansion described the bash manpage, except that names
+@cindex glob
+beginning with @samp{.} are matched and @samp{/} characters are not
+treated specially.
+
+These functions interpret the following characters specially in
+@var{pattern} strings:
+@table @samp
+@item *
+Matches any string, including the null string.
+@item ?
+Matches any single character.
+@item [@dots{}]
+Matches any one of the enclosed characters. A pair of characters
+separated by a minus sign (-) denotes a range; any character lexically
+between those two characters, inclusive, is matched. If the first
+character following the @samp{[} is a @samp{!} or a @samp{^} then any
+character not enclosed is matched. A @samp{-} or @samp{]} may be
+matched by including it as the first or last character in the set.
+@end table
+@end defun
+
+@defun filename:substitute?? pattern template
+@defunx filename:substitute-ci?? pattern template
+
+Returns a function transforming a single string argument according to
+glob patterns @var{pattern} and @var{template}. @var{pattern} and
+@var{template} must have the same number of wildcard specifications,
+which need not be identical. @var{pattern} and @var{template} may have
+a different number of literal sections. If an argument to the function
+matches @var{pattern} in the sense of @code{filename:match??} then it
+returns a copy of @var{template} in which each wildcard specification is
+replaced by the part of the argument matched by the corresponding
+wildcard specification in @var{pattern}. A @code{*} wildcard matches
+the longest leftmost string possible. If the argument does not match
+@var{pattern} then false is returned.
+
+@var{template} may be a function accepting the same number of string
+arguments as there are wildcard specifications in @var{pattern}. In
+the case of a match the result of applying @var{template} to a list
+of the substrings matched by wildcard specifications will be returned,
+otherwise @var{template} will not be called and @code{#f} will be returned.
+@end defun
+@example
+((filename:substitute?? "scm_[0-9]*.html" "scm5c4_??.htm")
+ "scm_10.html")
+@result{} "scm5c4_10.htm"
+((filename:substitute?? "??" "beg?mid?end") "AZ")
+@result{} "begAmidZend"
+((filename:substitute?? "*na*" "?NA?") "banana")
+@result{} "banaNA"
+((filename:substitute?? "?*?" (lambda (s1 s2 s3) (string-append s3 s1)))
+ "ABZ")
+@result{} "ZA"
+@end example
+
+
+@defun replace-suffix str old new
+
+@var{str} can be a string or a list of strings. Returns a new string
+(or strings) similar to @code{str} but with the suffix string @var{old}
+removed and the suffix string @var{new} appended. If the end of
+@var{str} does not match @var{old}, an error is signaled.
+@end defun
+@example
+(replace-suffix "/usr/local/lib/slib/batch.scm" ".scm" ".c")
+@result{} "/usr/local/lib/slib/batch.c"
+@end example
+
+
+@defun call-with-tmpnam proc k
+
+
+@defunx call-with-tmpnam proc
+Calls @var{proc} with @var{k} arguments, strings returned by successive calls to
+@code{tmpnam}.
+If @var{proc} returns, then any files named by the arguments to @var{proc} are
+deleted automatically and the value(s) yielded by the @var{proc} is(are)
+returned. @var{k} may be ommited, in which case it defaults to @code{1}.
+
+
+@defunx call-with-tmpnam proc suffix1 @dots{}
+Calls @var{proc} with strings returned by successive calls to @code{tmpnam},
+each with the corresponding @var{suffix} string appended.
+If @var{proc} returns, then any files named by the arguments to @var{proc} are
+deleted automatically and the value(s) yielded by the @var{proc} is(are)
+returned.
+@end defun
diff --git a/grapheps.ps b/grapheps.ps
new file mode 100644
index 0000000..87658dd
--- /dev/null
+++ b/grapheps.ps
@@ -0,0 +1,344 @@
+%%EndComments
+/plotdict 100 dict def
+plotdict begin
+
+% Definitions so that internal assignments are bound before setting.
+/DATA 0 def
+/DEN 0 def
+/DIAG 0 def
+/DIAG2 0 def
+/DLTA 0 def
+/EXPSN 0 def
+/GPROCS 0 def
+/GD 6 def
+/GR 3 def
+/IDX 0 def
+/ISIZ 0 def
+/MAX 0 def
+/MIN 0 def
+/NUM 0 def
+/PLOT-bmargin 0 def
+/PLOT-lmargin 0 def
+/PLOT-rmargin 0 def
+/PLOT-tmargin 0 def
+/PROC 0 def
+/ROW 0 def
+/TXT 0 def
+/WPAGE 0 def
+/X-COORD 0 def
+/XDX 0 def
+/XOFF 0 def
+/XPARTS 0 def
+/XRNG 0 def
+/XSCL 0 def
+/XSTEP 0 def
+/XSTEPH 0 def
+/XTSCL 0 def
+/XWID 0 def
+/Y-COORD 0 def
+/YDX 0 def
+/YHIT 0 def
+/YOFF 0 def
+/YPARTS 0 def
+/YRNG 0 def
+/YSCL 0 def
+/YSTEP 0 def
+/YSTEPH 0 def
+/YTSCL 0 def
+/graphrect 0 def
+/plotrect 0 def
+
+% Here are the procedure-arrays for passing as the third argument to
+% plot-column. Plot-column moves to the first coordinate before
+% calls to the first procedure. Thus both line and scatter graphs are
+% supported. Many additional glyph types can be produced as
+% combinations of these types. This is best accomplished by calling
+% plot-column with each component.
+
+% GD and GR are the graphic-glyph diameter and radius.
+% DIAG and DIAG2, used in /cross are diagonal and twice diagonal.
+% gtrans maps x, y coordinates on the stack to 72dpi page coordinates.
+
+% Render line connecting points
+/line [{} {lineto} {}] bind def
+/mountain [{currentpoint 2 copy pop bottomedge moveto lineto}
+ {lineto}
+ {currentpoint pop bottomedge lineto closepath fill}] bind def
+/cloud [{currentpoint 2 copy pop topedge moveto lineto}
+ {lineto}
+ {currentpoint pop topedge lineto closepath fill}] bind def
+% Render lines from x-axis to points
+/impulse [{} {moveto currentpoint pop 0 lineto} {}] bind def
+/bargraph [{} {exch GR sub exch 0 exch GD exch rectstroke} {}] bind def
+
+% Solid round dot.
+/disc [{GD setlinewidth 1 setlinecap}
+ {moveto 0 0 rlineto} {}] bind def
+% Minimal point -- invisible if linewidth is 0.
+/point [{1 setlinecap} {moveto 0 0 rlineto} {}] bind def
+% Square box.
+/square [{} {GR sub exch GR sub exch GD dup rectstroke} {}] bind def
+% Square box at 45.o
+/diamond [{}
+ {2 copy GR add moveto
+ GR neg GR neg rlineto GR GR neg rlineto
+ GR GR rlineto GR neg GR rlineto
+ closepath}
+ {}] bind def
+% Plus Sign
+/plus [{}
+ { GR sub moveto 0 GD rlineto
+ GR neg GR neg rmoveto GD 0 rlineto}
+ {}] bind def
+% X Sign
+/cross [{/DIAG GR .707 mul def /DIAG2 DIAG 2 mul def}
+ {exch DIAG sub exch DIAG add moveto DIAG2 dup neg rlineto
+ DIAG2 neg 0 rmoveto DIAG2 dup rlineto}
+ {}] bind def
+% Triangle pointing upward
+/triup [{}
+ {2 copy GR 1.12 mul add moveto GR neg GR -1.62 mul rlineto
+ GR 2 mul 0 rlineto GR neg GR 1.62 mul rlineto
+ closepath}
+ {}] bind def
+% Triangle pointing downward
+/tridown [{}
+ {2 copy GR 1.12 mul sub moveto GR neg GR 1.62 mul rlineto
+ GR 2 mul 0 rlineto GR neg GR -1.62 mul rlineto
+ closepath}
+ {}] bind def
+/pentagon [{}
+ {gsave translate 0 GR moveto 4 {72 rotate 0 GR lineto} repeat
+ closepath stroke grestore}
+ {}] bind def
+/circle [{stroke} {GR 0 360 arc stroke} {}] bind def
+
+% ( TITLE ) ( SUBTITLE )
+/title-top
+{ dup stringwidth pop -2 div plotrect 0 get plotrect 2 get 2 div add add
+ plotrect 1 get plotrect 3 get add pointsize .4 mul add moveto show
+ dup stringwidth pop -2 div plotrect 0 get plotrect 2 get 2 div add add
+ plotrect 1 get plotrect 3 get add pointsize 1.4 mul add moveto show
+} bind def
+
+% ( TITLE ) ( SUBTITLE )
+/title-bottom
+{ dup stringwidth pop -2 div plotrect 0 get plotrect 2 get 2 div add add
+ plotrect 1 get pointsize -2 mul add moveto show
+ dup stringwidth pop -2 div plotrect 0 get plotrect 2 get 2 div add add
+ plotrect 1 get pointsize -1 mul add moveto show
+} bind def
+
+% Plots column K against column J of given two-dimensional ARRAY.
+% The arguments are:
+% [ ARRAY J K ] J and K are column-indexes into ARRAY
+% [ PREAMBLE RENDER POSTAMBLE ] Plotting procedures:
+% PREAMBLE - Executed once before plotting row
+% RENDER - Called with each pair of coordinates to plot
+% POSTAMBLE - Called once after plotting row (often does stroke)
+/plot-column
+{ /GPROCS exch def aload pop /YDX exch def /XDX exch def /DATA exch def
+ /GD glyphsize def
+ /GR GD .5 mul def
+ gsave
+ /ROW DATA 0 get def ROW XDX get ROW YDX get gtrans moveto
+ GPROCS 0 get exec % preamble
+ /PROC GPROCS 1 get def DATA {dup XDX get exch YDX get gtrans PROC} forall
+ GPROCS 2 get exec stroke % postamble
+ grestore
+} bind def
+
+/whole-page
+{clippath pathbbox 2 index sub exch 3 index sub exch 4 array astore} bind def
+
+/partition-page
+{ /YPARTS exch def /XPARTS exch def /WPAGE exch def
+ /XWID WPAGE 2 get XPARTS div def /YHIT WPAGE 3 get YPARTS div def
+ /Y-COORD WPAGE 1 get def
+ YPARTS
+ { /X-COORD WPAGE 0 get WPAGE 2 get add XWID sub def
+ XPARTS {[X-COORD Y-COORD XWID YHIT]
+ /X-COORD X-COORD XWID sub def} repeat
+ /Y-COORD Y-COORD YHIT add def
+