diff options
author | Steve Langasek <vorlon@debian.org> | 2005-01-10 08:53:33 +0000 |
---|---|---|
committer | Bryan Newbold <bnewbold@robocracy.org> | 2017-02-20 00:05:30 -0800 |
commit | e33f9eb9cf5cc29c36ce2aa7e10cd0f37ae0cc8e (patch) | |
tree | abbf06041619e445f9d0b772b0d58132009d8234 | |
parent | f559c149c83da84d0b1c285f0298c84aec564af9 (diff) | |
parent | 8466d8cfa486fb30d1755c4261b781135083787b (diff) | |
download | slib-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-- | .slibcat | 164 | ||||
-rw-r--r-- | ANNOUNCE | 136 | ||||
-rw-r--r-- | Bev2slib.scm | 2 | ||||
-rw-r--r-- | COPYING | 2 | ||||
-rw-r--r-- | ChangeLog | 2079 | ||||
-rw-r--r-- | DrScheme.init | 61 | ||||
-rw-r--r-- | FAQ | 23 | ||||
-rw-r--r-- | Makefile | 312 | ||||
-rw-r--r-- | README | 88 | ||||
-rw-r--r-- | RScheme.init | 50 | ||||
-rw-r--r-- | STk.init | 63 | ||||
-rw-r--r-- | Template.scm | 146 | ||||
-rw-r--r-- | alist.scm | 55 | ||||
-rw-r--r-- | alist.txi | 70 | ||||
-rw-r--r-- | alistab.scm | 33 | ||||
-rw-r--r-- | array.scm | 186 | ||||
-rw-r--r-- | array.txi | 136 | ||||
-rw-r--r-- | arraymap.scm | 83 | ||||
-rw-r--r-- | arraymap.txi | 68 | ||||
-rw-r--r-- | batch.scm | 145 | ||||
-rw-r--r-- | bigloo.init | 82 | ||||
-rw-r--r-- | break.scm | 29 | ||||
-rw-r--r-- | byte.scm | 214 | ||||
-rw-r--r-- | byte.txi | 179 | ||||
-rw-r--r-- | bytenumb.scm | 346 | ||||
-rw-r--r-- | bytenumb.txi | 181 | ||||
-rw-r--r-- | chap.scm | 47 | ||||
-rw-r--r-- | chap.txi | 46 | ||||
-rw-r--r-- | charplot.scm | 380 | ||||
-rw-r--r-- | chez.init | 75 | ||||
-rw-r--r-- | cie1931.xyz | 82 | ||||
-rw-r--r-- | cie1964.xyz | 82 | ||||
-rw-r--r-- | cltime.scm | 10 | ||||
-rw-r--r-- | coerce.scm | 2 | ||||
-rw-r--r-- | collect.scm | 105 | ||||
-rw-r--r-- | collectx.scm | 247 | ||||
-rw-r--r-- | color.scm | 674 | ||||
-rw-r--r-- | color.txi | 345 | ||||
-rw-r--r-- | colornam.scm | 117 | ||||
-rw-r--r-- | colornam.txi | 75 | ||||
-rw-r--r-- | colorspc.scm | 536 | ||||
-rw-r--r-- | comlist.scm | 317 | ||||
-rw-r--r-- | comparse.scm | 76 | ||||
-rw-r--r-- | comparse.txi | 81 | ||||
-rw-r--r-- | crc.scm | 137 | ||||
-rw-r--r-- | cring.scm | 30 | ||||
-rw-r--r-- | cvs.scm | 140 | ||||
-rw-r--r-- | cvs.txi | 32 | ||||
-rw-r--r-- | daylight.scm | 356 | ||||
-rw-r--r-- | daylight.txi | 117 | ||||
-rw-r--r-- | db2html.scm | 77 | ||||
-rw-r--r-- | db2html.txi | 13 | ||||
-rw-r--r-- | dbcom.scm | 215 | ||||
-rw-r--r-- | dbinterp.scm | 34 | ||||
-rw-r--r-- | dbrowse.scm | 14 | ||||
-rw-r--r-- | dbsyn.scm | 54 | ||||
-rw-r--r-- | dbutil.scm | 674 | ||||
-rw-r--r-- | dbutil.txi | 219 | ||||
-rw-r--r-- | debian/changelog | 76 | ||||
-rw-r--r-- | debian/control | 5 | ||||
-rw-r--r-- | debian/copyright | 7 | ||||
-rw-r--r-- | debian/doc-base | 9 | ||||
-rw-r--r-- | debian/postinst | 10 | ||||
-rwxr-xr-x | debian/rules | 8 | ||||
-rw-r--r-- | debug.scm | 6 | ||||
-rw-r--r-- | defmacex.scm | 4 | ||||
-rw-r--r-- | determ.scm | 157 | ||||
-rw-r--r-- | determ.txi | 47 | ||||
-rw-r--r-- | differ.scm | 521 | ||||
-rw-r--r-- | differ.txi | 90 | ||||
-rw-r--r-- | dirs.scm | 98 | ||||
-rw-r--r-- | dirs.txi | 46 | ||||
-rw-r--r-- | dwindtst.scm | 2 | ||||
-rw-r--r-- | dynamic.scm | 10 | ||||
-rw-r--r-- | dynwind.scm | 6 | ||||
-rw-r--r-- | elk.init | 69 | ||||
-rw-r--r-- | eval.scm | 12 | ||||
-rw-r--r-- | factor.scm | 39 | ||||
-rw-r--r-- | fft.scm | 44 | ||||
-rw-r--r-- | fft.txi | 32 | ||||
-rw-r--r-- | fluidlet.scm | 9 | ||||
-rw-r--r-- | fmtdoc.txi | 434 | ||||
-rw-r--r-- | format.scm | 22 | ||||
-rw-r--r-- | formatst.scm | 19 | ||||
-rw-r--r-- | gambit.init | 73 | ||||
-rw-r--r-- | genwrite.scm | 4 | ||||
-rw-r--r-- | getopt.scm | 34 | ||||
-rw-r--r-- | getparam.scm | 132 | ||||
-rw-r--r-- | getparam.txi | 85 | ||||
-rw-r--r-- | glob.scm | 136 | ||||
-rw-r--r-- | glob.txi | 100 | ||||
-rw-r--r-- | grapheps.ps | 344 | ||||
-rw-r--r-- | grapheps.scm | 617 | ||||
-rw-r--r-- | grapheps.txi | 465 | ||||
-rw-r--r-- | guile.init | 420 | ||||
-rw-r--r-- | guile.init.local | 416 | ||||
-rw-r--r-- | hash.scm | 42 | ||||
-rw-r--r-- | hashtab.scm | 78 | ||||
-rw-r--r-- | hashtab.txi | 84 | ||||
-rw-r--r-- | html4each.scm | 240 | ||||
-rw-r--r-- | html4each.txi | 70 | ||||
-rw-r--r-- | htmlform.scm | 74 | ||||
-rw-r--r-- | htmlform.txi | 27 | ||||
-rw-r--r-- | http-cgi.scm | 34 | ||||
-rw-r--r-- | lineio.scm | 34 | ||||
-rw-r--r-- | lineio.txi | 19 | ||||
-rw-r--r-- | logical.scm | 335 | ||||
-rw-r--r-- | macscheme.init | 47 | ||||
-rw-r--r-- | macwork.scm | 18 | ||||
-rw-r--r-- | makcrc.scm | 96 | ||||
-rw-r--r-- | manifest.scm | 350 | ||||
-rw-r--r-- | manifest.txi | 145 | ||||
-rw-r--r-- | matfile.scm | 187 | ||||
-rw-r--r-- | matfile.txi | 31 | ||||
-rw-r--r-- | mbe.scm | 72 | ||||
-rw-r--r-- | minimize.scm | 3 | ||||
-rw-r--r-- | mitscheme.init | 305 | ||||
-rw-r--r-- | mkclrnam.scm | 259 | ||||
-rw-r--r-- | mkclrnam.txi | 54 | ||||
-rw-r--r-- | mklibcat.scm | 401 | ||||
-rw-r--r-- | modular.scm | 180 | ||||
-rw-r--r-- | modular.txi | 114 | ||||
-rw-r--r-- | mulapply.scm | 22 | ||||
-rw-r--r-- | mularg.scm | 20 | ||||
-rw-r--r-- | mwexpand.scm | 40 | ||||
-rw-r--r-- | mwsynrul.scm | 8 | ||||
-rw-r--r-- | ncbi-dna.scm | 172 | ||||
-rw-r--r-- | ncbi-dna.txi | 54 | ||||
-rw-r--r-- | nclients.scm | 385 | ||||
-rw-r--r-- | nclients.txi | 103 | ||||
-rw-r--r-- | null.scm | 1 | ||||
-rw-r--r-- | obj2str.scm | 3 | ||||
-rw-r--r-- | object.scm | 18 | ||||
-rw-r--r-- | object.texi (renamed from objdoc.txi) | 0 | ||||
-rw-r--r-- | paramlst.scm | 18 | ||||
-rw-r--r-- | phil-spc.scm | 94 | ||||
-rw-r--r-- | phil-spc.txi | 38 | ||||
-rw-r--r-- | plottest.scm | 27 | ||||
-rw-r--r-- | pnm.scm | 277 | ||||
-rw-r--r-- | pnm.txi | 66 | ||||
-rw-r--r-- | pp.scm | 8 | ||||
-rw-r--r-- | ppfile.scm | 7 | ||||
-rw-r--r-- | prec.scm | 72 | ||||
-rw-r--r-- | printf.scm | 21 | ||||
-rw-r--r-- | priorque.scm | 73 | ||||
-rw-r--r-- | priorque.txi | 33 | ||||
-rw-r--r-- | process.scm | 7 | ||||
-rw-r--r-- | promise.scm | 15 | ||||
-rw-r--r-- | pscheme.init | 44 | ||||
-rw-r--r-- | psxtime.scm | 40 | ||||
-rw-r--r-- | qp.scm | 35 | ||||
-rw-r--r-- | queue.scm | 77 | ||||
-rw-r--r-- | queue.txi | 60 | ||||
-rw-r--r-- | r4rsyn.scm | 2 | ||||
-rw-r--r-- | randinex.scm | 42 | ||||
-rw-r--r-- | randinex.txi | 21 | ||||
-rw-r--r-- | random.scm | 69 | ||||
-rw-r--r-- | random.txi | 26 | ||||
-rw-r--r-- | ratize.scm | 43 | ||||
-rw-r--r-- | ratize.txi | 41 | ||||
-rw-r--r-- | rdms.scm | 287 | ||||
-rw-r--r-- | recobj.scm | 11 | ||||
-rw-r--r-- | record.scm | 27 | ||||
-rw-r--r-- | repl.scm | 81 | ||||
-rw-r--r-- | report.scm | 116 | ||||
-rw-r--r-- | require.scm | 280 | ||||
-rw-r--r-- | resenecolours.txt | 1410 | ||||
-rw-r--r-- | root.scm | 14 | ||||
-rw-r--r-- | s48-0_57.init | 85 | ||||
-rw-r--r-- | saturate.txt | 39 | ||||
-rw-r--r-- | sc2.scm | 15 | ||||
-rw-r--r-- | sc4opt.scm | 17 | ||||
-rw-r--r-- | sc4sc3.scm | 2 | ||||
-rw-r--r-- | scainit.scm | 25 | ||||
-rw-r--r-- | scamacr.scm | 2 | ||||
-rw-r--r-- | scanf.scm | 514 | ||||
-rw-r--r-- | scheme2c.init | 70 | ||||
-rw-r--r-- | scheme48.init | 85 | ||||
-rw-r--r-- | schmooz.scm | 434 | ||||
-rw-r--r-- | schmooz.texi | 18 | ||||
-rw-r--r-- | scm.init | 1 | ||||
-rw-r--r-- | scmacro.scm | 21 | ||||
-rw-r--r-- | scsh.init | 63 | ||||
-rw-r--r-- | selfset.scm | 2 | ||||
-rw-r--r-- | sierpinski.scm | 2 | ||||
-rw-r--r-- | simetrix.scm | 5 | ||||
-rw-r--r-- | slib.html | 76 | ||||
-rw-r--r-- | slib.info | 10520 | ||||
-rwxr-xr-x | slib.sh | 119 | ||||
-rw-r--r-- | slib.spec | 37 | ||||
-rw-r--r-- | slib.texi | 6464 | ||||
-rw-r--r-- | slib_1.html | 1172 | ||||
-rw-r--r-- | slib_10.html | 217 | ||||
-rw-r--r-- | slib_11.html | 268 | ||||
-rw-r--r-- | slib_12.html | 346 | ||||
-rw-r--r-- | slib_13.html | 325 | ||||
-rw-r--r-- | slib_14.html | 314 | ||||
-rw-r--r-- | slib_15.html | 367 | ||||
-rw-r--r-- | slib_16.html | 311 | ||||
-rw-r--r-- | slib_17.html | 461 | ||||
-rw-r--r-- | slib_18.html | 331 | ||||
-rw-r--r-- | slib_19.html | 214 | ||||
-rw-r--r-- | slib_2.html | 824 | ||||
-rw-r--r-- | slib_20.html | 294 | ||||
-rw-r--r-- | slib_21.html | 271 | ||||
-rw-r--r-- | slib_22.html | 180 | ||||
-rw-r--r-- | slib_3.html | 2013 | ||||
-rw-r--r-- | slib_4.html | 5157 | ||||
-rw-r--r-- | slib_5.html | 6100 | ||||
-rw-r--r-- | slib_6.html | 3658 | ||||
-rw-r--r-- | slib_7.html | 8218 | ||||
-rw-r--r-- | slib_8.html | 767 | ||||
-rw-r--r-- | slib_9.html | 340 | ||||
-rw-r--r-- | slib_abt.html | 205 | ||||
-rw-r--r-- | slib_fot.html | 92 | ||||
-rw-r--r-- | slib_ovr.html | 69 | ||||
-rw-r--r-- | slib_toc.html | 676 | ||||
-rw-r--r-- | solid.scm | 943 | ||||
-rw-r--r-- | solid.txi | 441 | ||||
-rw-r--r-- | sort.scm | 251 | ||||
-rw-r--r-- | soundex.scm | 30 | ||||
-rw-r--r-- | srcdir.mk | 2 | ||||
-rw-r--r-- | srfi-1.scm | 230 | ||||
-rw-r--r-- | srfi-1.txi | 86 | ||||
-rw-r--r-- | srfi-2.scm | 41 | ||||
-rw-r--r-- | srfi-2.txi | 8 | ||||
-rw-r--r-- | srfi-8.scm | 14 | ||||
-rw-r--r-- | srfi-8.txi | 8 | ||||
-rw-r--r-- | srfi-9.scm | 16 | ||||
-rw-r--r-- | srfi.scm | 2 | ||||
-rw-r--r-- | stdio.scm | 5 | ||||
-rw-r--r-- | strcase.scm | 41 | ||||
-rw-r--r-- | strport.scm | 6 | ||||
-rw-r--r-- | strsrch.scm | 164 | ||||
-rw-r--r-- | structure.scm | 2 | ||||
-rw-r--r-- | subarray.scm | 172 | ||||
-rw-r--r-- | subarray.txi | 94 | ||||
-rw-r--r-- | synchk.scm | 2 | ||||
-rw-r--r-- | synclo.scm | 12 | ||||
-rw-r--r-- | synrul.scm | 2 | ||||
-rw-r--r-- | t3.init | 49 | ||||
-rw-r--r-- | tek40.scm | 92 | ||||
-rw-r--r-- | tek41.scm | 147 | ||||
-rw-r--r-- | timezone.scm | 16 | ||||
-rw-r--r-- | top-refs.scm | 285 | ||||
-rw-r--r-- | top-refs.txi | 65 | ||||
-rw-r--r-- | trace.scm | 24 | ||||
-rw-r--r-- | transact.scm | 486 | ||||
-rw-r--r-- | transact.txi | 150 | ||||
-rw-r--r-- | tree.scm | 69 | ||||
-rw-r--r-- | tree.txi | 48 | ||||
-rw-r--r-- | trnscrpt.scm | 18 | ||||
-rw-r--r-- | tsort.scm | 58 | ||||
-rw-r--r-- | tsort.txi | 53 | ||||
-rw-r--r-- | tzfile.scm | 134 | ||||
-rw-r--r-- | umbscheme.init | 50 | ||||
-rw-r--r-- | uri.scm | 139 | ||||
-rw-r--r-- | uri.txi | 87 | ||||
-rw-r--r-- | values.scm | 4 | ||||
-rw-r--r-- | version.txi | 4 | ||||
-rw-r--r-- | vet.scm | 218 | ||||
-rw-r--r-- | vet.txi | 35 | ||||
-rw-r--r-- | vscm.init | 66 | ||||
-rw-r--r-- | withfile.scm | 26 | ||||
-rw-r--r-- | wttest.scm | 2 | ||||
-rw-r--r-- | wttree.scm | 6 | ||||
-rw-r--r-- | yasyn.scm | 253 |
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") +) @@ -1,72 +1,56 @@ -This message announces the availability of Scheme Library release slib2d2. - -New in slib2d2: - - * s48-0_57.init: Added. - * array.scm (make-shared-array): Fixed offset. - * record.scm: Changed identifiers containing VECTOR to VECT or VCT - (but no help for scheme48-0.57). - * slib.texi (Collections, Lists as sets, Multi-argument / and -, - Multi-argument Apply): Improved procedure templates. - * comlist.scm: Replaced single-letter identifier names to improve - readability. - * slib.texi (Lists as sequences): Updated examples per change to - comlist.scm. - * comlist.scm (comlist:union, comlist:intersection, - comlist:set-difference, comlist:remove-if, comlist:remove-if-not, - comlist:remove-duplicates): Earlier tail-recursion enhancements - changed the element order; which broke things. Order restored. - * array.scm: Rewritten to sidestep license issues. - (array=?): Added. - * slib.texi (Arrays): Documentation integrated with array.scm. - * tree.scm (tree:subst): Rewritten; takes optional equality - predicate argument. - * Makefile (docfiles): Added "COPYING". - * mitcomp.pat: Unmaintained; removed. - * RScheme.init: Put in the public domain. - * Makefile (slib48): Simplified: scheme48 < scheme48.init - * scheme48.init (slib-primitives): Pipe into scheme48, not load. - Scheme48-0.45 the only version which runs jacal successfully. - * scmactst.scm: Removed for lack of license. - * struct.scm, structst.scm: Removed. struct.scm lacks license. - * scheme48.init (atan): Added workaround. - * Makefile (slib48-0.55): Makes slib48, but fluid-let broken. - * format.scm (mutliarg/and-): Requires. - * mularg.scm (two-arg:/, two-arg:-): Added. - * scheme48.init (*features*): Doesn't support multiarg/and-. - * Makefile (slib48-0.45): Added ",load-package floatnums". - * slib.texi (Installation): Added specific instructions for - DrScheme, MIT-Scheme, and Guile. - * guile.init: Added. - * require.scm (program-vicinity): Improved error message. - * slib.texi (Installation): Explicit instructions for MzScheme. - * Makefile (pdf): Added target for creating $(htmldir)slib.pdf. - * slib.texi (Installation): Expanded instructions. - * bigloo.init, RScheme.init, STk.init (*features*): Provide srfi. - * Template.scm, *.init (*features*): Put into consistent form. - * require.scm (srfi): Detect presence of srfi-0 through srfi-30. - * srfi-1.scm: Added. - * comlist.scm (comlist:remove): Returns don't disturb order. - * array.scm: Generalized so strings and vectors are arrays. - * slib.texi (Standard Formatted Output): %b was missing. - * slib.texi (Sorting and Searching): Section split from - "Procedures". - * differ.scm (diff:longest-common-subsequence): Added. - (diff:longest-common-subsequence, diff:edits, diff:edit-length): - Optional third argument is equality predicate. - * differ.scm: An O(NP) Sequence Comparison Algorithm. - * srfi.scm (cond-expand): Added. - * wttree.scm (error:error): Replaces error. - * dbutil.scm (make-defaulter): number defaults to 0. - * Makefile (rpm): Fixed dependencies. - -From Jacques Mequin <jmequin@tif.ti.com> - * gambit.init: (set-case-conversion! #t) - * scheme48.init (defmacro): Defmacro in terms of define-syntax - using defmacro:expand*. - -From Wade Humeniuk <humeniuw@cadvision.com> - * yasyn.scm, object.scm, recobj.scm: Placed in public domain. +This message announces the availability of Scheme Library release slib3a1. + +New in slib3a1: + + SLIB 3 has undergone major development from SLIB2d6. + + Most noticeable is that SLIB now has a module system with documented + semantics and a suite of reflexive tools for deriving reference and + module dependencies from library code. The reflexive tools are + designed to support compiler-writer's needs as expressed in + discussions arising from comp.lang.scheme in July 2003. + + The module semantics are intended to be compatible both with + implementations having module systems and those lacking. Ivan + Shmakov has been striving to integrate SLIB's and Scheme48's module + systems. His efforts and SLIB's reflexive tools have found a great + many bugs, some of them present since SLIB's beginnings. + + "make install" now creates a "slib" shell script for running various + Schemes with SLIB initialization. Currently supported + implementations are gsi (Gambit), Guile, MzScheme, Scheme48, and + SCM. + + The byte-number module converts between byte-vectors, + twos-complement integers, and IEEE floating-point formats -- all in + R4RS-compliant Scheme code. It also converts byte-vectors to a form + whose lexicographic ordering matches the encoded number's ordering. + + The correctly ordered byte representations of numbers tie in with + SLIB's relational database being extended to include indexed + sequential access methods (ISAM). The Database-interpolation module + uses sequential methods to synthesize continuous functions from + discrete data tables. + + These "continuous databases" are vital to my soon-to-be-released + optics program which calculates spectral responses of layered thin + films. + + The character plotting utility has been improved, and is now + complemented by eps-graph, a very flexible graphing library for + producing encapsulated-PostScript files. + + SRFI-2, SRFI-8, and SRFI-9 are added. + + Although I have endeavored to support legacy usage, some programs + will need modification to work with SLIB 3. Some issues that I know + of are: + + * REQUIRE no longer accepts a string as its argument. + * The RANDOM module is split into RANDOM and RANDOM-INEXACT. + * Some refactoring among TRANSACT, GLOB, and LINE-I/O. + + -=-=- SLIB is a portable Scheme library providing compatibiliy and utility functions for all standard Scheme implementations. @@ -79,17 +63,17 @@ Documentation includes a manifest, installation instructions, and coding guidelines for the library. Documentation of each library package is supplied. SLIB Documentation is online at: - http://swissnet.ai.mit.edu/~jaffer/SLIB.html + http://swissnet.ai.mit.edu/~jaffer/SLIB.html SLIB is available from: - http://swissnet.ai.mit.edu/ftpdir/scm/slib2d2.zip - http://swissnet.ai.mit.edu/ftpdir/scm/slib-2d2-1.noarch.rpm - swissnet.ai.mit.edu:/pub/scm/slib2d2.zip - swissnet.ai.mit.edu:/pub/scm/slib-2d2-1.noarch.rpm + http://swissnet.ai.mit.edu/ftpdir/scm/slib3a1.zip + http://swissnet.ai.mit.edu/ftpdir/scm/slib-3a1-1.noarch.rpm + swissnet.ai.mit.edu:/pub/scm/slib3a1.zip + swissnet.ai.mit.edu:/pub/scm/slib-3a1-1.noarch.rpm SLIB-PSD is a portable debugger for Scheme (requires emacs editor): - http://swissnet.ai.mit.edu/ftpdir/scm/slib-psd1-3.zip - swissnet.ai.mit.edu:/pub/scm/slib-psd1-3.zip + http://swissnet.ai.mit.edu/ftpdir/scm/slib-psd1-3.tar.gz + swissnet.ai.mit.edu:/pub/scm/slib-psd1-3.tar.gz SCHELOG is an embedding of Prolog in Scheme+SLIB: http://www.cs.rice.edu/CS/PLT/packages/schelog/ diff --git a/Bev2slib.scm b/Bev2slib.scm index 8461c5c..30562f5 100644 --- a/Bev2slib.scm +++ b/Bev2slib.scm @@ -8,7 +8,7 @@ ;1. Any copy made of this software must include this copyright notice ;in full. ; -;2. I have made no warrantee or representation that the operation of +;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; @@ -27,7 +27,7 @@ the beginning of "require.scm" states: ;1. Any copy made of this software must include this copyright notice ;in full. ; - ;2. I have made no warrantee or representation that the operation of + ;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; @@ -1,3 +1,2066 @@ +2003-11-30 Aubrey Jaffer <jaffer@scm.jaffer> + + * require.scm (*SLIB-VERSION*): Bumped from 2d6 to 3a1. + +2003-11-30 Aubrey Jaffer <agj@alum.mit.edu> + + * mklibcat.scm (precedence-parse): defmacro because uses + fluid-let. + +2003-11-29 Aubrey Jaffer <agj@alum.mit.edu> + + * grapheps.scm: Added introduction. + + * charplot.scm (charplot:array->list): Added missing SCM function. + + * grapheps.scm (set-color): Use setgray instead of slib GREY. + + * array.scm (make-array): Removed. + + * dbutil.scm (mdbm:try-opens): Try alist-table when all types in + *base-table-implementations* failed. + +2003-11-28 Aubrey Jaffer <agj@alum.mit.edu> + + * grapheps.scm: Reorganized for better documentation flow. + + * Makefile (txiscms, txifiles): grapheps now schmoozed. + + * slib.texi (Graphing): Node hosts "Character Plotting" and + subtree "PostScript Graphing". + + * grapheps.scm: Documented and fixed minor bugs. + + * grapheps.ps (y-axis, x-axis): Check for axis within bounds. + +2003-11-27 Aubrey Jaffer <agj@alum.mit.edu> + + * grapheps.scm (create-postscript-graph): Take document %%title + from title-top and title-bottom. + (grid-verticals, grid-horizontals): Split gridding. + (plot): Ported charplot function. + + * grapheps.ps: PostScript runtime support for creating graphs. + + * grapheps.scm: Procedures for creating PostScript graphs. + +2003-11-23 Aubrey Jaffer <agj@alum.mit.edu> + + * array.scm (make-prototype-checker): Added prototype checks. + +2003-11-18 Aubrey Jaffer <agj@alum.mit.edu> + + * charplot.scm: Code cleanup and comments. + +2003-11-17 Aubrey Jaffer <agj@alum.mit.edu> + + * gambit.init (define-macro): Set *defmacros*; macroexpand works! + +2003-11-15 Aubrey Jaffer <agj@alum.mit.edu> + + * charplot.scm (charplot:plot-function): Changed dats array to + Ar64. Changed scaling by one so last x is tried. + (charplot:make-array): Reduced width by one so newline is in + column 79. + (charplot:plot): Output extra newline if x scale overruns it. + +2003-11-10 Aubrey Jaffer <agj@alum.mit.edu> + + * slib.texi (Feature): *features* no longer advertised. + + * vet.scm (provided+?): Added. Converted to predicate argument. + + * fluidlet.scm (fluid-let): Recoded trivial use of make-list. + + * gambit.init (implementation-vicinity): Use Gambc-3.0 default. + (home-vicinity): Added. + (print-call-stack): Added stub to satisfy 'TRACE. + (defmacro): slib:eval workaround of macro restrictions. + + * mitscheme.init (*features*): Has FLUID-LET. + + * manifest.scm: Updated examples. + (feature->requires, file->requires): Take predicate argument + PROVIDED? instead of features-list. + +2003-11-09 Aubrey Jaffer <agj@alum.mit.edu> + + * slib.texi (The Library System): Reorganized. + (Catalog Vicinities): Separated from "Library Catalogs". + +2003-11-08 Aubrey Jaffer <agj@alum.mit.edu> + + * random.scm (seed->random-state): Seed is string, not bytes. + +2003-11-05 Aubrey Jaffer <agj@alum.mit.edu> + + * arraymap.scm (array-map): Added. + +2003-11-02 Aubrey Jaffer <agj@alum.mit.edu> + + * mkclrnam.scm, dbrowse.scm, dbcom.scm, db2html.scm: + Replaced type uint with ordinal. + + * rdms.scm, alistab.scm: Replaced types uint, base-id by ordinal. + +2003-11-01 Aubrey Jaffer <agj@alum.mit.edu> + + * rdms.scm (domains:init-data): Simplified. + (slib:error): Replaces alias rdms:error. + +2003-10-31 Aubrey Jaffer <agj@alum.mit.edu> + + * slib.texi (Base Table): Reorganized subsection into 9 node tree. + + * rdms.scm (isam-next, isam-prev): Take optional column argument. + + * scheme48.init, s48-0_57.init (inexact->exact, exact->inexact): + Workaround exactness bug. + +2003-10-30 Aubrey Jaffer <agj@alum.mit.edu> + + * slib.texi (Base Table): Description of wb-table and rwb-isam. + + * rdms.scm (isam-prev isam-next): Added. + +2003-10-29 Aubrey Jaffer <agj@alum.mit.edu> + + * slib.texi (Indexed Sequential Access Methods): Added. + (Table Operations): Reorganized subsection into into 6 node tree. + +2003-10-28 Aubrey Jaffer <agj@alum.mit.edu> + + * slib.texi (Base Table): Added new MAKE-GETTER-1 method + retrieving single non-key field. + + * rdms.scm (get, get*): Use optional make-getter-1 method. + +2003-10-25 Aubrey Jaffer <agj@alum.mit.edu> + + * dbutil.scm (define-tables): Replaced for-each row:insert with + row:insert*. + + * slib.texi (Require): Updated examples. + (Feature): Clarified about *features* per session. + (Base Table): Added rwb-isam. + + * rdms.scm (catalog:init-cols): TABLE-NAME now symbol. + (domains:init-data): ATOM is just symbol or #f. + + * comlist.scm (butnthcdr): Fixed short-list bug. + +2003-10-24 Aubrey Jaffer <agj@alum.mit.edu> + + * rdms.scm (coltab-name domain-name): Changed to symbol from atom. + + * comlist.scm (butnthcdr): SIMSYNCH FIFO8 uses negative k. + + * dbutil.scm (define-domains): Added. + +2003-10-18 Aubrey Jaffer <agj@alum.mit.edu> + + * comlist.scm (remove-duplicates): moved LETREC outside. + (butlast): Defined in terms of BUTNTHCDR. + (butnthcdr): SET-CDR! to avoid using REVERSE. + + * rdms.scm (combine-primary-keys): Removed primary-limit + restriction. + +2003-10-17 Aubrey Jaffer <agj@alum.mit.edu> + + * byte.scm (substring-write, substring-read!): Added. + + * random.scm (random:chunk): Changed from using arrays to bytes. + +2003-10-16 Aubrey Jaffer <agj@alum.mit.edu> + + * byte.scm (read-bytes!): Return number of bytes read. + (read-bytes): Shorten returned bytes to number of bytes read. + +2003-10-13 <agj@alum.mit.edu> + + * Makefile (efiles): bytenumb.scm was called out twice. + +2003-10-12 <agj@alum.mit.edu> + + * byte.scm (write-bytes, write-byte, make-bytes): Fixed @args. + +2003-10-09 Aubrey Jaffer <agj@alum.mit.edu> + + * bytenumb.scm (IEEE-byte-decollate!, IEEE-byte-collate!) + (integer-byte-collate!): Return byte-vector. + +2003-10-08 Aubrey Jaffer <agj@alum.mit.edu> + + * bytenumb.scm (ieee-double->bytes, ieee-float->bytes): Added. + (integer-byte-collate!, integer-byte-collate, IEEE-byte-collate!) + (IEEE-byte-decollate!, IEEE-byte-collate, IEEE-byte-decollate): + Added. + +2003-10-04 Aubrey Jaffer <agj@alum.mit.edu> + + * differ.scm (fp:compare): Use negative p-lim for no-limit. + + * sort.scm (sorted?, sort!, sort): Generalized to arrays. + + * differ.scm: Always require SORT. + (diff:longest-common-subsequence, diff:edits) + (diff:edit-length): Moved all but argument handling out. + (diff2lcs, diff2edits, diff2editlen): Schlepable top-levels. + (diff:order-edits): Coded sign reversal in DO loop. + (diff:divide-and-conquer): Allocate and fp:init! fp array. + (check-cost): Pulled out of diff:divide-and-conquer. + (fp:init!): Added. + (fp:compare): fp passed in. + (diff2edits): MAXDX was off-by-one. + (diff:divide-and-conquer, diff2et, diff2ez): Reuse passed fp. + Initialize only used segment of fp. + (diff2edits): Allocate just one CCRR and pass to procedures. + (diff:order-edits): Converted vector usage to arrays. + (diff2ez, diff2et, diff:divide-and-conquer): Reuse passed CCRR. + (fp:init!): Take fill argument. + +2003-09-30 Aubrey Jaffer <agj@alum.mit.edu> + + * collectx.scm: Expand automatically from collect.scm. + + * Makefile (collectx.scm): Build target using created collect.sc. + + * collect.scm (object): Added (require 'object) for collectx.scm. + + * macwork.scm (mw:suffix-character): Replaced non-R5RS-compliant + #\| with #\!. + + * slib.texi (Exact Random Numbers, Inexact Random Numbers): Made + independent packages. + + * randinex.scm: Separated package random-inexact from random. + (random:normal-vector!): Made *2pi internal. + + * random.scm (random): Now does only exact integers. + + * htmlform.scm (get-foreign-choices): Moved from db2html.scm in + order to eliminate circular require. + +2003-09-25 Aubrey Jaffer <agj@alum.mit.edu> + + * matfile.scm (matfile:read-matrix): Version 4 MAT-file endianness + cannot be detected from just the first word; ambiguous when 0. + Converted to use 'byte-number functions. + (matfile:read, matfile:load): Improved error handling. + + * slib.texi (Byte): Schmoozed. + (Byte/Number Conversions): Added. + + * Makefile (efiles, txiscms, txifiles): Added bytenumb. + + * byte.scm (bytes-copy, bytes-reverse, bytes-reverse!) + (read-bytes, write-bytes): Added. + + * bytenumb.scm: Added: Byte/integer and IEEE floating-point + conversions. + +2003-09-21 Ivan Shmakov <ivan@theory.dcn-asu.ru> + + * pnm.scm (pnm:array-write, pnm:type-dimensions): Fixed 'typo'. + + * schmooz.scm (schmooz-tops): Replaced #\tab with slib:tab. + + * yasyn.scm (print, size): ! replaces | in identifiers. + +2003-09-21 Aubrey Jaffer <agj@alum.mit.edu> + + * dirs.scm (transact): Eliminated require circularity. + + * glob.scm (call-with-tmpnam): Moved from transact.scm. String + arguments taken as suffixes for tmpnams. + + * lineio.scm (system->line): Moved from transact.scm. + (display-file): Removed. + + * scanf.scm (sscanf): No longer calls string-port export. + (stdio:scan-and-set): Moved call-with-input-string from sscanf. + +2003-09-14 Aubrey Jaffer <agj@alum.mit.edu> + + * ncbi-dna.scm (ncbi:read-DNA-sequence): Discard to end of ORIGIN + line (which can have chromosome location). + +2003-09-09 Aubrey Jaffer <agj@alum.mit.edu> + + * matfile.scm (ieee-float->bytes): Added. + + * sort.scm (sort, sort!, sorted?): Generalized to strings. + +2003-08-31 Aubrey Jaffer <agj@alum.mit.edu> + + * top-refs.scm: Footnote closing brace on @end line chokes + texi2html. + + * Makefile: Moved documentation targets after txifiles definition + so dependencies work correctly. + +2003-08-29 Aubrey Jaffer <agj@alum.mit.edu> + + * slib.texi (Relational Infrastructure): Collected internal + details of database operations. + +2003-08-26 Aubrey Jaffer <agj@alum.mit.edu> + + * dbutil.scm (open-table, open-table!): Added. + (create-database): Expanded documentation. + require-if 'compiling 'alist-table. + + * slib.texi (Relational Database Objects, Database Operations): + Deprecated in favor of section "Using Databases". + +2003-08-26 dai inukai <inukai.d@jeans.ocn.ne.jp> + + * transact.scm (emacs-lock:certificate): "ls -ld" is more portable + [GNU, FreeBSD, Vine Linux, Debian Linux] than "ls -o". + +2003-08-22 Aubrey Jaffer <agj@alum.mit.edu> + + * dbrowse.scm (browse:display-dir): Keys can be other than strings + or symbols. + +2003-08-18 Aubrey Jaffer <agj@alum.mit.edu> + + * dbutil.scm (create-database): Gracefully return #f when + (not (assq type *base-table-implementations*)). + +2003-08-17 Aubrey Jaffer <agj@alum.mit.edu> + + * pnm.scm (pnm:read+integer): Replaced by READ. + +2003-08-09 Aubrey Jaffer <agj@alum.mit.edu> + + * slib.texi (Basic Operations on Weight-Balanced Trees): wt-tree? + removed because it isn't exported. + +2003-07-25 Aubrey Jaffer <agj@alum.mit.edu> + + * scanf.scm (stdio:scan-and-set): Fixed scope of (return). + + * manifest.scm (feature->exports): Added; returns simple list. + (feature->export-alist): Renamed from feature->exports. + (feature->requires): Don't cons feature onto list. + + * slib.texi (Configuration): Use /usr/local/lib/scm/ in examples. + + * vet.scm (vet-slib): Use feature->exports. + +2003-07-24 Aubrey Jaffer <agj@alum.mit.edu> + + * mklibcat.scm (http, color, ncbi-dna): Are defmacro features. + + * schmooz.scm (schmooz:read-word): Replaced single use of scanf. + + * pnm.scm (pnm:array-write): Removed use of printf. + (pnm:read+integer): Removed use of scanf. + + * scanf.scm (stdio:scan-and-set): Minor cleanup. + + * slib.texi (Module Conventions): Added macro rules. + +2003-07-23 Aubrey Jaffer <agj@alum.mit.edu> + + * Template.scm (defmacro:expand*): Don't export. + + * defmacex.scm (defmacro:expand*): Exported. + + * mklibcat.scm: Added DEFMACRO for many 'scanf users. + + * slib.texi (Syntax-Case Macros): Added @findex define-structure. + (Spectra): Added @findex load-ciexyz. + (Color Conversions): Added color:linear-transform. + (Collections): Added @findex for gen-keys, gen-elts. + + * Makefile (bfiles): Added collectx.scm. + + * yasyn.scm (size, print): Replaced with macro expansions. + (pormat): Coded out printf. + Moved all define-syntax forms to end. + + * top-refs.scm (top-refs:expression): Handle WITH-SYNTAX; Don't + give up on ... in let* bindings. + + * schmooz.scm (schmooz-top): Fixed typo in error call. + + * manifest.scm (feature->exports): Handle aliases. Warn, not err. + + * transact.scm, uri.scm: Always require 'scanf since it needs + defmacro. + + * vet.scm (slib:catalog): Static SLIB part of *catalog*. + (vet-slib): Fixed handling of aggregate entries' exports. + + * collectx.scm: Copy of collect.scm where DEFINE-OPERATIONs are + replaced with macros-that-work expansions. + + * collect.scm: Cleaned up error messages and aliases. + +2003-07-22 Aubrey Jaffer <agj@alum.mit.edu> + + * slib.texi (Promises): Added delay macro. + +2003-07-17 Aubrey Jaffer <agj@alum.mit.edu> + + * manifest.scm: Shuffled functions; added examples. + + * slib.texi (Module Conventions): Clarified. Added example of ;@. + (Require): SLIB:IN-CATALOG? renamed from SLIB:FEATURE->PATH. + + * require.scm (slib:in-catalog?): Renamed from slib:feature->path. + Internal aliases defined from advertised functions. + SRFIs number over 40; test using SLIB:EVAL. + + * vet.scm (vet-slib): Improved output formatting. + Shuffled functions. + + * synclo.scm: Added ";@" export notations. + +2003-07-16 Aubrey Jaffer <agj@alum.mit.edu> + + * collect.scm: Added ";@" export notations for define-operation. + + * slib.texi (Coding Guidelines): Circular requires now handled. + (Feature): Added mention of catalog:read. + + * getopt.scm (getopt:opt): Export for getparam.scm. + + * vet.scm (top-refs<-files, requires<-file, requires<-files) + (definitions<-files, exports<-files): Added multi-file functions. + + * manifest.scm (load->path): Moved from top-refs.scm; exported. + (file->loads): Added; finds all loads. + (file->definitions): Handle define-operation. + + * Makefile (release): make pdf. + + * top-refs.scm (top-refs:expression): Handle define-syntax. + (arglist:flatten): Pulled up to top-level. + (top-refs:expression): Handle syntax-rules and syntax-case. + (top-refs:top-level): Handle define-operation. + + * solid.scm (solid-color->sRGB): Inlined logical calls. + (pi/180): Defined in terms of atan. + + * require.scm (slib:require): Provide _before_ load. + + * random.scm (random:chunk): Export for randinex.scm. + + * randinex.scm (random:uniform1): Export for random.scm. + +2003-07-15 Aubrey Jaffer <agj@alum.mit.edu> + + * top-refs.scm (top-refs:binding): Scan for all internal defines + before doing top-refs:expression. + + * uri.scm (uri:make-path): Document and export. + + * slib.texi (Coding Guidelines): Expanded and updated. + (Porting): Improved formating. + (Installation): Added @cindex. + (Module Semantics): Discuss compiling "provided?" calls. + Removed @refills. + + * README (USING SLIB): Section replaces CODING GUIDELINES. + + * alist.scm, lineio.scm: Removed @refill texinfo commands. + + * Template.scm, vscm.init, umbscheme.init, scsh.init, + pscheme.init, guile.init, STk.init, RScheme.init, t3.init, + scheme48.init, scheme2c.init, s48-0_57.init, mitscheme.init, + macscheme.init, gambit.init, elk.init, chez.init, bigloo.init, + Template.scm (rNrs): Renamed from revN-report feature. + +2003-07-15 From: Sven Hartrumpf + + * srfi-1.scm (%cars+cdrs, %cars+cdrs/no-test, %cdrs) + (any, filter, filter!, list-copy, list-index, map!) + (pair-for-each, partition, remove, remove!, span): + Adapted from the reference implementation by + + removing all check-arg calls + + expanding all uses of 'receive' + + extending 'remove' by a test to stay compatible with comlist:remove + +2003-07-14 Aubrey Jaffer <agj@alum.mit.edu> + + * glob.scm, getparam.scm: Schmoozed documentation into. + + * daylight.scm (pi pi/180): Define. + + * html4each.scm (prefix-ci?): Added. (require 'string-port). + + * http-cgi.scm (coerce->list): Fixed. Added missing requires. + + * logical.scm (logical:ones): Export. + + * mkclrnam.scm (load-rgb-txt): Removed lone printf. + + * repl.scm: Always require 'values. + + * slib.texi (Bit-Twiddling): Documented logical:ones + (Vicinity): Documented vicinity:suffix? + + * tzfile.scm: Replaced ASH with quotient. + + * uri.scm (path->uri): Needed (require 'directory). + + * top-refs.scm (vet-slib): Move to "vet.scm". + (exports<-info-index): Can do several sections per call. + (top-refs:expression): Fixed let* with internal defines. + + * vet.scm (vet-slib): Given own file. + + * color.scm (convert-color, color->string): Fixed handling of + optional whitepoint argument. + + * slib.texi (Trace): Added trackf, stackf, untrackf, unstackf. + (Getopt): Used @code{getopt--} to get correct symbol indexed. + + * top-refs.scm (vet-slib): Vets definitions and documentation + against each other -- way cool! + + * slib.texi (Spectra): Added temperature->chromaticity + + * manifest.scm (file->definitions): Added. + + * differ.scm (fp:step-check, smooth-costs): Commented out orphans. + + * dirs.scm (make-directory): Replaced sprintf with string-append. + + * slib.texi (Command Intrinsics, Table Operations) + (Database Operations): Changed to @defop. + Always bracket type-arguments to @def*s. + +2003-07-12 Aubrey Jaffer <agj@alum.mit.edu> + + * require.scm (slib:report-locations): Replace 'implementation + with type and version symbols. + +2003-07-11 Aubrey Jaffer <agj@alum.mit.edu> + + * manifest.scm (file->exports): Added BEGIN support. + + * top-refs.scm: Added; list top-level variable references. + + * Makefile (txiscms): Added hashtab.scm, chap.scm. + + * slib.texi (Hash Tables, Chapter Ordering): Moved documentation + to schmooz comments in source. + + * object.texi: Renamed from objdoc.txi; so isn't confused with + schmooz-generated file. + + * hashtab.scm: Schmoozed documentation into. + (hash-rehasher): Documented. + + * withfile.scm, trnscrpt.scm: Added ";@" export notations. + +2003-07-10 Aubrey Jaffer <agj@alum.mit.edu> + + * alist.scm, comparse.scm, chap.scm: Schmoozed documentation into. + + * slib.texi (Color Difference Metrics): Reorganized. + + * glob.scm: Added ";@" export notations. + Removed "glob:" aliases for exports. + + * rdms.scm (catalog:view-proc-pos, domains:type-param-pos) + (rdms:warn): Commented out unused definitions. + + * db2html.scm (make-defaulter): Moved near its only use. + (get-foreign-choices): Moved here and documented. + + * Makefile (txiscms): Added ratize.scm, modular.scm, comparse.scm, + alist.scm. + + * slib.texi (Array Mapping, Cyclic Checksum, Directories, Fast + Fourier Transform, Portable Image Files, Priority Queues, Queues, + Rationalize, Modular Arithmetic, Command Line, Association Lists): + Moved documentation to schmooz comments in source. + + * schmooz.scm (schmooz-fun): Use "deffn Procedure" if procedure + name ends in "!". + + * color.scm: Added ";@" export notations; removed collision-prone + aliases. + + * qp.scm (qp): Removed aliases; added ";@" export notations. + + * arraymap.scm, queue.scm, priorque.scm, pnm.scm, dirs.scm, + ratize.scm, modular.scm: Schmoozed documentation into. + + * slib.texi (Token definition): Added tok:bump-column. + + * hash.scm (hashv): Cleaned; Added ";@" export notations. + + * logical.scm, guile.init: "logical:" prefixes for internal use + only (except logical:rotate). + + * slib.texi (Time Zone): Documented tz:std-offset; used in + "psxtime.scm". + + * uri.scm (uri:path->keys): Documented; used by + command:modify-table in "db2html.scm". + + * random.scm: Commented-out unused random:random. + + * htmlform.scm (html:delimited-list): Documented; used in + command->p-specs example. + +2003-07-09 Aubrey Jaffer <agj@alum.mit.edu> + + * strsrch.scm, strport.scm, strcase.scm, scanf.scm, sc4opt.scm, + rdms.scm, printf.scm, mbe.scm, fluidlet.scm, dynwind.scm, + byte.scm: Added ";@" export notations. + + * comlist.scm: "comlist:" prefixes for internal use only. + + * srfi-1.scm (cons*, take, drop, take-right, drop-right, last, + reverse!, find, find-tail): Dropped comlist: prefixes. + + * scmacro.scm (base:load): Unused; removed. + + * scainit.scm: Put SLIB:LOADs at top-level so codewalk finds them. + + * macwork.scm (mw:every, mw:union, mw:remove-if-not): Local copies + of common-list-functions. + + * dbutil.scm (add-domain): Documented. + +2003-07-08 Aubrey Jaffer <agj@alum.mit.edu> + + * mklibcat.scm: Converted associations to proper lists. + + * require.scm (slib:require): Corrected subtle logic problems. + (catalog:resolve): Accept and convert proper lists associations. + + * recobj.scm (field:position): Private name for CL function. + + * object.scm: Added export notations: ";@". + + * factor.scm (primes-gcd?): Inlined single use of NOTEVERY. + (primes<): Renamed from prime:primes<. + +2003-07-07 Aubrey Jaffer <agj@alum.mit.edu> + + * slib.texi (Module Semantics): Added. + +2003-07-06 Aubrey Jaffer <agj@alum.mit.edu> + + * slib.texi (Catalog Creation): Added catalog:read. + + * mklibcat.scm: Use catalog:resolve. + + * require.scm (catalog:resolve, catalog:read): Added. + +2003-07-05 Aubrey Jaffer <agj@alum.mit.edu> + + * factor.scm (prime:factor, prime:primes>, prime:primes<): + eliminated orphans. + + * tree.scm: Moved documentation from slib.texi. + + * srfi-2.scm (and-let*): Guarded LET* special form. + + * Makefile (txiscms, txifiles): Added srfi-2. + +2003-07-03 Aubrey Jaffer <agj@alum.mit.edu> + + * Makefile (*files): Reorganized to eliminate duplications. + + * srfi-9.scm (define-record-type): Syntax wrapper for 'record. + + * srfi-8.scm (receive): Added. + + * schmooz.scm (def->args): Fixed for syntax-rules. + +2003-07-02 Aubrey Jaffer <agj@alum.mit.edu> + + * slib.texi (Feature): Added feature-eval. + (Require): Added require-if. + (Database Reports): Removed. + + * manifest.scm: Examples added. + + * array.scm (make-array): Alias of create-array. + + * manifest.scm: List SLIB module requires and exports; useful for + compiling. + + * Makefile (txifiles, txiscms): Added tsort. + + * slib.texi (Topological Sort): Moved docs to "tsort.scm". + + * tsort.scm: Moved documentation from slib.texi into. + + * require.scm (feature-eval): Abstracted from slib:provided? + + * cring.scm: Added export notations: ";@". + +2003-07-01 Aubrey Jaffer <agj@alum.mit.edu> + + * require.scm (slib:require-if): Added. + (slib:provided?): Accepts expressions with AND, OR, and NOT. + +2003-06-30 Aubrey Jaffer <agj@alum.mit.edu> + + * Makefile (txiscms): sed script seems not to work. + + * slib.texi (Top): Universal SLIB Procedures (was Built-in + Support) moved to Top. + (Feature Require): Fixed bad craziness. + (About this manual): Moved to "About SLIB". + + * require.scm: All "require:" prefixes changed to "slib:". + (*modules*): Removed. + +2003-06-29 Aubrey Jaffer <agj@alum.mit.edu> + + * formatst.scm, fmtdoc.txi, format.scm: Removed because not + reentrant. + + * FAQ: Added "What happened to FORMAT?" + + * Makefile (txiscms): Generated from txifiles. + + * yasyn.scm: Changed from FORMAT to PRINTF-based (pormat). + + * prec.scm (prec:trace): Removed. + + * solid.scm, solid.scm, timezone.scm, uri.scm, admin.scm, + alistab.scm, batch.scm, colorspc.scm, db2html.scm, dbutil.scm, + differ.scm, getparam.scm, html4each.scm, obj2str.scm, printf.scm, + psxtime.scm, repl.scm, transact.scm, format.scm, matfile.scm, + ncbi-dna.scm: + Added conditional top-level REQUIRE for each dynamic REQUIRE. + +2003-06-28 Aubrey Jaffer <agj@alum.mit.edu> + + * Makefile (MKNMDB): mkclrnam.scm split from colornam.scm. + + * colornam.scm (load-rgb-txt): Database creation moved to + mkclrnam.scm. + + * mkclrnam.scm (load-rgb-txt): Database creation moved from + colornam.scm. + + * priorque.scm (heap:test): Removed. + + * crc.scm (cksum-string): Moved to example in "slib.texi" (Cyclic + Checksum). + +2003-06-27 Felix Winkelmann + + * minimize.scm (golden-section-search): eqv? --> =. + + * mklibcat.scm (scanf): Is defmacro package. + +2003-06-20 Aubrey Jaffer <agj@alum.mit.edu> + + * require.scm (*SLIB-VERSION*): Bumped from 2d5 to 2d6. + * array.scm (make-array): Removed legacy procedures. + +2003-06-18 Aubrey Jaffer <agj@alum.mit.edu> + + * differ.scm (diff:order-edits): Interleave inserts and deletes + when adjacent. + +2003-06-16 Aubrey Jaffer <agj@alum.mit.edu> + + * differ.scm (diff2ebc diff2ebr): Removed; 3% not worth it. + + * logical.scm (gray-code->integer): + * pnm.scm (pnm:array-write): + * slib.texi (Yasos examples, Commutative Rings): + * subarray.scm (array-trim): error -> slib:error. + + * charplot.scm (histobins): Gracefully return when no data. + +2003-06-11 Aubrey Jaffer <agj@alum.mit.edu> + + * differ.scm (diff:mid-split): Replaces diff:best-split. + (diff2ebr): Fixed RR polarity; now works with diff:mid-split. + +2003-06-07 Aubrey Jaffer <agj@alum.mit.edu> + + * differ.scm (diff:longest-common-subsequence): Call + DIFF:ORDER-EDITS only when there are edits. + (diff:divide-and-conquer): Inlined diff->costs; allocate CC and RR + out of the same array. + +2003-06-05 Aubrey Jaffer <agj@alum.mit.edu> + + * differ.scm (diff2ebc, diff2el): Inlined insert and delete. + (diff:order-edits): take sign argument. + (diff:edits, diff:longest-common-subsequence): Handle argument + order. + (diff2ebc, diff2ebr): Handle insertions and deletes; not matches. + +2003-06-04 Aubrey Jaffer <agj@alum.mit.edu> + + * differ.scm (diff2el): Simplified by half. + (diff:order-edits): Returns; edits were almost right order. + (diff->costs): smooth-costs not needed. + (diff2ebc, diff2ebr): Moved conditional swap to diff2et. + (diff:order-edits): Figure LEN-A and LEN-B from EDITS. + (diff:best-split): Simplified using passed expected COST. + +2003-06-02 Aubrey Jaffer <agj@alum.mit.edu> + + * differ.scm (diff2el): Removed never-used LEN-B = 0 case. + (diff:divide-and-conquer): Pass cost to diff2ebr, diff2ebc. + (diff2ebc): Fixed insert order; P-LIM when B gets shorter than A. + (diff:order-edits): Removed -- edits are now generated in order. + (diff2edits): Check returned cost. + (diff2el): Handle LEN-A = P-LIM case. + +2003-06-01 Aubrey Jaffer <agj@alum.mit.edu> + + * differ.scm Reordered procedures and changed some argument names + to match paper. + (diff2e*): INSERT and DELETE replaced with EDITS, EDX, and EPO. + +2003-05-28 Aubrey Jaffer <agj@alum.mit.edu> + + * differ.scm (edits2lcs): Pass in editlen in pursuit of + schlepability. + +2003-05-26 Aubrey Jaffer <agj@alum.mit.edu> + + * soundex.scm (SOUNDEX): Character lookups use ASSV and MEMV. + + * strsrch.scm (substring?, substring-ci?): Bum simple cases. + (subskip): Split out common code from substring?, substring-ci?. + (subloop): Old non-table-driven code for short substring?s. + (substring?, substring-ci?): Compared measurements of subskip vs + subloop; set breakpoint at STRLEN < CHAR-CODE-LIMIT/2 + 2*PATLEN. + (substring-ci?, substring?): Refined; subloop for PATLEN <= 4. + +2003-05-25 Steve VanDevender + + * strsrch.scm (substring?, substring-ci?): Rewrote, improving + performance and fixing (substring-ci? "a" "An apple") ==> 3 bug. + +2003-05-24 Aubrey Jaffer <agj@alum.mit.edu> + + * differ.scm (diff:order-edits): Added; returns correct order. + +2003-05-23 Aubrey Jaffer <agj@alum.mit.edu> + + * differ.scm (edits2lcs): Removed editlen argument. + + * ncbi-dna.scm: Read and manipulate NCBI-format nucleotide + sequences. + +2003-05-12 Aubrey Jaffer <agj@alum.mit.edu> + + * differ.scm (diff2el): Handle all (zero? p-lim) cases. + +2003-05-06 Aubrey Jaffer <agj@alum.mit.edu> + + * differ.scm: Reorganized diff2* functions. Leading and trailing + runs of matches now trimmed from all edits-producing comparisons. + (smooth-costs): Correct cost jumps left by fp:compare + [which visits only a few (x,y)]. + (diff->costs): Check that each adjacent CC pair differs by +/-1. + (diff:divide-and-conquer): Disable SHAVE pending bug resolution. + (diff2ebr, diff2ebc): Split diff2eb; end-run optimization only + works for half inheriting middle insertions. + (diff:divide-and-conquer): Moved fp:check-cost into. + +2003-05-03 Aubrey Jaffer <agj@alum.mit.edu> + + * differ.scm (diff:shave): Removed cdx+1; now cdx. Keep track of + endb in insert loop. + +2003-05-01 Aubrey Jaffer <agj@alum.mit.edu> + + * differ.scm (diff:shave): Also trim matches with decreasing CC + from ends; nets 27% speed. + +2003-04-27 Aubrey Jaffer <agj@alum.mit.edu> + + * guile.init (port?): Had argument name mismatch. + +2003-04-06 Aubrey Jaffer <agj@alum.mit.edu> + + * db2html.scm (command:make-editable-table, command:modify-table): + Improved null-keys treatment to work with multiple primaries. + +2003-04-05 Aubrey Jaffer <agj@alum.mit.edu> + + * qp.scm (qp:qp): Distinguish #f and 0 values for *qp-width*. + +2003-03-30 Aubrey Jaffer <agj@alum.mit.edu> + + * differ.scm (diff:divide-and-conquer): Trim based on CC alone. + (diff:best-split): Extracted from diff:divide-and-conquer. + (diff:shave): Abstracted from diff:divide-and-conquer. + +2003-03-29 Aubrey Jaffer <agj@alum.mit.edu> + + * differ.scm (fp:compare): Use smaller fp if p-lim supplied. + +2003-03-27 Aubrey Jaffer <agj@alum.mit.edu> + + * differ.scm (diff:divide-and-conquer): Find longest optimal run. + (diff2edits): Initialize edits array to prevent type error. + (diff:divide-and-conquer): Split nearest to midpoint within + longest run. + (diff:divide-and-conquer): Split into 3 parts if consecutive + inserts are discovered in bestrun. + (diff:divide-and-conquer): No need to check both CC and RR for + linearity; tcst being constant guarantees it. + +2003-03-25 Aubrey Jaffer <agj@alum.mit.edu> + + * solid.scm (scene:viewpoint): Simplified; fixed pitch. + (solid:extract-colors): Fixed color/elevations alignment. + (solid:extract-colors, solid:extract-elevations): Fixed row-major. + +2003-03-24 Aubrey Jaffer <agj@alum.mit.edu> + + * solid.scm (solid:basrelief): Added VRML ElevationGrid. + (solid:bry): Added "solid FALSE" and missing alternative clause. + +2003-03-23 Aubrey Jaffer <agj@alum.mit.edu> + + * html4each.scm (html-for-each): Rewrote for full quote hair. + Removed require string-search; uses own multi-char version. + +2003-03-16 Aubrey Jaffer <agj@alum.mit.edu> + + * html4each.scm (html-for-each): "unterminated HTML entity" + warning infinitely looped; changed to error. + (htm-fields): Recover from HTML errors. + +2003-03-15 Aubrey Jaffer <agj@alum.mit.edu> + + * uri.scm (uri->tree, make-uri): Fixed confusion of #f and "". + + * db2html.scm (command:make-editable-table): foreign-choice-lists + now opens the table. + +2003-03-07 Aubrey Jaffer <agj@alum.mit.edu> + + * slib.texi: Fixed database examples. + + * dbutil.scm (solidify-database): Fixed lock handling. + +2003-03-02 Aubrey Jaffer <agj@alum.mit.edu> + + * fft.scm (fft:shuffle&scale): Use bit-reverse from 'logical. + + * arraymap.scm (array-for-each): Use set-car! instead of reverse. + +2003-02-17 Aubrey Jaffer <agj@alum.mit.edu> + + * slib.texi (Getopt): Fixed double dashes. + + * transact.scm (transact-file-replacement): Accept (string) path + to backup file in place of backup-style symbol. + +2003-01-27 Aubrey Jaffer <agj@alum.mit.edu> + + * phil-spc.scm (hilbert-coordinates->integer): Converted to + tail-recursive internal define. + + * slib.texi (Peano-Hilbert Space-Filling Curve): Renamed from + "Hilbert Space-Filling Curve". + + * phil-spc.scm: Renamed from "fhilbert.scm". + +2003-01-25 Aubrey Jaffer <agj@alum.mit.edu> + + * fhilbert.scm (integer->hilbert-coordinates): Made index + processing symmetrical with hilbert-coordinates->integer. + +2003-01-13 Aubrey Jaffer <agj@alum.mit.edu> + + * bigloo.init (scheme-implementation-version): *bigloo-version* + (implementation-vicinity): *default-lib-dir*/. + (library-vicinity): Check couple of places using DIRECTORY?. + +2003-01-11 Aubrey Jaffer <agj@alum.mit.edu> + + * slib.texi (Plotting): Updated examples. + +2003-01-06 Aubrey Jaffer <agj@alum.mit.edu> + + * fhilbert.scm (hilbert-coordinates->integer) + (integer->hilbert-coordinates): Reference rank now 0 (was 2). + +2003-01-05 Aubrey Jaffer <agj@alum.mit.edu> + + * fhilbert.scm (hilbert-coordinates->integer): Fixed nBits. + (integer->hilbert-coordinates): Simplified. + + * DrScheme.init (defmacro): Restore for mzscheme-202. + +2003-01-05 Ivan Shmakov <ivan@theory.dcn-asu.ru> + + * queue.scm (dequeue-all!): Added. + +2003-01-05 L.J. Buitinck <L.J.Buitinck@student.rug.nl> + + * comlist.scm (comlist:subset?): Added. + +2003-01-04 Aubrey Jaffer <agj@alum.mit.edu> + + * fhilbert.scm: Added Hilbert Space-Filling Functions. + + * logical.scm (logical:logcount, logical:integer-length): Made + tail-recursive. + (logical:logxor, logical:logior, logical:logand): Made + tail-recursive. + +2002-12-29 Aubrey Jaffer <agj@alum.mit.edu> + + * logical.scm (logical:ones): Return 0 for 0 argument. + (gray-code->integer): Improved running time from O(b^2) to + O(b*log(b)). + +2002-12-26 Aubrey Jaffer <agj@alum.mit.edu> + + * batch.scm (*operating-system*): gnu-win32 renamed from cygwin32. + + * slib.texi (String Search): State search order for string-subst. + +2002-12-25 Aubrey Jaffer <agj@alum.mit.edu> + + * html4each.scm (htm-fields): Parses markup string. + (html-for-each): Handle comments as markups. + + * strsrch.scm (count-newlines): Added. + + * comlist.scm (comlist:list*): Make letrec top-level. + +2002-12-25 "L.J. Buitinck" <L.J.Buitinck@let.rug.nl> + + * comlist.scm (comlist:union): Make letrec top-level. + +2002-12-17 Aubrey Jaffer <agj@alum.mit.edu> + + * solid.scm (scene:viewpoints): Restored Up and Down views. + + * slib.texi (Rule Types): Split from Precedence Parsing Overview. + (Precedence Parsing Overview): Describe binding power concept. + +2002-12-11 Aubrey Jaffer <agj@alum.mit.edu> + + * batch.scm (*operating-system*): Detect MINGW32 (gcc on MS-DOS) + as CYGWIN. + +2002-12-09 W. Garrett Mitchener <wmitchen@math.princeton.edu> + + * Makefile (catalogs): Make mzscheme new-catalog -g + (case-sensitive) so *SLIB-VERSION* symbol upper-cased. + +2002-12-08 L.J. Buitinck <L.J.Buitinck@let.rug.nl> + + * slib.texi (Destructive list operations): Fixed SOME example. + MAP instead of MAPCAR in nconc example. + +2002-12-06 Aubrey Jaffer <agj@alum.mit.edu> + + * random.scm (random): Streamlined. + (seed->random-state, random:chunk): Replaced BYTE with ARRAY. + +2002-12-05 Aubrey Jaffer <agj@alum.mit.edu> + + * random.scm (random): Don't get extra chunk when modu is integer + multiple of 256. + +2002-12-02 Aubrey Jaffer <agj@alum.mit.edu> + + * html4each.scm (html:read-title): Added optional LIMIT + (word-count) argument. + + * slib.texi (Getopt, Getopt Parameter lists): + * getparam.scm (getopt->arglist, getopt->parameter-list): + * getopt.scm (getopt, getopt--): Global variable *argv* replaces + argc, argv arguments. Not the best solution -- but at least its + consistent. + + * slib.texi (Lists as sets): Updated UNION examples. + + * comlist.scm (comlist:union): Optimized for list lengths. + +2002-12-01 Aubrey Jaffer <agj@alum.mit.edu> + + * html4each.scm (html:read-title): Added. + (html-for-each): Accept input-port for FILE argument. + (html:read-title): Added check for first char being '<'. + + * uri.scm (absolute-uri?): Added. + +2002-11-30 Aubrey Jaffer <agj@alum.mit.edu> + + * uri.scm (uri->tree): Corrected documentation. + + * dbutil.scm (mdbm:report): Show lock certificates. + (create-database, write-database, syncify-database, + close-database): Lock database file for writing. + (create-database): Allow initial #f filename. + + * slib.texi (Copyrights): Fixed TeX formatting. + +2002-11-29 Aubrey Jaffer <agj@alum.mit.edu> + + * DrScheme.init: Added (provide 'fluid-let). + (call-with-input-string): Corrects bug in + /usr/local/lib/plt/collects/slibinit/init.ss. + +2002-11-26 Aubrey Jaffer <jaffer@aubrey.jaffer> + + * require.scm (*SLIB-VERSION*): Bumped from 2d4 to 2d5. + +2002-11-26 dai inukai <inukai.d@jeans.ocn.ne.jp> + + * srfi-1.scm (drop-right, take-right): Were swapped. + +2002-11-26 Aubrey Jaffer <agj@alum.mit.edu> + + * DrScheme.init: Ported for VERSIONs >= "200". + + * Template.scm, vscm.init, umbscheme.init, t3.init, STk.init, + scsh.init, scheme2c.init, s48-0_57.init, RScheme.init, + macscheme.init, gambit.init, elk.init, chez.init, bigloo.init + (slib:warn): Put spaces between arguments. + + * slib.texi (Database Macros): Section added. + + * dbcom.scm (define-*commands*): Added; supports define-command. + +2002-11-26 Ivan Shmakov <ivan@theory.dcn-asu.ru> + + * scheme48.init (slib:warn): Match S48-ERROR format. + + * dbsyn.scm (within-database, define-table, define-command): + Added new file. + +2002-11-22 Aubrey Jaffer <agj@alum.mit.edu> + + * slib.texi (Portable Image Files): Added cindexes. + + * pnm.scm (pnm:read-bit-vector!): Fixed for odd width pbms. + (pnm:image-file->array): Takes optional comment string arguments. + +2002-11-21 Aubrey Jaffer <agj@alum.mit.edu> + + * Makefile (docfiles, efiles): nclients.* renamed transact.*. + + * transact.scm: Renamed from nclients.scm. + + * nclients.scm (emacs:backup-name): Added. + (transact-file-replacement): Now does backup files. + +2002-11-20 Aubrey Jaffer <agj@alum.mit.edu> + + * guile.init (define-module, eval): Condition on version. + + * slib.texi (Transactions): Replaces net-clients section. + + * vscm.init, umbscheme.init, Template.scm, t3.init, STk.init, + scsh.init, scheme48.init, scheme2c.init, s48-0_57.init, + RScheme.init, pscheme.init, macscheme.init, gambit.init, elk.init, + DrScheme.init, chez.init, bigloo.init (browse-url): Added. + + * nclients.scm (user-email-address): Split into pieces. + (transact-file-replacement): Replaces call-with-replacement-file. + +2002-11-17 Aubrey Jaffer <agj@alum.mit.edu> + + * uri.scm (path->uri, absolute-path?, null-directory?) + (glob-pattern?, parse-ftp-address): Moved from nclients.scm. + + * dirs.scm (current-directory, make-directory): Moved from + nclients.scm. + +2002-11-15 Aubrey Jaffer <agj@alum.mit.edu> + + * dirs.scm: Added. + +2002-11-11 Aubrey Jaffer <agj@alum.mit.edu> + + * slib.texi (Space-Filling Curves): Section added. + (Bit-Twiddling): Added logical:rotate. + + * logical.scm (logical:rotate): Added. + (logical:ones): Added so correct with limited-precision integers. + +2002-11-03 Aubrey Jaffer <agj@alum.mit.edu> + + * nclients.scm (file-lock-owner): Also check emacs-lock. + (word-lock:certificate): Name3 missing also triggered length + error. + + * db2html.scm (crc:hash-obj): Added. + + * slib.texi (Cyclic Checksum): Rewritten. + + * Makefile (slib$(VERSION).info): Ignore makeinfo-4.1 bailing on + colons in names. + + * crc.scm: Replaces makcrc.scm. + +2002-10-27 Aubrey Jaffer <agj@alum.mit.edu> + + * solid.scm (scene:viewpoint): Corrected translation/rotation + order. + +2002-10-14 Aubrey Jaffer <agj@alum.mit.edu> + + * DrScheme.init: Corrected mis-attribution + +2002-10-09 Aubrey Jaffer <ajaffer@r3logic.com> + + * pnm.scm (pnm:read-bit-vector!): Read pbm-raw correctly. + +2002-09-24 Aubrey Jaffer <ajaffer@r3logic.com> + + * pnm.scm (pnm:image-file->array): Correctly handle array type + when max-pixval > 256. + +2002-08-17 Aubrey Jaffer <agj@alum.mit.edu> + + * dbcom.scm (make-command-server): Handle lacking domain-checkers. + +2002-08-14 Aubrey Jaffer <agj@alum.mit.edu> + + * makcrc.scm (make-port-crc): Default based on number-size of + implementation. + +2002-07-22 Aubrey Jaffer <agj@alum.mit.edu> + + * differ.scm (diff:divide-and-conquer): Limit p-lim of sub-diffs + to those computed at mid-a, mid-b. + +2002-07-19 Aubrey Jaffer <agj@alum.mit.edu> + + * differ.scm (diff:divide-and-conquer): Rewrote edit-sequence and + longest common subsequence generation. + +2002-06-28 Aubrey Jaffer <agj@alum.mit.edu> + + * array.scm (create-array): Fixed scales calculation. + +2002-06-23 Aubrey Jaffer <agj@alum.mit.edu> + + * modular.scm (modular:normalize): Test (provided? 'bignum) once. + +2002-06-18 Aubrey Jaffer <agj@alum.mit.edu> + + * differ.scm (fp->lcs): Use argument array type for returned + array. + +2002-06-17 Aubrey Jaffer <agj@alum.mit.edu> + + * slib.texi (Parsing HTML): Added. + +2002-06-09 Aubrey Jaffer <agj@alum.mit.edu> + + * html4each.scm: HTML scan calls procedures for word, tag, + whitespac, and newline. + +2002-05-31 Aubrey Jaffer <agj@alum.mit.edu> + + * nclients.scm (file=?): Added. + +2002-05-30 Aubrey Jaffer <agj@alum.mit.edu> + + * chez.init (*features*): random is not. + +2002-05-28 Aubrey Jaffer <agj@alum.mit.edu> + + * slib.texi (net-clients): Updated. + + * nclients.scm (file-lock-owner, file-lock!, file-unlock!, + system->line): Added. + +2002-05-27 Aubrey Jaffer <agj@alum.mit.edu> + + * nclients.scm (call-with-replacement-file): Added emacs-aware + procedure to read-modify-write file. + + * slib.texi (Vicinity): Clarified make-vicinity. + +2002-05-18 Aubrey Jaffer <agj@alum.mit.edu> + + * slib.texi (Command Example): Corrected. + + * cvs.scm (cvs-repository): Added. + (cvs-set-root!, cvs-vet): Rewritten to handle absolute paths in + CVS/Repository files. + +2002-05-16 Aubrey Jaffer <agj@alum.mit.edu> + + * cvs.scm (cvs:vet): Added CVS structure checker. + +2002-05-09 Aubrey Jaffer <agj@alum.mit.edu> + + * differ.scm (diff:edits): Return array of signed integers. + Broke functions into schlepable chunks; reorganized functions. + +2002-05-08 Aubrey Jaffer <agj@alum.mit.edu> + + * differ.scm (diff:make-differ): Abstracted operations. + +2002-05-06 Aubrey Jaffer <agj@alum.mit.edu> + + * differ.scm (fp->edits): Was forgetting some first deletes. + + * differ.scm (fp->edits): Fixed off-by-one; last delete was lost. + (diff:edit-length): Array fp was uninitialized. + +2002-05-02 Aubrey Jaffer <agj@alum.mit.edu> + + * cvs.scm (cvs-directories, cvs-root, cvs-set-root!): Added. + + * require.scm (pathname->vicinity): Removed "Go up one level if + PATHNAME ends in a vicinity suffix" behavior. + +2002-04-28 Aubrey Jaffer <agj@alum.mit.edu> + + * htmlform.scm (html:head): Use second argument (backlink) + verbatim if it contains <H1>. + +2002-04-26 Aubrey Jaffer <agj@alum.mit.edu> + + * require.scm (pathname->vicinity): Added. + + * slib.texi (Vicinity): Added pathname->vicinity. + +2002-04-24 Aubrey Jaffer <agj@alum.mit.edu> + + * db2html.scm (db->html-files): Fixed for #f argument DIR. + +2002-04-21 Aubrey Jaffer <agj@alum.mit.edu> + + * mitscheme.init (sort!): Accepts only vectors; set it to SORT. + +2002-04-18 Aubrey Jaffer <agj@alum.mit.edu> + + * http-cgi.scm (make-query-alist-command-server): Don't assume + query-alist is non-false. + +2002-04-18 Chris Hanson <cph@zurich.ai.mit.edu> + + * mitscheme.init (char-code-limit, defmacro, *features*): + Corrected. + +2002-04-17 Aubrey Jaffer <agj@alum.mit.edu> + + * require.scm (software-type): Removed vestigal conversion from + msdos -> ms-dos. + +2002-04-17 Chris Hanson <cph@zurich.ai.mit.edu> + + * mitscheme.init: Updated for versions 7.5 .. 7.7. + +2002-04-14 Aubrey Jaffer <jaffer@aubrey.jaffer> + + * require.scm (*SLIB-VERSION*): Bumped from 2d3 to 2d4. + + * slib.texi (CVS): Added. + + * batch.scm (*operating-system*): Renamed from *current-platform*. + +2002-04-11 Aubrey Jaffer <agj@alum.mit.edu> + + * batch.scm (batch:operating-system): Added. + (batch:write-header-comment): Take parms argument. + (batch:call-with-output-script): Corrected platform. + +2002-04-07 Aubrey Jaffer <agj@alum.mit.edu> + + * Makefile (efiles): Added cvs.scm. + + * mklibcat.scm (cvs): Added for cvs.scm. + + * htmlform.scm (html:select, form:delimited): Added newlines. + + * batch.scm (batch:platform): Handles cygwin unames. + (batch:call-with-output-script): /bin/rc is PLAN9 shell. + + * cvs.scm: Functions to enumerate files under CVS control. + +2002-04-03 Aubrey Jaffer <agj@alum.mit.edu> + + * batch.scm (operating-system): Added plan9. + +2002-03-31 Aubrey Jaffer <agj@alum.mit.edu> + + * colorspc.scm (spectrum->chromaticity, + temperature->chromaticity): Added. + +2002-03-30 Aubrey Jaffer <agj@alum.mit.edu> + + * require.scm (sub-vicinity): Support for PLAN9. + + * nclients.scm (user-email-address, current-directory): PLAN9. + +2002-03-29 Aubrey Jaffer <agj@alum.mit.edu> + + * slib.texi (Color Names, The Short List): Saturate replaces + hollasch. + + * mklibcat.scm: Saturate color dictionary replaces hollasch. + + * colornam.scm (load-rgb-txt): parses saturate dictionary. + (make-slib-color-name-db): Saturate dictionary replaces hollasch. + + * saturate.txt: Saturated colors from "Approximate Colors on CIE + Chromaticity Diagram" + + * resenecolours.txt: "dictionary", not "software". + +2002-03-20 Aubrey Jaffer <agj@alum.mit.edu> + + * comlist.scm (comlist:list-of??): Replaced calls to EVERY with + calls to COMLIST:EVERY. + + * slib.texi (Spectra): Added new functions and constants. + + * colorspc.scm (CIEXYZ:A, CIEXYZ:B, CIEXYZ:C, CIEXYZ:E): Added. + (CIEXYZ:D65): Derive from e-sRGB so (color->e-srgb 16 d65) works. + (chromaticity->whitepoint): Added. + (chromaticity->CIEXYZ): Normalize to 1=x+y+z. + (wavelength->chromaticity, wavelength->CIEXYZ): Added. + +2002-03-16 Aubrey Jaffer <agj@alum.mit.edu> + + * Makefile (docfiles): Added recent schmooz-generated files. + +2002-03-11 Aubrey Jaffer <agj@alum.mit.edu> + + * slib.texi (Color Names): Added resenecolours.txt license. + + * Makefile (catalogs): Added scripts for 5 implementations. + (clrnamdb.scm): Tries up to 5 implementations. + + * mklibcat.scm (catpath): Delete slibcat if exists. + + * slib.spec (%post): Improved catalog-building scripts. + Make clrnamdb.scm. + + * Makefile (gfiles): Added resenecolours.txt. + (clrnamdb.scm): Depends on colornam.scm. + + * colornam.scm (load-rgb-txt): Added m4c to read resenecolours.txt + without "Resene " prefix. + + * resenecolours.txt: Removed "Resene " prefix. + +2002-03-11 Karen Warman <Karen.Warman@rpl.co.nz> + + * resenecolours.txt: (Citrine White): Supplied missing value. + (Copyright): Accepted license change to allow modifications. + +2002-03-01 Aubrey Jaffer <agj@alum.mit.edu> + + * db2html.scm (command:make-editable-table): require + database-commands. + + * colornam.scm (load-rgb-txt): Made method names be symbols. + +2002-02-26 Aubrey Jaffer <agj@alum.mit.edu> + + * slib.texi (Lists as sets): Corrected description of MEMBER-IF. + Improved example. + +2002-02-23 Bill Wood <wtw@mathstar.com> + + * format.scm (Iteration Directive): Modified iteration directive + code to respect configuration variables format:iteration-bounded + and format:max-iterations. + (Configuration Variables): Added format:iteration-bounded, + default #t, and format:max-iterations, default 100. + + * fmtdoc.txi: Added documentation of changes and additions. + +2002-02-20 Aubrey Jaffer <agj@alum.mit.edu> + + * slib.texi (Color): Added tags for Color nodes. + + * guile.init (expt): Fixed (expt 2 -1). + (port?, call-with-open-ports): Added. + +2002-02-18 Aubrey Jaffer <agj@alum.mit.edu> + + * slib.texi (Motivations): Removed to DBManifesto.html. + + * bigloo.init, chez.init, elk.init, mitscheme.init, RScheme.init, + scheme2c.init, scheme48.init, scsh.init, STk.init, Template.scm, + vscm.init (home-vicinity): ELSE clause was missing. + + * guile.init (home-vicinity): Case-sensitive case was hosing. + +2002-02-14 Aubrey Jaffer <agj@alum.mit.edu> + + * scheme48.init: (asin) is totally busted in Scheme-48-0.45. + + * colorspc.scm (pi): Added. + (multiarg/and-): Required. + Scheme-48-0.45 chokes on 1e1. + + * daylight.scm: Scheme-48-0.45 chokes on 1e1. + Quoted vectors. + + * solid.scm: Scheme-48-0.45 chokes on 1e1. + + * slib.texi (multiarg/and-): Fixed typo. + +2002-02-11 Aubrey Jaffer <jaffer@aubrey.jaffer> + + * require.scm (*SLIB-VERSION*): Bumped from 2d2 to 2d3. + + * batch.scm (batch:write-header-comment): Include batch:platform + in message. + +2002-01-31 Aubrey Jaffer <agj@alum.mit.edu> + + * guile.init (create-array, Ac64, Ac32, Ar64, Ar32, As64, As32, + As16, As8, Au64, Au32, Au16, Au8, At1): Added new SLIB arrays. + + * charplot.scm, differ.scm, pnm.scm, fft.scm: Changed to use + create-array. + + * arraymap.scm (array-indexes): + * matfile.scm (matfile:read-matrix): Changed to use create-array. + + * array.scm: (Ac64, Ac32, Ar64, Ar32, As64, As32, As16, As8, + Au64, Au32, Au16, Au8, At1): Added prototype makers. + + * pnm.scm (pnm:image-file->uniform-array): Removed. + (pnm:array-write): Changed away from using *-uniform-*. + +2002-01-28 Aubrey Jaffer <agj@alum.mit.edu> + + * array.scm (create-array): 1-element fill only. + +2002-01-26 Aubrey Jaffer <agj@alum.mit.edu> + + * subarray.scm (subarray0, array-align): Added. + + * slib.texi (Input/Output): Added call-with-open-ports, port? + (Installation): How to make color-name database. + (Byte): Added note about opening binary files. + + * matfile.scm (matfile:read): + * tzfile.scm (tzfile:read): + * pnm.scm (pnm:type-dimensions, pnm:image-file->array): + (pnm:array-write): Converted to use CALL-WITH-OPEN-PORTS and + OPEN-FILE for binary files. + + * *.init, Template.scm (call-with-open-ports, port?): Added. + + * slib.texi (Color Names): Added Resene and Hollasch dictionaries. + + * Makefile (clrnamdb.scm): Make using most portable method; "<". + + * mklibcat.scm (hollasch, resene): Added color-name-dictionary + features. + + * require.scm (require:require): Use feature name for + color-dictionary define. + + * colornam.scm (make-slib-color-name-db): Added. + + * dbutil.scm (open-database!): OK if database is already open for + writing. + +2002-01-25 Aubrey Jaffer <agj@alum.mit.edu> + + * slib.texi (Input/Output): Open-file MODES argument now symbol. + + * Template.scm, *.init (open-file): Modes argument now symbol. + +2002-01-23 Radey Shouman <Shouman@ne.mediaone.net> + + * subarray.scm (subarray): Trailing indices can now be elided, as + in the rautil.scm version. + +2002-01-22 Aubrey Jaffer <agj@alum.mit.edu> + + * slib.texi (Input/Output): Changed procedures returning values to + @defun. + + * mklibcat.scm (display*): Added to reduce code size. + + * dbutil.scm (make-exchanger): Removed; now in *.init files. + + * slib.texi (Miscellany): Renamed from Legacy. + Added make-exchanger, open-file, and close-port. + + * guile.init (make-exchanger): Added. + + * STk.init, vscm.init, umbscheme.init, t3.init, scsh.init, + scheme48.init, scheme2c.init, s48-0_57.init, pscheme.init, + mitscheme.init, macscheme.init, gambit.init, elk.init, chez.init, + bigloo.init, Template.scm, RScheme.init, DrScheme.init + (make-exchanger, open-file, close-port): Added. + +2002-01-21 Aubrey Jaffer <agj@alum.mit.edu> + + * solid.scm (direction->vrml-field): Corrected angle errors due to + having only one buggy viewer. + (scene:sun): FreeWRL-0.30 sun disappears even closer than lookat. + +2002-01-19 Aubrey Jaffer <agj@alum.mit.edu> + + * slib.texi (Relational Database): Reorganized. + Feature `database-utilities' renamed `databases'. + + * dbutil.scm (close-database, write-database, open-database, + open-database!, create-database): Changed errors to warnings. + Added (schmooz) documentation. + + * slib.texi (Base Table): Added introduction. Listed alist-table + and wb-table features. + (Database Utilities): Moved documentation to "dbutil.scm". + + * dbutil.scm (mdbm:report): Added. + (open-database!, open-database, write-database, sync-database, + solidify-database, close-database): will accept database or + filename. + Rewrote using dynamic-wind to protect mdbm:*databases*. + + * rdms.scm (close-database): Fixed return value. + (write-database, sync-database): Made conditional on MUTABLE. + (solidify-database): Added method to change mutable to unmutable. + +2002-01-18 Radey Shouman <shouman@ne.mediaone.net> + + * pnm.scm: Fixed pbm read for the case when 0 and 1 characters are + not separated by whitespace (Ghostscript does this). + +2002-01-17 Aubrey Jaffer <agj@alum.mit.edu> + + * slib.texi (Database Utilities): Updated dbutil changes. + + * dbutil.scm (close-database, sync-database, write-database): Added. + (create-database, open-database!, open-database): Rewritten to + support database sharing. + +2002-01-13 Aubrey Jaffer <agj@alum.mit.edu> + + * rdms.scm (filename): Added database method for retrieving. + + * scsh.init, chez.init, bigloo.init, scheme2c.init + (scheme-implementation-home-page): Updated. + +2002-01-10 Aubrey Jaffer <agj@alum.mit.edu> + + * Makefile (clrnamdb.scm): Added target to build resene + color-dictionary. + + * require.scm (require:require): Added color-names loader. + + * colornam.scm (load-dictionary, make-slib-color-db): Added. + +2002-01-08 Aubrey Jaffer <agj@alum.mit.edu> + + * determ.scm (matrix:inverse, matrix:product, transpose, + matrix->array, matrix->lists): Added. + + * slib.texi (Matrix Algebra): Renamed from Determinant. + Schmooz documentation from determ.scm. + + * array.scm (create-array): Default to vector for non-array + prototypes. + +2002-01-07 Aubrey Jaffer <agj@alum.mit.edu> + + * colornam.scm (load-rgb-txt): Allows multiple names per color. + Added support for multi-lingual "color_names.txt". + +2002-01-06 Aubrey Jaffer <agj@alum.mit.edu> + + * colorspc.scm (e-sRGB-log, e-sRGB-exp): Abstracted and corrected. + (CIEXYZ:D65, CIEXYZ:D50): Compute from CIE chromaticities. + (e-sRGB:from-matrix): + http://www.pima.net/standards/it10/PIMA7667/PIMA7667-2001.PDF + gives matrix identical to sRGB:from-matrix, but colors drift under + repeated conversions to and from CIEXYZ. Instead use computed + inverse of e-sRGB:into-matrix. + +2002-01-05 Aubrey Jaffer <agj@alum.mit.edu> + + * colorspc.scm (CIE:Y/Yn->L*, CIE:L*->Y/Yn): Abstracted CIE + luminance <-> lightness conversions. + (ab-log, ab-exp): Abstracted a*, b* nonlinearities. + (L*u*v*->CIEXYZ): Simplified. + + * slib.texi (Spectra): Features cie1964, cie1931, and ciexyz. + + * colorspc.scm (spectrum->XYZ, wavelength->XYZ): Require 'ciexyz. + + * mklibcat.scm (cie1964, cie1931, spectral-tristimulus-values): + Added. + + * require.scm (require:require): Added spectral-tristimulus-values + loader. + + * cie1964.xyz: Added. + +2002-01-03 Aubrey Jaffer <agj@alum.mit.edu> + + * slib.texi (MAT-File Format): Added node. + + * matfile.scm (matfile:read-matrix): Dispatch per binary format; + only IEEE currently. + Added schmooz documentation. + +2002-01-01 Aubrey Jaffer <agj@alum.mit.edu> + + * subarray.scm (subarray, array-trim): Added easier ways to make + subarrays. + + * array.scm (array=?): Fixed example. + + * charplot.scm (charplot:data->lists): Fixed for 1-dimensional + array. + + * matfile.scm (bytes->double): Corrected mantissa scale. + +2001-12-21 Aubrey Jaffer <agj@alum.mit.edu> + + * matfile.scm: Added; reads MAT-File Format version 4 (MATLAB). + +2001-12-13 Aubrey Jaffer <agj@alum.mit.edu> + + * scainit.scm (syncase:sanity-check): Had too many ".scm" suffi. + +2001-12-12 Aubrey Jaffer <agj@alum.mit.edu> + + * solid.scm (scene:sphere): Major rewrite. Now works, I think. + + * daylight.scm (sunlight-spectrum): Added and debugged calculation + from http://www.cs.utah.edu/vissim/papers/sunsky/sunsky.pdf. + + * colorspc.scm (xyY:normalize-colors): Added optional argument to + control luminence scaling. + +2001-12-11 Ivan Shmakov <ivan@theory.dcn-asu.ru> + + * s48-0_57.init (system): Removed code that set! system to #f. + +2001-12-09 Aubrey Jaffer <agj@alum.mit.edu> + + * solid.scm (light:ambient, light:directional, light:dispersion, + light:point, light:spot): Added light sources. + + * slib.texi (Plotting): Updated documentation. + +2001-12-08 Aubrey Jaffer <agj@alum.mit.edu> + + * charplot.scm: Major cleanup; raster conversion replaced by array + of chars; y coordinate lists rendered with distinct characters. + (coordinate-extrema): Added; computes extrema for lists of + coordinates of any rank. + (histograph): Added. + +2001-12-05 Aubrey Jaffer <agj@alum.mit.edu> + + * Makefile ($(dvidir)slib.dvi): Depend on Schmoozed files. + +2001-12-04 Aubrey Jaffer <agj@alum.mit.edu> + + * charplot.scm (charplot:plot!): Accept lists for second + coordinates; plot all against first coordinates. + + * colornam.scm (file->color-dictionary): Added format for data + from Resene spreadsheetd. + + * colorspc.scm (xyY:normalize-colors): Added. + + * daylight.scm: Added mathematical model of sky colors. + +2001-12-01 Aubrey Jaffer <agj@alum.mit.edu> + + * logical.scm (logical:integer-expt): Merged + logical:ipow-by-squaring into. + + * modular.scm (mod, rem): Added Common-Lisp functions. + (modular:r, modular:expt): Removed dependence on logical package. + +2001-11-29 Aubrey Jaffer <agj@alum.mit.edu> + + * solid.scm (solid:pyramid): Added. + +2001-11-28 Aubrey Jaffer <agj@alum.mit.edu> + + * solid.scm (scene:panorama, scene:sphere): Added backgrounds. + (solid:cylinder, solid:disk, solid:cone): Added. + (solid:arrow): Rewritten in terms of solid primitives. + +2001-11-25 Aubrey Jaffer <agj@alum.mit.edu> + + * solid.scm (solid:texture): Added. + (vrml-append): Added; puts newlines between strings. + + * colorspc.scm (chromaticity->CIEXYZ, spectrum->CIEXYZ, + temperature->CIEXYZ): Added; useful for making whitepoints. + +2001-11-24 Aubrey Jaffer <agj@alum.mit.edu> + + * slib.texi (Database Utilities): Added description of + *base-table-implementations*. + + * colornam.scm (load-rgb-txt): Added many data formats. Internal + function parse-rgb-line clobbers itself with method the first time + a method works. + + * colorspc.scm (spectrum->xyz): Now accepts vector (or list) and + bounds. Now compensates for number of samples. + (blackbody-spectrum): Made public. Takes optional SPAN argument. + (XYZ->xyY, xyY->XYZ): Corrected; it really is just Y. + (CIE:L*): Y->L* conversion abstracted into function. + +2001-11-23 Aubrey Jaffer <agj@alum.mit.edu> + + * charplot.scm (charplot:iplot!): Fixed 9-year old fencepost bug. + (charplot:iplot!): Coordinates standardized to lists, rather than + pairs. PLOT will accept either. + (plot): Dispatches to plot! or plot-function!. + (plot-function): Added alias for plot. + +2001-11-17 Aubrey Jaffer <agj@alum.mit.edu> + + * colornam.scm (load-rgb-txt): Added "order" index field. + + * scsh.init, scheme48.init, scheme2c.init, mitscheme.init, + guile.init, elk.init, chez.init, bigloo.init, Template.scm, + STk.init, s48-0_57.init (home-vicinity): + Now assures trailing "/". + + * colornam.scm (grey): Added X11 numbered greys. + +2001-11-17 Ivan Shmakov <ivan@theory.dcn-asu.ru> + + * scsh.init, scheme48.init, scheme2c.init, mitscheme.init, + guile.init, elk.init, chez.init, bigloo.init, Template.scm, + STk.init, s48-0_57.init (home-vicinity): + (getenv "HOME") Was evaluated at compile time, thus returning the + installer's home directory! Instead, call when HOME-VICINITY is + called. + + * dbcom.scm (add-command-tables): The argument of set-car! + function must be mutable, but (quote xxx) isn't in Scheme48. + +2001-11-16 Aubrey Jaffer <agj@alum.mit.edu> + + * colornam.scm: Rewritten. + + * slib.texi (Color Names): Moved to end of color section. + + * alistab.scm (open-base): Check that first line starts with ";;". + +2001-11-15 Aubrey Jaffer <agj@alum.mit.edu> + + * colornam.scm: Added. + + * slib.texi (Database Utilities): Reorganized. + (Color Names): Added. + + * alistab.scm: Put *SLIB-VERSION* in header. Set + *base-table-implementations*. + + * dbcom.scm: Split rdb command extensions from dbutil.scm. + (wrap-command-interface, add-command-tables): Added + + * require.scm (*base-table-implementations*): Added. + + * dbutil.scm (open-database!, open-database): Use + *base-table-implementations* to dispatch on db-file type. + +2001-11-11 Aubrey Jaffer <agj@alum.mit.edu> + + * slib.texi (Bit-Twiddling): Added "Bit order and Lamination". + (Bit-Twiddling): Added "Gray code". + + * logical.scm (bit-reverse integer->list list->integer + booleans->integer bitwise:laminate bitwise:delaminate): Added bit + order and lamination functions. + + (integer->gray-code gray-code->integer gray-code<? gray-code<=? + gray-code>? gray-code>=?): Added Gray code functions. + +2001-11-07 Aubrey Jaffer <agj@alum.mit.edu> + + * colorspc.scm (xRGB): Renamed from sRGBi. + + * color.scm (CIEXYZ->color, RGB709->color, L*a*b*->color, + L*u*v*->color, L*C*h->color, sRGB->color, xRGB->color, + e-sRGB->color): Added. + + * slib.texi: Fixed comparison function documentation. + +2001-11-04 Aubrey Jaffer <agj@alum.mit.edu> + + * color.scm (color->string, string->color): Added. + (color:L*u*v*, color:L*a*b*, color:L*C*h): White-point must be + XYZ. + + * colorspc.scm (L*C*h->L*a*b*): Fixed angle polarity. + +2001-11-03 Aubrey Jaffer <agj@alum.mit.edu> + + * color.scm (color:white-point): Return default if no parameter. + + * colorspc.scm (temperature->xyz): Optimized. + + * solid.scm (solid:color): Hooked to use SLIB color data-type. + + * slib.texi (Spectra): Replaced "White Point". Groups procedures + for spectrum conversions. + + * colorspc.scm (temperature->xyz, XYZ:normalize-colors): Added. + +2001-11-02 Aubrey Jaffer <agj@alum.mit.edu> + + * colorspc.scm (XYZ->xyY, xyY->XYZ): Added. + +2001-11-01 Aubrey Jaffer <agj@alum.mit.edu> + + * colorspc.scm (XYZ->chromaticity): Added. + (wavelength->xyz): Added. + +2001-10-31 Aubrey Jaffer <agj@alum.mit.edu> + + * color.scm (color->L*C*h): Added. + (color->L*u*v*, color->L*a*b*): Fixed white-point arguments. + (color:RGB709, color:CIEXYZ): Relaxed bounds 0.001. + (color:white-point): Depends on color:encoding. + + * colorspc.scm (L*a*b*->L*C*h): Normalize angle positive. + +2001-10-21 Aubrey Jaffer <agj@alum.mit.edu> + + * getparam.scm (getopt-barf): Replace calls to slib:warn with + lines written to current-error-port; to dovetail better with the + call to parameter-list->getopt-usage immediately after. + +2001-10-14 Aubrey Jaffer <agj@alum.mit.edu> + + * nclients.scm (ftp-upload): Removed (to docupage). + + * prec.scm (tok:bump-column, prec:parse): Fluid-let prec:token + whenever *prec:port* is. + +2001-10-11 Aubrey Jaffer <agj@alum.mit.edu> + + * cie1931.xyz: Added. + + * color.scm: Reorganized documentation. + + * colorspc.scm (read-ciexyz!, spectrum->xyz): Added. + +2001-10-09 Mikael Djurfeldt <mdj@mdj.nada.kth.se> + + * guile.init (guile:wrap-case-insensitive): Simplified. + +2001-10-07 Aubrey Jaffer <agj@alum.mit.edu> + + * color.scm: Color data type supporting CIEXYZ, RGB709, sRGB, + e-sRGB, L*a*b*, L*u*v*, and L*C*h. + Added smooze documentation. + (color-white-point): Fixed wrapping. + + * colorspc.scm (CMC:DE): CMC:DE is designed only for small + color-differences. But try to do something reasonable for large + differences. Use bisector (h*) of the hue angles if separated by + less than 90.o; otherwise, pick h of the color with larger C*. + (e-sRGB:into-matrix): Fixed missing '-'. + Moved error checking to "color.scm". + +2001-10-06 Aubrey Jaffer <agj@alum.mit.edu> + + * colorspc.scm (CIE:DE, CIE:DE*94, CMC:DE): Added color difference + metrics. + + * slib.texi (Color Spaces): Section added. + + * colorspc.scm (e-sRGB->e-sRGB): Added. + (CIE:DE, CIE:DE*94): Color difference functions added. + Input range checking added to most functions. + +2001-09-25 Aubrey Jaffer <agj@alum.mit.edu> + + * strsrch.scm (string-index, string-index-ci, + string-reverse-index, string-reverse-index-ci): Optimized. + +2001-09-23 Aubrey Jaffer <agj@alum.mit.edu> + + * guile.init: Replaces guile/ice-9/slib.scm. + (array-indexes, array-copy!, copy-bit, bit-field, copy-bit-field): + Added missing procedures. + (slib:load, read): Wrapped with guile:wrap-case-insensitive; + fixes symbol-case problems. + + * logical.scm (bitwise-if): Was missing. + + * array.scm (create-array): Added function allowing transparent + support for uniform-arrays. + (make-array): Defined in terms of create-array. + +2001-09-22 Aubrey Jaffer <agj@alum.mit.edu> + + * array.scm (array-shape): Fixed confusion with array:shape. + +2001-09-12 Aubrey Jaffer <agj@alum.mit.edu> + + * slib.texi (Color Spaces): Documentation for colorspc.scm. + + * tek41.scm, tek40.scm: Removed very old modules not in catalog. + +2001-09-11 Aubrey Jaffer <agj@alum.mit.edu> + + * strcase.scm (StudlyCapsExpand): Added. + +2001-09-09 Aubrey Jaffer <agj@alum.mit.edu> + + * colorspc.scm: Added -- CIE, sRGB, e-sRGB color-space transforms. + + * solid.scm (solid:rotation): Added. + +2001-09-06 Aubrey Jaffer <agj@alum.mit.edu> + + * solid.scm (solid:sphere, solid:spheroid, solid:center-row-of, + solid:center-array-of, solid:center-pile-of): Added. + +2001-09-05 Aubrey Jaffer <agj@alum.mit.edu> + + * solid.scm (solid:color, solid:scale, solid:box): Generalized and + documented. + +2001-09-04 Aubrey Jaffer <agj@alum.mit.edu> + + * solid.scm: Added VRML97 solid-modeling package. + + * pnm.scm, nclients.scm, htmlform.scm: Use \\n (not \n) for + #\newline in printf strings. + +2001-09-01 Aubrey Jaffer <agj@alum.mit.edu> + + * slib.texi (RnRS): Added subsection. + + * null.scm: Added. + + * Makefile (revfiles): Added "null.scm" + + * mklibcat.scm: Added support for AGGREGATE. + (r2rs, r3rs, r4rs, r5rs): Added aggregate features. + + * require.scm (require:require): Added AGGREGATE *catalog* format. + + * slib.texi (Library Catalogs): Added AGGREGATE *catalog* format. + Fri Jul 27 19:54:00 EDT 2001 Aubrey Jaffer <jaffer@aubrey.jaffer> * require.scm (*SLIB-VERSION*): Bumped from 2d1 to 2d2. @@ -692,7 +2755,7 @@ Sun Sep 12 22:45:01 EDT 1999 Aubrey Jaffer <jaffer@ai.mit.edu> 1999-06-05 Radey Shouman <Radey_Shouman@splashtech.com> - * glob.scm (glob:substitute??): (glob:substitute-ci??): Now accept + * glob.scm (glob:substitute??, glob:substitute-ci??): Now accept a procedure or string as template argument, for more general transformations. @@ -793,7 +2856,7 @@ Sun Sep 12 22:45:01 EDT 1999 Aubrey Jaffer <jaffer@ai.mit.edu> 1999-02-25 Radey Shouman <Radey_Shouman@splashtech.com> * printf.scm (stdio:iprintf): Fixed bug in %f format, - (printf "%.1f" 0.001) printed "0", now prints "0.0" + (printf "%.1f" 0.001) printed "0", now prints "0.0" 1999-02-12 Hakan L. Younes <d93-hyo@nada.kth.se> @@ -913,7 +2976,7 @@ Sun Jan 17 12:33:31 EST 1999 Aubrey Jaffer <jaffer@ai.mit.edu> * glob.scm (glob:make-substituter): Made to handle cases where PATTERN and TEMPLATE have different numbers of literal sections. - * glob.scm (glob:pattern->tokens): (glob:make-matcher): + * glob.scm (glob:pattern->tokens, glob:make-matcher): (glob:make-substituter): Fixed to accept null strings as literals to match, for REPLACE-SUFFIX. There is no way to write a glob pattern that produces such a token, should there be? @@ -1672,7 +3735,7 @@ Wed Aug 21 20:38:26 1996 Aubrey Jaffer <jaffer@jacal.bertronics> Fri Jul 19 11:24:45 1996 Aubrey Jaffer <jaffer@jacal.bertronics> * structure.scm scaoutp.scm scamacr.scm scainit.scm scaglob.scm - scaexpp.scm: Added missing copyright notice and terms. + scaexpp.scm: Added missing copyright notice and terms. Thu Jul 18 17:37:14 1996 Aubrey Jaffer <jaffer@jacal.bertronics> @@ -1929,7 +3992,7 @@ Mon Jan 2 10:26:45 1995 Aubrey Jaffer (jaffer@jacal) * comlist.scm (comlist:atom?): renamed from comlist:atom. - * scheme48.init (char->integer integer->char): Now use integers in + * scheme48.init (char->integer integer->char): Now use integers in the range 0 to 255. Fixed several other problems. (modulo): Worked around negative modulo bug. @@ -1949,8 +4012,8 @@ Mon Jan 2 10:26:45 1995 Aubrey Jaffer (jaffer@jacal) Thu Dec 22 13:28:16 1994 Aubrey Jaffer (jaffer@jacal) * dbutil.scm (open-database! open-database create-database): This - enhancement wraps a utility layer on `relational-database' which - provides: + enhancement wraps a utility layer on `relational-database' which + provides: * Automatic loading of the appropriate base-table package when opening a database. * Automatic execution of initialization commands stored in @@ -2245,7 +4308,7 @@ Thu Feb 17 01:19:47 1994 Aubrey Jaffer (jaffer@jacal) Wed Feb 16 12:44:34 1994 Aubrey Jaffer (jaffer@jacal) From: dorai@cs.rice.edu (Dorai Sitaram) - * mbe.scm: Macro by Example define-syntax using defmacro. + * mbe.scm: Macro by Example define-syntax using defmacro. Tue Feb 15 17:18:56 1994 Aubrey Jaffer (jaffer@jacal) diff --git a/DrScheme.init b/DrScheme.init index 0676250..9942897 100644 --- a/DrScheme.init +++ b/DrScheme.init @@ -1,6 +1,59 @@ ;;;"DrScheme.init" Initialization for SLIB for DrScheme -*-scheme-*- -;; Friedrich Dominicus <frido@q-software-solutions.com> -;; Newsgroups: comp.lang.scheme -;; Date: 02 Oct 2000 09:24:57 +0200 +;;; Author: Aubrey Jaffer +;;; +;;; This code is in the public domain. -(require-library "init.ss" "slibinit") +(define (make-exchanger obj) + (lambda (rep) (let ((old obj)) (set! obj rep) old))) +(define (open-file filename modes) + (case modes + ((r rb) (open-input-file filename)) + ((w wb) (open-output-file filename)) + (else (slib:error 'open-file 'mode? modes)))) +;;(define (port? obj) (or (input-port? port) (output-port? port))) +(define (call-with-open-ports . ports) + (define proc (car ports)) + (cond ((procedure? proc) (set! ports (cdr ports))) + (else (set! ports (reverse ports)) + (set! proc (car ports)) + (set! ports (reverse (cdr ports))))) + (let ((ans (apply proc ports))) + (for-each close-port ports) + ans)) +(define (close-port port) + (cond ((input-port? port) + (close-input-port port) + (if (output-port? port) (close-output-port port))) + ((output-port? port) (close-output-port port)) + (else (slib:error 'close-port 'port? port)))) + +(define (browse-url url) + (define (try cmd end) (zero? (system (string-append cmd url end)))) + (or (try "netscape-remote -remote 'openURL(" ")'") + (try "netscape -remote 'openURL(" ")'") + (try "netscape '" "'&") + (try "netscape '" "'"))) + +(cond ((string<? (version) "200") + (require-library "init.ss" "slibinit")) + (else + (load (build-path (collection-path "slibinit") "init.ss")) + (eval '(require (lib "defmacro.ss"))) + (slib:provide 'defmacro))) + +;;;The rest corrects mistakes in +;;;/usr/local/lib/plt/collects/slibinit/init.ss: + +(provide 'fluid-let) + +(define slib:warn + (lambda args + (let ((cep (current-error-port))) + (if (provided? 'trace) (print-call-stack cep)) + (display "Warn: " cep) + (for-each (lambda (x) (display #\ cep) (write x cep)) args)))) + +(define call-with-input-string + (lambda (string thunk) + (parameterize ((current-input-port (open-input-string string))) + (thunk (current-input-port))))) @@ -1,4 +1,4 @@ -FAQ (Frequently Asked Questions and answers) for SLIB Scheme Library (slib2d2). +FAQ (Frequently Asked Questions and answers) for SLIB Scheme Library (slib3a1). Written by Aubrey Jaffer (http://swissnet.ai.mit.edu/~jaffer). INTRODUCTION AND GENERAL INFORMATION @@ -14,9 +14,9 @@ Scheme is a programming language in the Lisp family. [] Which implementations has SLIB been ported to? -SLIB is supported by Bigloo, Chez, DrScheme, ELK, GAMBIT, MacScheme, -MITScheme, PocketScheme, RScheme Scheme->C, Scheme48, SCM, SCSH, T3.1, -UMB-Scheme, and VSCM. +SLIB supports Bigloo, Chez, ELK, GAMBIT, Guile, MacScheme, MITScheme, +PLT Scheme (DrScheme and MzScheme), Pocket Scheme, RScheme, scheme->C, +Scheme48, SCM, SCM Mac, scsh, Stk, T3.1, umb-scheme, and VSCM. [] How can I obtain SLIB? @@ -25,8 +25,6 @@ SLIB is available via http from: SLIB is available via ftp from: swissnet.ai.mit.edu:/pub/scm/ -SLIB is also included with SCM floppy disks. - [] How do I install SLIB? Read the INSTALLATION INSTRUCTIONS in "slib/README". @@ -48,7 +46,7 @@ Several times a year. [] What is the latest version? -The version as of this writing is slib2d2. The latest documentation +The version as of this writing is slib3a1. The latest documentation is available online at: http://swissnet.ai.mit.edu/~jaffer/SLIB.html @@ -132,6 +130,17 @@ I find that I only type require statements at top level when debugging. I put require statements in my Scheme files so that the appropriate modules are loaded automatically. +[] What happened to FORMAT? + +In order for FORMAT to call itself for FORMAT error messages, the +original author made its code non-reentrant. For that reason and the +reasons below, FORMAT was removed; I saw little evidence of anyone +using it. + +If someone fixes FORMAT, I will put it back into SLIB. The last +versions of FORMAT are in "format.scm", "formatst.scm", and +"fmtdoc.txi" in http://swissnet.ai.mit.edu/ftpdir/scm/OLD/slib2d5.zip + [] Why does SLIB have PRINTF when it already has the more powerful (CommonLisp) FORMAT? @@ -9,146 +9,214 @@ intro: @echo "Welcome to SLIB. Read \"README\" and \"slib.info\" (or" @echo "\"slib.texi\") to learn how to install and use SLIB." @echo - @echo -make slib.info include srcdir.mk srcdir.mk: .. Makefile echo -e "srcdir = `pwd`/\n" > srcdir.mk #srcdir=$(HOME)/slib/ -PREVDOCS = prevdocs/ -dvidir=../dvi/ -dvi: $(dvidir)slib.dvi -$(dvidir)slib.dvi: version.txi slib.texi $(dvidir)slib.fn schmooz.texi -# cd $(dvidir);export TEXINPUTS=$(srcdir):;texi2dvi $(srcdir)slib.texi - -(cd $(dvidir);export TEXINPUTS=$(srcdir):;texindex slib.??) - cd $(dvidir);export TEXINPUTS=$(srcdir):;tex $(srcdir)slib.texi -$(dvidir)slib.fn: - cd $(dvidir);export TEXINPUTS=$(srcdir):;tex $(srcdir)slib.texi \ - $(srcdir)schmooz.texi -xdvi: $(dvidir)slib.dvi - xdvi -s 6 $(dvidir)slib.dvi -htmldir=../public_html/ -slib_toc.html: version.txi slib.texi htmlform.txi schmooz.texi - texi2html -split -verbose slib.texi -pdf: $(htmldir)slib.pdf -$(htmldir)slib.pdf: version.txi slib.texi $(dvidir)slib.fn schmooz.texi -# cd $(dvidir);dvipdf slib.dvi # doesn't have links! - cd $(dvidir);export TEXINPUTS=$(srcdir):;pdftex $(srcdir)slib.texi - mv $(dvidir)slib.pdf $(htmldir) -xpdf: $(htmldir)slib.pdf - xpdf -z 3 $(htmldir)slib.pdf - -html: $(htmldir)slib_toc.html -$(htmldir)slib_toc.html: slib_toc.html Makefile - hitch $(PREVDOCS)slib_\*.html slib_\*.html $(htmldir) +VERSION = 3a1 +RELEASE = 1 rpm_prefix=/usr/src/redhat/ - prefix = 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: @@ -1,4 +1,4 @@ -This directory contains the distribution of Scheme Library slib2d2. +This directory contains the distribution of Scheme Library slib3a1. Slib conforms to Revised^5 Report on the Algorithmic Language Scheme and the IEEE P1178 specification. Slib supports Unix and similar systems, VMS, and MS-DOS. @@ -8,8 +8,8 @@ The maintainer can be reached at agj @ alum.mit.edu. MANIFEST - `README' is this file. It contains a MANIFEST, INSTALLATION - INSTRUCTIONS, and coding guidelines. + `README' is this file. It contains a MANIFEST and INSTALLATION + INSTRUCTIONS. `FAQ' Frequently Asked Questions and answers. `ChangeLog' documents changes to slib. `slib.texi' has documentation on library packages in TexInfo format. @@ -19,7 +19,7 @@ The maintainer can be reached at agj @ alum.mit.edu. `bigloo.init' is a configuration file for Bigloo. `chez.init' is a configuration file for Chez Scheme. `DrScheme.init' is a configuration file for DrScheme. - `elk.init' is a configuration file for ELK 2.1 + `elk.init' is a configuration file for ELK 3.0. `gambit.init' is a configuration file for Gambit Scheme. `macscheme.init' is a configuration file for MacScheme. `mitscheme.init' is a configuration file for MIT Scheme. @@ -32,16 +32,15 @@ The maintainer can be reached at agj @ alum.mit.edu. `scm.init' is a configuration file for SCM. `t3.init' is a configuration file for T3.1 in Scheme mode. `STk.init' is a configuration file for STk. - `umbscheme.init' is a configuration file for umb-scheme. + `umbscheme.init' is a configuration file for umb-scheme. `vscm.init' is a configuration file for VSCM. `guile.init' is a configuration file for guile. `mklibcat.scm' builds the *catalog* cache. `require.scm' has code which allows system independent access to the library files. + `slib.sh' is a shell script for running various Schemes with SLIB. `Bev2slib.scm' Converts Stephen Bevan's "*.map" files to SLIB catalog entries. - `format.scm' has Common-Lisp style format. - `formatst.scm' has code to test format.scm `pp.scm' has pretty-print. `ppfile.scm' has pprint-file and pprint-filter-file. `obj2str.scm' has object->string. @@ -63,6 +62,7 @@ The maintainer can be reached at agj @ alum.mit.edu. `hash.scm' defines hash, hashq, and hashv. `hashtab.scm' has hash tables. `sierpinski.scm' 2-dimensional coordinate hash. + `phil-spc.scm' Peano-Hilbert Space-Filling Curve. `soundex.scm' English name hash. `logical.scm' emulates 2's complement logical operations. `random.scm' has random number generator compatible with Common Lisp. @@ -75,10 +75,19 @@ The maintainer can be reached at agj @ alum.mit.edu. `selfset.scm' sets single letter identifiers to their symbols. `determ.scm' compute determinant of list of lists. `charplot.scm' has procedure for plotting on character screens. + `grapheps.scm' has procedures for creating PostScript graphs. + `grapheps.ps' is PostScript runtime support for creating graphs. + `matfile.scm' reads MAT-File Format version 4 (MATLAB). `plottest.scm' has code to test charplot.scm. - `tek40.scm' has routines for Tektronix 4000 series graphics. - `tek41.scm' has routines for Tektronix 4100 series graphics. - `getopt.scm' has posix-like getopt for parsing command line arguments. + `solid.scm' has VRML97 solid-modeling. + `colorspc.scm' has CIE and sRGB color transforms. + `colornam.scm' has color-name database functions. + `mkclrnam.scm' creates color-name databases. + `color.scm' has color data-type. + `cie1931.xyz' CIE XYZ(1931) Spectra from 380.nm to 780.nm. + `cie1964.xyz' CIE XYZ(1964) Spectra from 380.nm to 780.nm. + `daylight.scm' Model of sky colors. + `getopt.scm' has posix-like getopt for parsing command line arguments. `psxtime.scm' has Posix time conversion routines. `cltime.scm' has Common-Lisp time conversion routines. `timezone.scm' has the default time-zone, UTC. @@ -88,23 +97,29 @@ The maintainer can be reached at agj @ alum.mit.edu. `rdms.scm' has code to construct a relational database from a base table implementation. `alistab.scm' has association list base tables. - `dbutil.scm' has utilities for creating and manipulating relational + `dbutil.scm' has procedures for creating and opening relational databases. + `dbsyn.scm' has Syntactic extensions for RDMS (within-database). + `dbcom.scm' embeds *commands* in relational databases. + `dbinterp.scm' Interpolate function from database table. `htmlform.scm' generates HTML-3.2 with forms. `db2html.scm' convert relational database to hyperlinked tables and pages. `http-cgi.scm' serves WWW pages with HTTP or CGI. + `html4each.scm' parses HTML files. + `dirs.scm' maps over directory filenames. `uri.scm' encodes and decodes Uniform Resource Identifiers. `dbrowse.scm' browses relational databases. `paramlst.scm' has procedures for passing parameters by name. `getparam.scm' has procedures for converting getopt to parameters. - `report.scm' prints database reports. + `manifest.scm' List SLIB module requires and exports; useful for compiling. + `top-defs.scm' Finds external references. + `vet.scm' Checks each module imports, exports, and documentation. `schmooz.scm' is a simple, lightweight markup language for interspersing Texinfo documentation with Scheme source code. `glob.scm' has filename matching and manipulation. `batch.scm' Group and execute commands on various operating systems. - `makcrc.scm' Create Scheme procedure to calculate POSIX.2 checksums - or other CRCs. + `crc.scm' Calculate POSIX.2 checksums and other CRCs. `record.scm' a MITScheme user-definable datatypes package `promise.scm' has code from R4RS for supporting DELAY and FORCE. @@ -134,7 +149,8 @@ The maintainer can be reached at agj @ alum.mit.edu. `wttree.scm' has weight-balanced trees. `wttest.scm' tests weight-balanced trees. `process.scm' has multi-processing primitives. - `array.scm' has multi-dimensional arrays and sub-arrays. + `array.scm' has multi-dimensional arrays. + `subarray.scm' has subarray and accessory procedures. `arraymap.scm' has array-map!, array-for-each, and array-indexes. `sort.scm' has sorted?, sort, sort!, merge, and merge!. @@ -147,7 +163,7 @@ The maintainer can be reached at agj @ alum.mit.edu. `sc4opt.scm' has optional rev4 procedures. `sc4sc3.scm' has procedures to make a rev3 implementation run rev4 - code. + code. `sc2.scm' has rev2 procedures eliminated in subsequent versions. `mularg.scm' redefines - and / to take more than 2 arguments. `mulapply.scm' redefines apply to take more than 2 arguments. @@ -161,9 +177,11 @@ The maintainer can be reached at agj @ alum.mit.edu. `fluidlet.scm' has fluid-let syntax. `structure.scm' has undocumented syntax-case macros. `byte.scm' has arrays of small integers. - `nclients.scm' provides a Scheme interface to FTP and WWW Browsers. + `bytenumb.scm' convert byte-arrays to integers; IEEE floating-point numbers. + `transact.scm' File locking and backup. `pnm.scm' provides a Scheme interface to "portable bitmap" files. `simetrix.scm' provides SI Metric Interchange Format. + `ncbi-dna.scm' reads and manipulates DNA and protein sequences. `srfi.scm' implements Scheme Request for Implementation. `srfi-N.scm' implements srfi-N. @@ -237,6 +255,13 @@ when installing SLIB. (require 'new-catalog) + The catalog also supports color-name dictionaries. With an +SLIB-installed scheme implementation, type: + (require 'color-names) + (make-slib-color-name-db) + (require 'new-catalog) + (slib:exit) + Implementation-specific Instructions ------------------------------------ @@ -293,7 +318,7 @@ as outlined above. To use SLIB in MzScheme, set the SCHEME_LIBRARY_PATH environment variable to the installed SLIB location; then invoke MzScheme thus: - `mzscheme -L init.ss slibinit' + `mzscheme -f ${SCHEME_LIBRARY_PATH}DrScheme.init' - Implementation: MIT Scheme `scheme -load ${SCHEME_LIBRARY_PATH}mitscheme.init' @@ -326,27 +351,14 @@ library will then be accessible in a system independent fashion. Please mail new working configuration files to `agj @ alum.mit.edu' so that they can be included in the SLIB distribution. - CODING GUIDELINES + USING SLIB - All library packages are written in IEEE P1178 Scheme and assume that -a configuration file and `require.scm' package have already been + All library packages are written in IEEE P1178 Scheme and assume +that a configuration file and `require.scm' package have already been loaded. Other versions of Scheme can be supported in library packages -as well by using, for example, `(provided? 'rev3-report)' or `(require -'rev3-report)'. - - `require.scm' defines `*catalog*', an association list of module -names and filenames. When a new package is added to the library, an -entry should be added to `require.scm'. Local packages can also be -added to `*catalog*' and even shadow entries already in the table. - - The module name and `:' should prefix each symbol defined in the -package. Definitions for external use should then be exported by having -`(define foo module-name:foo)'. +as well by using, for example, `(provided? 'r3rs)' or `(require 'r3rs)'. - Submitted packages should not duplicate routines which are already in -SLIB files. Use `require' to force those features to be supported in -your package. Care should be taken that there are no circularities in -the `require's and `load's between the library packages. +The first chapter of the SLIB manual "The Library System" explains the +mechanics of using SLIB modules. - Documentation should be provided in Emacs Texinfo format if possible, -But documentation must be provided. + http://swissnet.ai.mit.edu/~jaffer/slib_1 diff --git a/RScheme.init b/RScheme.init index c03119c..b9a7d84 100644 --- a/RScheme.init +++ b/RScheme.init @@ -54,6 +54,19 @@ (else ""))))) (lambda () library-path))) +;;; (home-vicinity) should return the vicinity of the user's HOME +;;; directory, the directory which typically contains files which +;;; customize a computer environment for a user. +(define (home-vicinity) + (let ((home (getenv "HOME"))) + (and home + (case (software-type) + ((UNIX COHERENT MS-DOS) ;V7 unix has a / on HOME + (if (eqv? #\/ (string-ref home (+ -1 (string-length home)))) + home + (string-append home "/"))) + (else home))))) + ;;; *FEATURES* should be set to a list of symbols describing features ;;; of this implementation. Suggestions for features are: @@ -66,7 +79,7 @@ ;; Scheme report features -; rev5-report ;conforms to +; r5rs ;conforms to ; eval ;R5RS two-argument eval ; values ;R5RS multiple values ; dynamic-wind ;R5RS dynamic-wind @@ -80,11 +93,11 @@ ;STRING-FILL!, LIST->VECTOR, ;VECTOR->LIST, and VECTOR-FILL! - rev4-report ;conforms to + r4rs ;conforms to ieee-p1178 ;conforms to -; rev3-report ;conforms to +; r3rs ;conforms to ; rev2-procedures ;SUBSTRING-MOVE-LEFT!, ;SUBSTRING-MOVE-RIGHT!, @@ -95,7 +108,7 @@ multiarg/and- ;/ and - can take more than 2 args. with-file ;has WITH-INPUT-FROM-FILE and - ;WITH-OUTPUT-FROM-FILE + ;WITH-OUTPUT-TO-FILE ; transcript ;TRANSCRIPT-ON and TRANSCRIPT-OFF ; ieee-floating-point ;conforms to IEEE Standard 754-1985 ;IEEE Standard for Binary @@ -160,6 +173,33 @@ ;;; CALL-WITH-INPUT-STRING and CALL-WITH-OUTPUT-STRING are the string ;;; port versions of CALL-WITH-*PUT-FILE. +(define (make-exchanger obj) + (lambda (rep) (let ((old obj)) (set! obj rep) old))) +(define (open-file filename modes) + (case modes + ((r rb) (open-input-file filename)) + ((w wb) (open-output-file filename)) + (else (slib:error 'open-file 'mode? modes)))) +(define (port? obj) (or (input-port? port) (output-port? port))) +(define (call-with-open-ports . ports) + (define proc (car ports)) + (cond ((procedure? proc) (set! ports (cdr ports))) + (else (set! ports (reverse ports)) + (set! proc (car ports)) + (set! ports (reverse (cdr ports))))) + (let ((ans (apply proc ports))) + (for-each close-port ports) + ans)) +(define (close-port port) + (cond ((input-port? port) + (close-input-port port) + (if (output-port? port) (close-output-port port))) + ((output-port? port) (close-output-port port)) + (else (slib:error 'close-port 'port? port)))) + +(define (browse-url url) + (slib:warn "define BROWSE-URL in macscheme.init")) + ;;; CHAR-CODE-LIMIT is one greater than the largest integer which can ;;; be returned by CHAR->INTEGER. (define char-code-limit 65536) @@ -232,7 +272,7 @@ (let ((cep (current-error-port))) (if (provided? 'trace) (print-call-stack cep)) (display "Warn: " cep) - (for-each (lambda (x) (display x cep)) args)))) + (for-each (lambda (x) (display #\ cep) (write x cep)) args)))) ;;; define an error procedure for the library (define (slib:error msg . args) @@ -7,35 +7,29 @@ ;;; (software-type) should be set to the generic operating system type. ;;; UNIX, VMS, MACOS, AMIGA and MS-DOS are supported. - (define (software-type) 'UNIX) ;;; (scheme-implementation-type) should return the name of the scheme ;;; implementation loading this file. - (define (scheme-implementation-type) '|STk|) ;;; (scheme-implementation-home-page) should return a (string) URI ;;; (Uniform Resource Identifier) for this scheme implementation's home ;;; page; or false if there isn't one. - (define (scheme-implementation-home-page) "http://kaolin.unice.fr/STk/STk.html") ;;; (scheme-implementation-version) should return a string describing ;;; the version the scheme implementation loading this file. - (define (scheme-implementation-version) (version)) ;;; (implementation-vicinity) should be defined to be the pathname of ;;; the directory where any auxillary files to your Scheme ;;; implementation reside. - (define (implementation-vicinity) "/usr/local/lib/stk/3.99.3/") ;;; (library-vicinity) should be defined to be the pathname of the ;;; directory where files of Scheme library functions reside. - (define library-vicinity (let ((library-path (or (getenv "SCHEME_LIBRARY_PATH") "/usr/local/lib/slib/"))) (lambda () library-path))) @@ -44,14 +38,18 @@ ;;; (home-vicinity) should return the vicinity of the user's HOME ;;; directory, the directory which typically contains files which ;;; customize a computer environment for a user. - -(define home-vicinity - (let ((home-path (or (getenv "HOME") "/"))) - (lambda () home-path))) +(define (home-vicinity) + (let ((home (getenv "HOME"))) + (and home + (case (software-type) + ((UNIX COHERENT MS-DOS) ;V7 unix has a / on HOME + (if (eqv? #\/ (string-ref home (+ -1 (string-length home)))) + home + (string-append home "/"))) + (else home))))) ;;; *FEATURES* should be set to a list of symbols describing features ;;; of this implementation. Suggestions for features are: - (define *features* '( source ;can load scheme source files @@ -61,7 +59,7 @@ ;; Scheme report features -; rev5-report ;conforms to +; r5rs ;conforms to eval ;R5RS two-argument eval ; values ;R5RS multiple values dynamic-wind ;R5RS dynamic-wind @@ -75,11 +73,11 @@ ;STRING-FILL!, LIST->VECTOR, ;VECTOR->LIST, and VECTOR-FILL! - rev4-report ;conforms to + r4rs ;conforms to ieee-p1178 ;conforms to -; rev3-report ;conforms to +; r3rs ;conforms to ; rev2-procedures ;SUBSTRING-MOVE-LEFT!, ;SUBSTRING-MOVE-RIGHT!, @@ -90,7 +88,7 @@ multiarg/and- ;/ and - can take more than 2 args. with-file ;has WITH-INPUT-FROM-FILE and - ;WITH-OUTPUT-FROM-FILE + ;WITH-OUTPUT-TO-FILE ; transcript ;TRANSCRIPT-ON and TRANSCRIPT-OFF ieee-floating-point ;conforms to IEEE Standard 754-1985 ;IEEE Standard for Binary @@ -141,6 +139,37 @@ ;;; use this definition if your system doesn't have such a procedure. (define (force-output . arg) (apply flush arg)) +(define (make-exchanger obj) + (lambda (rep) (let ((old obj)) (set! obj rep) old))) +(define (open-file filename modes) + (case modes + ((r rb) (open-input-file filename)) + ((w wb) (open-output-file filename)) + (else (slib:error 'open-file 'mode? modes)))) +(define (port? obj) (or (input-port? port) (output-port? port))) +(define (call-with-open-ports . ports) + (define proc (car ports)) + (cond ((procedure? proc) (set! ports (cdr ports))) + (else (set! ports (reverse ports)) + (set! proc (car ports)) + (set! ports (reverse (cdr ports))))) + (let ((ans (apply proc ports))) + (for-each close-port ports) + ans)) +(define (close-port port) + (cond ((input-port? port) + (close-input-port port) + (if (output-port? port) (close-output-port port))) + ((output-port? port) (close-output-port port)) + (else (slib:error 'close-port 'port? port)))) + +(define (browse-url url) + (define (try cmd) (eqv? 0 (system (sprintf #f cmd url)))) + (or (try "netscape-remote -remote 'openURL(%s)'") + (try "netscape -remote 'openURL(%s)'") + (try "netscape '%s'&") + (try "netscape '%s'"))) + ;;; CHAR-CODE-LIMIT is one greater than the largest integer which can ;;; be returned by CHAR->INTEGER. (define char-code-limit 256) @@ -199,7 +228,7 @@ (let ((cep (current-error-port))) (if (provided? 'trace) (print-call-stack cep)) (display "Warn: " cep) - (for-each (lambda (x) (display x cep)) args)))) + (for-each (lambda (x) (display #\ cep) (write x cep)) args)))) ;;; define an error procedure for the library (define (slib:error . args) @@ -230,13 +259,11 @@ ;;; (SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever ;;; suffix all the module files in SLIB have. See feature 'SOURCE. - (define slib:load-source LOAD) ;;; (SLIB:LOAD-COMPILED "foo") should load the file that was produced ;;; by compiling "foo.scm" if this implementation can compile files. ;;; See feature 'COMPILED. - (define slib:load-compiled load) ;;; diff --git a/Template.scm b/Template.scm index 6421d92..63c10c9 100644 --- a/Template.scm +++ b/Template.scm @@ -3,40 +3,34 @@ ;;; ;;; This code is in the public domain. -;;; (software-type) should be set to the generic operating system type. +;;@ (software-type) should be set to the generic operating system type. ;;; UNIX, VMS, MACOS, AMIGA and MS-DOS are supported. - (define (software-type) 'UNIX) -;;; (scheme-implementation-type) should return the name of the scheme +;;@ (scheme-implementation-type) should return the name of the scheme ;;; implementation loading this file. - (define (scheme-implementation-type) 'Template) -;;; (scheme-implementation-home-page) should return a (string) URI +;;@ (scheme-implementation-home-page) should return a (string) URI ;;; (Uniform Resource Identifier) for this scheme implementation's home ;;; page; or false if there isn't one. - (define (scheme-implementation-home-page) #f) -;;; (scheme-implementation-version) should return a string describing +;;@ (scheme-implementation-version) should return a string describing ;;; the version the scheme implementation loading this file. - (define (scheme-implementation-version) "?") -;;; (implementation-vicinity) should be defined to be the pathname of +;;@ (implementation-vicinity) should be defined to be the pathname of ;;; the directory where any auxillary files to your Scheme ;;; implementation reside. - (define (implementation-vicinity) (case (software-type) ((UNIX) "/usr/local/src/scheme/") ((VMS) "scheme$src:") ((MS-DOS) "C:\\scheme\\"))) -;;; (library-vicinity) should be defined to be the pathname of the +;;@ (library-vicinity) should be defined to be the pathname of the ;;; directory where files of Scheme library functions reside. - (define library-vicinity (let ((library-path (or @@ -51,17 +45,21 @@ (else ""))))) (lambda () library-path))) -;;; (home-vicinity) should return the vicinity of the user's HOME +;;@ (home-vicinity) should return the vicinity of the user's HOME ;;; directory, the directory which typically contains files which ;;; customize a computer environment for a user. - -(define home-vicinity - (let ((home-path (getenv "HOME"))) - (lambda () home-path))) - -;;; *FEATURES* should be set to a list of symbols describing features +(define (home-vicinity) + (let ((home (getenv "HOME"))) + (and home + (case (software-type) + ((UNIX COHERENT MS-DOS) ;V7 unix has a / on HOME + (if (eqv? #\/ (string-ref home (+ -1 (string-length home)))) + home + (string-append home "/"))) + (else home))))) + +;;@ *FEATURES* should be set to a list of symbols describing features ;;; of this implementation. Suggestions for features are: - (define *features* '( source ;can load scheme source files @@ -71,7 +69,7 @@ ;; Scheme report features - rev5-report ;conforms to + r5rs ;conforms to eval ;R5RS two-argument eval values ;R5RS multiple values dynamic-wind ;R5RS dynamic-wind @@ -85,11 +83,11 @@ ;STRING-FILL!, LIST->VECTOR, ;VECTOR->LIST, and VECTOR-FILL! - rev4-report ;conforms to + r4rs ;conforms to ieee-p1178 ;conforms to -; rev3-report ;conforms to +; r3rs ;conforms to ; rev2-procedures ;SUBSTRING-MOVE-LEFT!, ;SUBSTRING-MOVE-RIGHT!, @@ -100,7 +98,7 @@ ; multiarg/and- ;/ and - can take more than 2 args. ; with-file ;has WITH-INPUT-FROM-FILE and - ;WITH-OUTPUT-FROM-FILE + ;WITH-OUTPUT-TO-FILE ; transcript ;TRANSCRIPT-ON and TRANSCRIPT-OFF ieee-floating-point ;conforms to IEEE Standard 754-1985 ;IEEE Standard for Binary @@ -133,66 +131,66 @@ )) -;;; (OUTPUT-PORT-WIDTH <port>) +;;@ (OUTPUT-PORT-WIDTH <port>) (define (output-port-width . arg) 79) -;;; (OUTPUT-PORT-HEIGHT <port>) +;;@ (OUTPUT-PORT-HEIGHT <port>) (define (output-port-height . arg) 24) -;;; (CURRENT-ERROR-PORT) +;;@ (CURRENT-ERROR-PORT) (define current-error-port (let ((port (current-output-port))) (lambda () port))) -;;; (TMPNAM) makes a temporary file name. +;;@ (TMPNAM) makes a temporary file name. (define tmpnam (let ((cntr 100)) (lambda () (set! cntr (+ 1 cntr)) (string-append "slib_" (number->string cntr))))) -;;; (FILE-EXISTS? <string>) +;;@ (FILE-EXISTS? <string>) (define (file-exists? f) #f) -;;; (DELETE-FILE <string>) +;;@ (DELETE-FILE <string>) (define (delete-file f) #f) -;;; FORCE-OUTPUT flushes any pending output on optional arg output port +;;@ FORCE-OUTPUT flushes any pending output on optional arg output port ;;; use this definition if your system doesn't have such a procedure. (define (force-output . arg) #t) ;;; CALL-WITH-INPUT-STRING and CALL-WITH-OUTPUT-STRING are the string ;;; port versions of CALL-WITH-*PUT-FILE. -;;; "rationalize" adjunct procedures. +;;@ "rationalize" adjunct procedures. ;;(define (find-ratio x e) ;; (let ((rat (rationalize x e))) ;; (list (numerator rat) (denominator rat)))) ;;(define (find-ratio-between x y) ;; (find-ratio (/ (+ x y) 2) (/ (- x y) 2))) -;;; CHAR-CODE-LIMIT is one greater than the largest integer which can +;;@ CHAR-CODE-LIMIT is one greater than the largest integer which can ;;; be returned by CHAR->INTEGER. (define char-code-limit 256) -;;; MOST-POSITIVE-FIXNUM is used in modular.scm +;;@ MOST-POSITIVE-FIXNUM is used in modular.scm (define most-positive-fixnum #x0FFFFFFF) -;;; Return argument +;;@ Return argument (define (identity x) x) -;;; SLIB:EVAL is single argument eval using the top-level (user) environment. +;;@ SLIB:EVAL is single argument eval using the top-level (user) environment. (define slib:eval eval) -;;; If your implementation provides R4RS macros: +;; If your implementation provides R4RS macros: ;(define macro:eval slib:eval) ;(define macro:load load) - (define *defmacros* (list (cons 'defmacro (lambda (name parms . body) `(set! *defmacros* (cons (cons ',name (lambda ,parms ,@body)) *defmacros*)))))) +;@ (define (defmacro? m) (and (assq m *defmacros*) #t)) - +;@ (define (macroexpand-1 e) (if (pair? e) (let ((a (car e))) @@ -200,7 +198,7 @@ (if a (apply (cdr a) (cdr e)) e)) (else e))) e)) - +;@ (define (macroexpand e) (if (pair? e) (let ((a (car e))) @@ -209,7 +207,7 @@ (if a (macroexpand (apply (cdr a) (cdr e))) e)) (else e))) e)) - +;@ (define gentemp (let ((*gensym-counter* -1)) (lambda () @@ -218,13 +216,15 @@ (string-append "slib:G" (number->string *gensym-counter*)))))) (define base:eval slib:eval) +;@ (define (defmacro:eval x) (base:eval (defmacro:expand* x))) + (define (defmacro:expand* x) (require 'defmacroexpand) (apply defmacro:expand* x '())) - +;@ (define (defmacro:load <pathname>) (slib:eval-load <pathname> defmacro:eval)) - +;@ (define (slib:eval-load <pathname> evl) (if (not (file-exists? <pathname>)) (set! <pathname> (string-append <pathname> (scheme-file-suffix)))) @@ -236,61 +236,89 @@ ((eof-object? o)) (evl o)) (set! *load-pathname* old-load-pathname))))) - +;@ (define slib:warn (lambda args (let ((cep (current-error-port))) (if (provided? 'trace) (print-call-stack cep)) (display "Warn: " cep) - (for-each (lambda (x) (display x cep)) args)))) + (for-each (lambda (x) (display #\ cep) (write x cep)) args)))) -;;; define an error procedure for the library +;;@ define an error procedure for the library (define (slib:error . args) (if (provided? 'trace) (print-call-stack (current-error-port))) (apply error args)) - -;;; define these as appropriate for your system. +;@ +(define (make-exchanger obj) + (lambda (rep) (let ((old obj)) (set! obj rep) old))) +(define (open-file filename modes) + (case modes + ((r rb) (open-input-file filename)) + ((w wb) (open-output-file filename)) + (else (slib:error 'open-file 'mode? modes)))) +(define (port? obj) (or (input-port? port) (output-port? port))) +(define (call-with-open-ports . ports) + (define proc (car ports)) + (cond ((procedure? proc) (set! ports (cdr ports))) + (else (set! ports (reverse ports)) + (set! proc (car ports)) + (set! ports (reverse (cdr ports))))) + (let ((ans (apply proc ports))) + (for-each close-port ports) + ans)) +(define (close-port port) + (cond ((input-port? port) + (close-input-port port) + (if (output-port? port) (close-output-port port))) + ((output-port? port) (close-output-port port)) + (else (slib:error 'close-port 'port? port)))) +;@ +(define (browse-url url) + (define (try cmd end) (zero? (system (string-append cmd url end)))) + (or (try "netscape-remote -remote 'openURL(" ")'") + (try "netscape -remote 'openURL(" ")'") + (try "netscape '" "'&") + (try "netscape '" "'"))) + +;;@ define these as appropriate for your system. (define slib:tab (integer->char 9)) (define slib:form-feed (integer->char 12)) -;;; Support for older versions of Scheme. Not enough code for its own file. +;;@ Support for older versions of Scheme. Not enough code for its own file. (define (last-pair l) (if (pair? (cdr l)) (last-pair (cdr l)) l)) (define t #t) (define nil #f) -;;; Define these if your implementation's syntax can support it and if +;;@ Define these if your implementation's syntax can support it and if ;;; they are not already defined. - ;(define (1+ n) (+ n 1)) ;(define (-1+ n) (+ n -1)) ;(define 1- -1+) +;@ (define in-vicinity string-append) -;;; Define SLIB:EXIT to be the implementation procedure to exit or +;;@ Define SLIB:EXIT to be the implementation procedure to exit or ;;; return if exitting not supported. (define slib:exit (lambda args #f)) -;;; Here for backward compatability +;;@ Here for backward compatability (define scheme-file-suffix (let ((suffix (case (software-type) ((NOSVE) "_scm") (else ".scm")))) (lambda () suffix))) -;;; (SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever +;;@ (SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever ;;; suffix all the module files in SLIB have. See feature 'SOURCE. - (define (slib:load-source f) (load (string-append f ".scm"))) -;;; (SLIB:LOAD-COMPILED "foo") should load the file that was produced +;;@ (SLIB:LOAD-COMPILED "foo") should load the file that was produced ;;; by compiling "foo.scm" if this implementation can compile files. ;;; See feature 'COMPILED. - (define slib:load-compiled load) -;;; At this point SLIB:LOAD must be able to load SLIB files. - +;;@ At this point SLIB:LOAD must be able to load SLIB files. (define slib:load slib:load-source) (slib:load (in-vicinity (library-vicinity) "require")) @@ -1,5 +1,5 @@ ;;;"alist.scm", alist functions for Scheme. -;;;Copyright (c) 1992, 1993 Aubrey Jaffer +;;;Copyright (c) 1992, 1993, 2003 Aubrey Jaffer ; ;Permission to copy this software, to modify it, to redistribute it, ;to distribute modified versions, and to use it for any purpose is @@ -8,7 +8,7 @@ ;1. Any copy made of this software must include this copyright notice ;in full. ; -;2. I have made no warrantee or representation that the operation of +;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; @@ -17,6 +17,23 @@ ;promotional, or sales literature without prior written consent in ;each case. +;;@code{(require 'alist)} +;;@ftindex alist +;; +;;Alist functions provide utilities for treating a list of key-value pairs +;;as an associative database. These functions take an equality predicate, +;;@var{pred}, as an argument. This predicate should be repeatable, +;;symmetric, and transitive. +;; +;;Alist functions can be used with a secondary index method such as hash +;;tables for improved performance. + +;;@body +;;Returns an @dfn{association function} (like @code{assq}, @code{assv}, or +;;@code{assoc}) corresponding to @var{pred}. The returned function +;;returns a key-value pair whose key is @code{pred}-equal to its first +;;argument or @code{#f} if no key in the alist is @var{pred}-equal to the +;;first argument. (define (predicate->asso pred) (cond ((eq? eq? pred) assq) ((eq? = pred) assv) @@ -30,12 +47,28 @@ ((pred key (caar al)) (car al)) (else (l (cdr al))))))))) +;;@body +;;Returns a procedure of 2 arguments, @var{alist} and @var{key}, which +;;returns the value associated with @var{key} in @var{alist} or @code{#f} if +;;@var{key} does not appear in @var{alist}. (define (alist-inquirer pred) (let ((assofun (predicate->asso pred))) (lambda (alist key) (let ((pair (assofun key alist))) (and pair (cdr pair)))))) +;;@body +;;Returns a procedure of 3 arguments, @var{alist}, @var{key}, and +;;@var{value}, which returns an alist with @var{key} and @var{value} +;;associated. Any previous value associated with @var{key} will be +;;lost. This returned procedure may or may not have side effects on its +;;@var{alist} argument. An example of correct usage is: +;; +;;@lisp +;;(define put (alist-associator string-ci=?)) +;;(define alist '()) +;;(set! alist (put alist "Foo" 9)) +;;@end lisp (define (alist-associator pred) (let ((assofun (predicate->asso pred))) (lambda (alist key val) @@ -44,6 +77,16 @@ alist) (else (cons (cons key val) alist))))))) +;;@body +;;Returns a procedure of 2 arguments, @var{alist} and @var{key}, which +;;returns an alist with an association whose @var{key} is key removed. +;;This returned procedure may or may not have side effects on its +;;@var{alist} argument. An example of correct usage is: +;; +;;@lisp +;;(define rem (alist-remover string-ci=?)) +;;(set! alist (rem alist "foo")) +;;@end lisp (define (alist-remover pred) (lambda (alist key) (cond ((null? alist) alist) @@ -58,9 +101,17 @@ (set-cdr! al (cddr al)) alist) (else (l (cdr al))))))))) +;;@body +;;Returns a new association list formed by mapping @var{proc} over the +;;keys and values of @var{alist}. @var{proc} must be a function of 2 +;;arguments which returns the new value part. (define (alist-map proc alist) (map (lambda (pair) (cons (car pair) (proc (car pair) (cdr pair)))) alist)) +;;@body +;;Applies @var{proc} to each pair of keys and values of @var{alist}. +;;@var{proc} must be a function of 2 arguments. The returned value is +;;unspecified. (define (alist-for-each proc alist) (for-each (lambda (pair) (proc (car pair) (cdr pair))) alist)) diff --git a/alist.txi b/alist.txi new file mode 100644 index 0000000..804df8a --- /dev/null +++ b/alist.txi @@ -0,0 +1,70 @@ +@code{(require 'alist)} +@ftindex alist + +Alist functions provide utilities for treating a list of key-value pairs +as an associative database. These functions take an equality predicate, +@var{pred}, as an argument. This predicate should be repeatable, +symmetric, and transitive. + +Alist functions can be used with a secondary index method such as hash +tables for improved performance. + + +@defun predicate->asso pred + +Returns an @dfn{association function} (like @code{assq}, @code{assv}, or +@cindex association function +@code{assoc}) corresponding to @var{pred}. The returned function +returns a key-value pair whose key is @code{pred}-equal to its first +argument or @code{#f} if no key in the alist is @var{pred}-equal to the +first argument. +@end defun + +@defun alist-inquirer pred + +Returns a procedure of 2 arguments, @var{alist} and @var{key}, which +returns the value associated with @var{key} in @var{alist} or @code{#f} if +@var{key} does not appear in @var{alist}. +@end defun + +@defun alist-associator pred + +Returns a procedure of 3 arguments, @var{alist}, @var{key}, and +@var{value}, which returns an alist with @var{key} and @var{value} +associated. Any previous value associated with @var{key} will be +lost. This returned procedure may or may not have side effects on its +@var{alist} argument. An example of correct usage is: + +@lisp +(define put (alist-associator string-ci=?)) +(define alist '()) +(set! alist (put alist "Foo" 9)) +@end lisp +@end defun + +@defun alist-remover pred + +Returns a procedure of 2 arguments, @var{alist} and @var{key}, which +returns an alist with an association whose @var{key} is key removed. +This returned procedure may or may not have side effects on its +@var{alist} argument. An example of correct usage is: + +@lisp +(define rem (alist-remover string-ci=?)) +(set! alist (rem alist "foo")) +@end lisp +@end defun + +@defun alist-map proc alist + +Returns a new association list formed by mapping @var{proc} over the +keys and values of @var{alist}. @var{proc} must be a function of 2 +arguments which returns the new value part. +@end defun + +@defun alist-for-each proc alist + +Applies @var{proc} to each pair of keys and values of @var{alist}. +@var{proc} must be a function of 2 arguments. The returned value is +unspecified. +@end defun diff --git a/alistab.scm b/alistab.scm index e51bd26..e8999bf 100644 --- a/alistab.scm +++ b/alistab.scm @@ -8,7 +8,7 @@ ;1. Any copy made of this software must include this copyright notice ;in full. ; -;2. I have made no warrantee or representation that the operation of +;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; @@ -23,7 +23,9 @@ ;;; ROW is a list of non-primary VALUEs (require 'common-list-functions) - +(require 'relational-database) ;for make-relational-system +(require-if 'compiling 'sort) +;@ (define alist-table (let ((catalog-id 0) (resources '*base-resources*) @@ -42,13 +44,15 @@ (list resources (list 'free-id 1)))) (define (open-base infile writable) - (and (or (input-port? infile) (file-exists? infile)) - (cons (if (input-port? infile) #f infile) - ((lambda (fun) - (if (input-port? infile) - (fun infile) - (call-with-input-file infile fun))) - read)))) + (define (reader port) + (cond ((eof-object? port) #f) + ((not (eqv? #\; (read-char port))) #f) + ((not (eqv? #\; (read-char port))) #f) + (else (cons (and (not (input-port? infile)) infile) + (read port))))) + (cond ((input-port? infile) (reader infile)) + ((file-exists? infile) (call-with-input-file infile reader)) + (else #f))) (define (write-base lldb outfile) ((lambda (fun) @@ -57,7 +61,8 @@ (else #f))) (lambda (port) (display (string-append - ";;; \"" outfile "\" SLIB alist-table database -*-scheme-*-") + ";;; \"" outfile "\" SLIB " *SLIB-VERSION* + " alist-table database -*-scheme-*-") port) (newline port) (newline port) (display "(" port) (newline port) @@ -303,12 +308,12 @@ (define (supported-type? type) (case type - ((base-id atom integer boolean string symbol expression number) #t) + ((atom ordinal integer boolean string symbol expression number) #t) (else #f))) (define (supported-key-type? type) (case type - ((atom integer number symbol string) #t) + ((atom ordinal integer number symbol string) #t) (else #f))) ;;make-table open-table remover assoc* make-assoc* @@ -349,4 +354,8 @@ (else #f))) )) +(set! *base-table-implementations* + (cons (list 'alist-table (make-relational-system alist-table)) + *base-table-implementations*)) + ;; #f (trace-all "/home/jaffer/slib/alistab.scm") (untrace alist-table) (set! *qp-width* 333) @@ -1,5 +1,5 @@ ;;;;"array.scm" Arrays for Scheme -; Copyright (C) 2001 Aubrey Jaffer +; Copyright (C) 2001, 2003 Aubrey Jaffer ; ;Permission to copy this software, to modify it, to redistribute it, ;to distribute modified versions, and to use it for any purpose is @@ -8,7 +8,7 @@ ;1. Any copy made of this software must include this copyright notice ;in full. ; -;2. I have made no warrantee or representation that the operation of +;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; @@ -30,7 +30,12 @@ store ;data ))) -(define array:shape (record-accessor array:rtd 'shape)) +(define array:shape + (let ((shape (record-accessor array:rtd 'shape))) + (lambda (array) + (cond ((vector? array) (list (list 0 (+ -1 (vector-length array))))) + ((string? array) (list (list 0 (+ -1 (string-length array))))) + (else (shape array)))))) (define array:scales (let ((scales (record-accessor array:rtd 'scales))) @@ -77,7 +82,8 @@ ;;corresponding elements of @1 and @2 are @code{equal?}. ;; ;;@example -;;(array=? (make-array 'foo 3 3) (make-array 'foo '(0 2) '(1 2))) +;;(array=? (create-array '#(foo) 3 3) +;; (create-array '#(foo) '(0 2) '(0 2))) ;; @result{} #t ;;@end example (define (array=? array1 array2) @@ -87,17 +93,133 @@ (define (array:dimensions->shape dims) (map (lambda (dim) (if (list? dim) dim (list 0 (+ -1 dim)))) dims)) -;;@args initial-value bound1 bound2 @dots{} -;;Creates and returns an array with dimensions @var{bound1}, -;;@var{bound2}, @dots{} and filled with @1. -(define (make-array initial-value . dimensions) +;;@args prototype bound1 bound2 @dots{} +;; +;;Creates and returns an array of type @1 with dimensions @2, @3, +;;@dots{} and filled with elements from @1. @1 must be an array, +;;vector, or string. The implementation-dependent type of the returned +;;array will be the same as the type of @1; except if that would be a +;;vector or string with non-zero origin, in which case some variety of +;;array will be returned. +;; +;;If the @1 has no elements, then the initial contents of the returned +;;array are unspecified. Otherwise, the returned array will be filled +;;with the element at the origin of @1. +(define (create-array prototype . dimensions) + (define range2length (lambda (bnd) (- 1 (apply - bnd)))) + ;;(if (not (array? prototype)) (set! prototype (vector prototype))) (let* ((shape (array:dimensions->shape dimensions)) - (dims (map (lambda (bnd) (- 1 (apply - bnd))) shape)) - (scales (reverse (cons 1 (cdr (reverse dims)))))) - (array:construct shape - scales - (- (apply + (map * (map car shape) scales))) - (make-vector (apply * dims) initial-value)))) + (dims (map range2length shape)) + (scales + (do ((dims (reverse (cdr dims)) (cdr dims)) + (scls '(1) (cons (* (car dims) (car scls)) scls))) + ((null? dims) scls)))) + (array:construct + shape + scales + (- (apply + (map * (map car shape) scales))) + (if (string? prototype) + (case (string-length prototype) + ((0) (make-string (apply * dims))) + (else (make-string (apply * dims) + (string-ref prototype 0)))) + (let ((pshape (array:shape prototype))) + (case (apply * (map range2length pshape)) + ((0) (make-vector (apply * dims))) + (else (make-vector (apply * dims) + (apply array-ref prototype + (map car pshape)))))))))) + +;;@noindent +;;These functions return a prototypical uniform-array enclosing the +;;optional argument (which must be of the correct type). If the +;;uniform-array type is supported by the implementation, then it is +;;returned; defaulting to the next larger precision type; resorting +;;finally to vector. + +(define (make-prototype-checker name pred? creator) + (lambda args + (case (length args) + ((1) (if (pred? (car args)) + (creator (car args)) + (slib:error name 'incompatible 'type (car args)))) + ((0) (creator)) + (else (slib:error name 'wrong 'number 'of 'args args))))) + +(define (integer-bytes?? n) + (lambda (obj) + (and (integer? obj) + (exact? obj) + (or (negative? n) (not (negative? obj))) + (do ((num obj (quotient num 256)) + (n (+ -1 (abs n)) (+ -1 n))) + ((or (zero? num) (negative? n)) + (zero? num)))))) + +;;@args z +;;@args +;;Returns a high-precision complex uniform-array prototype. +(define Ac64 (make-prototype-checker 'Ac64 complex? vector)) +;;@args z +;;@args +;;Returns a complex uniform-array prototype. +(define Ac32 (make-prototype-checker 'Ac32 complex? vector)) + +;;@args x +;;@args +;;Returns a high-precision real uniform-array prototype. +(define Ar64 (make-prototype-checker 'Ar64 real? vector)) +;;@args x +;;@args +;;Returns a real uniform-array prototype. +(define Ar32 (make-prototype-checker 'Ar32 real? vector)) + +;;@args n +;;@args +;;Returns an exact signed integer uniform-array prototype with at least +;;64 bits of precision. +(define As64 (make-prototype-checker 'As64 (integer-bytes?? -8) vector)) +;;@args n +;;@args +;;Returns an exact signed integer uniform-array prototype with at least +;;32 bits of precision. +(define As32 (make-prototype-checker 'As32 (integer-bytes?? -4) vector)) +;;@args n +;;@args +;;Returns an exact signed integer uniform-array prototype with at least +;;16 bits of precision. +(define As16 (make-prototype-checker 'As16 (integer-bytes?? -2) vector)) +;;@args n +;;@args +;;Returns an exact signed integer uniform-array prototype with at least +;;8 bits of precision. +(define As8 (make-prototype-checker 'As8 (integer-bytes?? -1) vector)) + +;;@args k +;;@args +;;Returns an exact non-negative integer uniform-array prototype with at +;;least 64 bits of precision. +(define Au64 (make-prototype-checker 'Au64 (integer-bytes?? 8) vector)) +;;@args k +;;@args +;;Returns an exact non-negative integer uniform-array prototype with at +;;least 32 bits of precision. +(define Au32 (make-prototype-checker 'Au32 (integer-bytes?? 4) vector)) +;;@args k +;;@args +;;Returns an exact non-negative integer uniform-array prototype with at +;;least 16 bits of precision. +(define Au16 (make-prototype-checker 'Au16 (integer-bytes?? 2) vector)) +;;@args k +;;@args +;;Returns an exact non-negative integer uniform-array prototype with at +;;least 8 bits of precision. +(define Au8 (make-prototype-checker 'Au8 (integer-bytes?? 1) vector)) + +;;@args bool +;;@args +;;Returns a boolean uniform-array prototype. +(define At1 (make-prototype-checker 'At1 boolean? vector)) ;;@noindent ;;When constructing an array, @var{bound} is either an inclusive range of @@ -105,18 +227,18 @@ ;;a single integer. So ;; ;;@example -;;(make-array 'foo 3 3) @equiv{} (make-array 'foo '(0 2) '(0 2)) +;;(create-array '#(foo) 3 3) @equiv{} (create-array '#(foo) '(0 2) '(0 2)) ;;@end example ;;@args array mapper bound1 bound2 @dots{} -;;@code{make-shared-array} can be used to create shared subarrays of other +;;@0 can be used to create shared subarrays of other ;;arrays. The @var{mapper} is a function that translates coordinates in ;;the new array into coordinates in the old array. A @var{mapper} must be ;;linear, and its range must stay within the bounds of the old array, but ;;it can be otherwise arbitrary. A simple example: ;; ;;@example -;;(define fred (make-array #f 8 8)) +;;(define fred (create-array '#(#f) 8 8)) ;;(define freds-diagonal ;; (make-shared-array fred (lambda (i) (list i i)) 8)) ;;(array-set! freds-diagonal 'foo 3) @@ -153,32 +275,28 @@ ;;Returns the number of dimensions of @1. If @1 is not an array, 0 is ;;returned. (define (array-rank obj) - (if (array? obj) (length (array-shape obj)) 0)) + (if (array? obj) (length (array:shape obj)) 0)) -;;@body +;;@args array ;;Returns a list of inclusive bounds. ;; ;;@example -;;(array-shape (make-array 'foo 3 5)) +;;(array-shape (create-array '#() 3 5)) ;; @result{} ((0 2) (0 4)) ;;@end example -(define array-shape - (lambda (array) - (cond ((vector? array) (list (list 0 (+ -1 (vector-length array))))) - ((string? array) (list (list 0 (+ -1 (string-length array))))) - (else (array:shape array))))) +(define array-shape array:shape) ;;@body ;;@code{array-dimensions} is similar to @code{array-shape} but replaces ;;elements with a 0 minimum with one greater than the maximum. ;; ;;@example -;;(array-dimensions (make-array 'foo 3 5)) +;;(array-dimensions (create-array '#() 3 5)) ;; @result{} (3 5) ;;@end example (define (array-dimensions array) (map (lambda (bnd) (if (zero? (car bnd)) (+ 1 (cadr bnd)) bnd)) - (array-shape array))) + (array:shape array))) (define (array:in-bounds? array indices) (do ((bnds (array:shape array) (cdr bnds)) @@ -217,12 +335,8 @@ ;;; Legacy functions -;; These procedures are fast versions of @code{array-ref} and -;; @code{array-set!} for non-string arrays; they take a fixed number of -;; arguments and perform no bounds checking. -(define array-1d-ref array-ref) -(define array-2d-ref array-ref) -(define array-3d-ref array-ref) -(define array-1d-set! array-set!) -(define array-2d-set! array-set!) -(define array-3d-set! array-set!) +;; ;;@args initial-value bound1 bound2 @dots{} +;; ;;Creates and returns an array with dimensions @2, +;; ;;@3, @dots{} and filled with @1. +;; (define (make-array initial-value . dimensions) +;; (apply create-array (vector initial-value) dimensions)) @@ -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 @@ -8,7 +8,7 @@ ;1. Any copy made of this software must include this copyright notice ;in full. ; -;2. I have made no warrantee or representation that the operation of +;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; @@ -17,11 +17,14 @@ ;promotional, or sales literature without prior written consent in ;each case. +(require 'tree) (require 'line-i/o) ;Just for write-line +(require 'databases) (require 'parameters) -(require 'database-utilities) (require 'string-port) -(require 'tree) +(require 'pretty-print) +(require 'common-list-functions) +(require-if '(and bignum compiling) 'posix-time) (define system (if (provided? 'system) @@ -43,6 +46,9 @@ (define (batch:dialect parms) ; was batch-family (car (parameter-list-ref parms 'batch-dialect))) +(define (batch:operating-system parms) + (car (parameter-list-ref parms 'operating-system))) + (define (write-batch-line str line-limit port) (cond ((and line-limit (>= (string-length str) line-limit)) (slib:warn 'write-batch-line 'too-long @@ -53,7 +59,7 @@ (write-batch-line str (batch:line-length-limit parms) (batch:port parms))) ;;; add a Scheme batch-dialect? - +;@ (define (batch:try-chopped-command parms . args) (define args-but-last (batch:flatten (butlast args 1))) (define line-limit (batch:line-length-limit parms)) @@ -65,7 +71,7 @@ (batch:try-command parms str)) ((< (length fodder) 2) (slib:warn 'batch:try-chopped-command "can't fit in " line-limit - (cons proc (append args-but-last (list fodder)))) + (append args-but-last (list fodder))) #f) (else (let ((hlen (quotient (length fodder) 2))) (and (loop (last fodder hlen)) @@ -74,15 +80,15 @@ (define (batch:glued-line parms strings) (case (batch:dialect parms) ((vms) (apply string-join " " "$" strings)) - ((unix dos amigados system *unknown*) (apply string-join " " strings)) + ((unix dos amigaos system *unknown*) (apply string-join " " strings)) (else #f))) - +;@ (define (batch:try-command parms . strings) (set! strings (batch:flatten strings)) (let ((line (batch:glued-line parms strings))) (and line (case (batch:dialect parms) - ((unix dos vms amigados) (batch-line parms line)) + ((unix dos vms amigaos) (batch-line parms line)) ((system) (let ((port (batch:port parms))) (write `(system ,line) port) (newline port) @@ -91,11 +97,11 @@ (let ((port (batch:port parms))) (write `(system ,line) port) (newline port) #t)) (else #f))))) - +;@ (define (batch:command parms . strings) (cond ((apply batch:try-command parms strings)) (else (slib:error 'batch:command 'failed strings)))) - +;@ (define (batch:run-script parms name . strings) (case (batch:dialect parms strings) ((vms) (batch:command parms (string-append "@" name) strings)) @@ -106,12 +112,12 @@ ((unix) (write-batch-line (string-append "# " line) #f port)) ((dos) (write-batch-line (string-append "rem " line) #f port)) ((vms) (write-batch-line (string-append "$! " line) #f port)) - ((amigados) (write-batch-line (string-append "; " line) #f port)) + ((amigaos) (write-batch-line (string-append "; " line) #f port)) ((system) (write-batch-line (string-append "; " line) #f port)) ((*unknown*) (write-batch-line (string-append ";;; " line) #f port) ;;(newline port) #f))) - +;@ (define (batch:comment parms . lines) (define port (batch:port parms)) (define dialect (batch:dialect parms)) @@ -119,7 +125,7 @@ (every (lambda (line) (batch:write-comment-line dialect line port)) lines)) - +;@ (define (batch:lines->file parms file . lines) (define port (batch:port parms)) (set! lines (batch:flatten lines)) @@ -142,7 +148,7 @@ (every (lambda (string) (batch-line parms string)) lines) (batch-line parms (string-append "$EOD")))) - ((amigados) (batch-line parms (string-append "delete force " file)) + ((amigaos) (batch-line parms (string-append "delete force " file)) (every (lambda (str) (letrec ((star-quote @@ -162,7 +168,6 @@ lines)) ((system) (write `(delete-file ,file) port) (newline port) (delete-file file) - (require 'pretty-print) (pretty-print `(call-with-output-file ,file (lambda (fp) (for-each @@ -175,7 +180,6 @@ #t) ((*unknown*) (write `(delete-file ,file) port) (newline port) - (require 'pretty-print) (pretty-print `(call-with-output-file ,file (lambda (fp) @@ -185,7 +189,7 @@ ,lines))) port) #f))) - +;@ (define (batch:delete-file parms file) (define port (batch:port parms)) (case (batch:dialect parms) @@ -195,13 +199,13 @@ #t) ((vms) (batch-line parms (string-append "$DELETE " file)) #t) - ((amigados) (batch-line parms (string-append "delete force " file)) + ((amigaos) (batch-line parms (string-append "delete force " file)) #t) ((system) (write `(delete-file ,file) port) (newline port) (delete-file file)) ; SLIB provides ((*unknown*) (write `(delete-file ,file) port) (newline port) #f))) - +;@ (define (batch:rename-file parms old-name new-name) (define port (batch:port parms)) (case (batch:dialect parms) @@ -209,15 +213,18 @@ ;;((dos) (batch-line parms (string-join " " "REN" old-name new-name))) ((dos) (batch-line parms (string-join " " "MOVE" "/Y" old-name new-name))) ((vms) (batch-line parms (string-join " " "$RENAME" old-name new-name))) - ((amigados) (batch-line parms (string-join " " "failat 21")) - (batch-line parms (string-join " " "delete force" new-name)) - (batch-line parms (string-join " " "rename" old-name new-name))) + ((amigaos) (batch-line parms (string-join " " "failat 21")) + (batch-line parms (string-join " " "delete force" new-name)) + (batch-line parms (string-join " " "rename" old-name new-name))) ((system) (batch:extender 'rename-file batch:rename-file)) ((*unknown*) (write `(rename-file ,old-name ,new-name) port) (newline port) #f))) -(define (batch:write-header-comment dialect name port) +(define (batch:write-header-comment parms name port) + (define dialect (batch:dialect parms)) + (define operating-system + (or (batch:operating-system parms) *operating-system*)) (batch:write-comment-line dialect (string-append (if (string? name) @@ -228,6 +235,7 @@ ((dos) "DOS") ((default-for-platform) "??") (else (symbol->string dialect)))) + " (" (symbol->string operating-system) ")" " script created by SLIB/batch " (cond ((provided? 'bignum) (require 'posix-time) @@ -235,9 +243,11 @@ (substring ct 0 (+ -1 (string-length ct))))) (else ""))) port)) - +;@ (define (batch:call-with-output-script parms name proc) (define dialect (batch:dialect parms)) + (define operating-system + (or (batch:operating-system parms) *operating-system*)) (case dialect ((unix) ((cond ((and (string? name) (provided? 'system)) (lambda (proc) @@ -247,8 +257,11 @@ ((output-port? name) (lambda (proc) (proc name))) (else (lambda (proc) (proc (current-output-port))))) (lambda (port) - (write-line "#!/bin/sh" port) - (batch:write-header-comment dialect name port) + (write-line (if (eq? 'plan9 operating-system) + "#! /bin/rc" + "#! /bin/sh") + port) + (batch:write-header-comment parms name port) (proc port)))) ((dos) ((cond ((string? name) @@ -257,7 +270,7 @@ ((output-port? name) (lambda (proc) (proc name))) (else (lambda (proc) (proc (current-output-port))))) (lambda (port) - (batch:write-header-comment dialect name port) + (batch:write-header-comment parms name port) (proc port)))) ((vms) ((cond ((string? name) @@ -266,20 +279,20 @@ ((output-port? name) (lambda (proc) (proc name))) (else (lambda (proc) (proc (current-output-port))))) (lambda (port) - (batch:write-header-comment dialect name port) + (batch:write-header-comment parms name port) ;;(write-line "$DEFINE/USER SYS$OUTPUT BUILD.LOG" port) (proc port)))) - ((amigados) ((cond ((and (string? name) (provided? 'system)) - (lambda (proc) - (let ((ans (call-with-output-file name proc))) - (system (string-append "protect " name " rswd")) - ans))) - ((output-port? name) (lambda (proc) (proc name))) - (else (lambda (proc) (proc (current-output-port))))) - (lambda (port) - (batch:write-header-comment dialect name port) - (proc port)))) + ((amigaos) ((cond ((and (string? name) (provided? 'system)) + (lambda (proc) + (let ((ans (call-with-output-file name proc))) + (system (string-append "protect " name " rswd")) + ans))) + ((output-port? name) (lambda (proc) (proc name))) + (else (lambda (proc) (proc (current-output-port))))) + (lambda (port) + (batch:write-header-comment parms name port) + (proc port)))) ((system) ((cond ((and (string? name) (provided? 'system)) (lambda (proc) @@ -290,7 +303,7 @@ ((output-port? name) (lambda (proc) (proc name))) (else (lambda (proc) (proc (current-output-port))))) (lambda (port) - (batch:write-header-comment dialect name port) + (batch:write-header-comment parms name port) (proc port)))) ((*unknown*) ((cond ((and (string? name) (provided? 'system)) @@ -302,7 +315,7 @@ ((output-port? name) (lambda (proc) (proc name))) (else (lambda (proc) (proc (current-output-port))))) (lambda (port) - (batch:write-header-comment dialect name port) + (batch:write-header-comment parms name port) (proc port)))))) ;;; This little ditty figures out how to use a Scheme extension or @@ -321,8 +334,9 @@ (else (let ((pl (make-parameter-list (map car parms)))) (adjoin-parameters! - pl (cons 'batch-dialect (os->batch-dialect - (parameter-list-ref parms 'platform)))) + pl (cons 'batch-dialect + (os->batch-dialect + (parameter-list-ref parms 'operating-system)))) (system (call-with-output-string (lambda (port) @@ -332,7 +346,7 @@ (define new-parms (copy-tree pl)) (adjoin-parameters! new-parms (list 'batch-port batch-port)) (apply BATCHER new-parms args))))))))))) - +;@ (define (truncate-up-to str chars) (define (tut str) (do ((i (string-length str) (+ -1 i))) @@ -341,15 +355,15 @@ (cond ((char? chars) (set! chars (list chars))) ((string? chars) (set! chars (string->list chars)))) (if (string? str) (tut str) (map tut str))) - +;@ (define (must-be-first firsts lst) (append (remove-if-not (lambda (i) (member i lst)) firsts) (remove-if (lambda (i) (member i firsts)) lst))) - +;@ (define (must-be-last lst lasts) (append (remove-if (lambda (i) (member i lasts)) lst) (remove-if-not (lambda (i) (member i lst)) lasts))) - +;@ (define (string-join joiner . args) (if (null? args) "" (apply string-append @@ -369,21 +383,15 @@ obj "in" strings)))) strings))) -(define batch:platform (software-type)) -(cond ((and (eq? 'unix batch:platform) (provided? 'system)) - (let ((file-name (tmpnam))) - (system (string-append "uname > " file-name)) - (set! batch:platform (call-with-input-file file-name read)) - (delete-file file-name)))) - (define batch:database #f) -(define os->batch-dialect #f) (define batch-dialect->line-length-limit #f) +;@ +(define os->batch-dialect #f) (define (batch:line-length-limit parms) (let ((bl (parameter-list-ref parms 'batch-line-length-limit))) (if bl (car bl) (batch-dialect->line-length-limit (batch:dialect parms))))) - +;@ (define (batch:initialize! database) (set! batch:database database) (define-tables database @@ -394,7 +402,7 @@ ((unix 1023) (dos 127) (vms 1023) - (amigados 511) + (amigaos 511) (system 1023) (*unknown* -1))) @@ -406,7 +414,7 @@ (acorn *unknown*) (aix unix) (alliant *unknown*) - (amiga amigados) + (amiga amigaos) (apollo unix) (apple2 *unknown*) (arm *unknown*) @@ -415,6 +423,7 @@ (celerity *unknown*) (concurrent *unknown*) (convex *unknown*) + (darwin unix) (encore *unknown*) (harris *unknown*) (hp-ux unix) @@ -432,6 +441,7 @@ (novell *unknown*) (os/2 dos) (osf1 unix) + (plan9 unix) (prime *unknown*) (psion *unknown*) (pyramid *unknown*) @@ -445,10 +455,29 @@ (vms vms) ))) - ((database 'add-domain) '(operating-system operating-system #f symbol #f)) + (define-domains database '(operating-system operating-system #f symbol #f)) (set! os->batch-dialect (((batch:database 'open-table) 'operating-system #f) 'get 'os-family)) (set! batch-dialect->line-length-limit (((batch:database 'open-table) 'batch-dialect #f) 'get 'line-length-limit)) ) +;@ +(define *operating-system* + (cond ((and (eq? 'unix (software-type)) (provided? 'system)) + (let* ((file-name (tmpnam)) + (uname (and (system (string-append "uname > " file-name)) + (call-with-input-file file-name read))) + (ustr (and (symbol? uname) (symbol->string uname)))) + (delete-file file-name) + (cond ((and ustr + (> (string-length ustr) 5) + (string-ci=? "cygwin" (substring ustr 0 6))) + 'gnu-win32) + ((and ustr + (> (string-length ustr) 4) + (string-ci=? "mingw" (substring ustr 0 5))) + 'gnu-win32) + (ustr uname) + (else (software-type))))) + (else (software-type)))) diff --git a/bigloo.init b/bigloo.init index 41a4179..9ded1a4 100644 --- a/bigloo.init +++ b/bigloo.init @@ -7,34 +7,29 @@ ;;; (scheme-implementation-type) should return the name of the scheme ;;; implementation loading this file. - (define (scheme-implementation-type) 'Bigloo) ;;; (scheme-implementation-home-page) should return a (string) URI ;;; (Uniform Resource Identifier) for this scheme implementation's home ;;; page; or false if there isn't one. - (define (scheme-implementation-home-page) - "http://kaolin.unice.fr/~serrano/bigloo/bigloo.html") + "http://www-sop.inria.fr/mimosa/fp/Bigloo/") ;;; (scheme-implementation-version) should return a string describing ;;; the version the scheme implementation loading this file. - -(define (scheme-implementation-version) "2.0c") +(define (scheme-implementation-version) *bigloo-version*) ;;; (implementation-vicinity) should be defined to be the pathname of ;;; the directory where any auxillary files to your Scheme ;;; implementation reside. - (define (implementation-vicinity) (case (software-type) - ((UNIX) "/usr/local/lib/bigloo/") - ((VMS) "scheme$src:") - ((MS-DOS) "C:\\scheme\\"))) + ((UNIX) (string-append *default-lib-dir* "/")) + ((MS-DOS) "C:\\scheme\\") + (else ""))) ;;; (library-vicinity) should be defined to be the pathname of the ;;; directory where files of Scheme library functions reside. - (define library-vicinity (let ((library-path (or @@ -43,8 +38,11 @@ ;; Use this path if your scheme does not support GETENV ;; or if SCHEME_LIBRARY_PATH is not set. (case (software-type) - ((UNIX) "/usr/share/slib/") - ((VMS) "lib$scheme:") + ((UNIX) (cond ((directory? "/usr/share/slib/") + "/usr/share/slib/") + ((directory? "/usr/local/lib/slib/") + "/usr/local/lib/slib/") + (else ""))) ((MS-DOS) "C:\\SLIB\\") (else ""))))) (lambda () library-path))) @@ -52,15 +50,19 @@ ;;; (home-vicinity) should return the vicinity of the user's HOME ;;; directory, the directory which typically contains files which ;;; customize a computer environment for a user. - -(define home-vicinity - (let ((home-path (getenv "HOME"))) - (lambda () home-path))) +(define (home-vicinity) + (let ((home (getenv "HOME"))) + (and home + (case (software-type) + ((UNIX COHERENT MS-DOS) ;V7 unix has a / on HOME + (if (eqv? #\/ (string-ref home (+ -1 (string-length home)))) + home + (string-append home "/"))) + (else home))))) ;;; *FEATURES* should be set to a list of symbols describing features ;;; of this implementation. See Template.scm for the list of feature ;;; names. - (define *features* '( source ;can load scheme source files @@ -70,7 +72,7 @@ ;; Scheme report features -; rev5-report ;conforms to +; r5rs ;conforms to eval ;R5RS two-argument eval ; values ;R5RS multiple values ; dynamic-wind ;R5RS dynamic-wind @@ -84,11 +86,11 @@ ;STRING-FILL!, LIST->VECTOR, ;VECTOR->LIST, and VECTOR-FILL! - rev4-report ;conforms to + r4rs ;conforms to ieee-p1178 ;conforms to - rev3-report ;conforms to + r3rs ;conforms to ; rev2-procedures ;SUBSTRING-MOVE-LEFT!, ;SUBSTRING-MOVE-RIGHT!, @@ -99,7 +101,7 @@ multiarg/and- ;/ and - can take more than 2 args. with-file ;has WITH-INPUT-FROM-FILE and - ;WITH-OUTPUT-FROM-FILE + ;WITH-OUTPUT-TO-FILE transcript ;TRANSCRIPT-ON and TRANSCRIPT-OFF ieee-floating-point ;conforms to IEEE Standard 754-1985 ;IEEE Standard for Binary @@ -170,6 +172,37 @@ (close-input-port insp) res)) +(define (make-exchanger obj) + (lambda (rep) (let ((old obj)) (set! obj rep) old))) +(define (open-file filename modes) + (case modes + ((r rb) (open-input-file filename)) + ((w wb) (open-output-file filename)) + (else (slib:error 'open-file 'mode? modes)))) +;;(define (port? obj) (or (input-port? port) (output-port? port))) +(define (call-with-open-ports . ports) + (define proc (car ports)) + (cond ((procedure? proc) (set! ports (cdr ports))) + (else (set! ports (reverse ports)) + (set! proc (car ports)) + (set! ports (reverse (cdr ports))))) + (let ((ans (apply proc ports))) + (for-each close-port ports) + ans)) +(define (close-port port) + (cond ((input-port? port) + (close-input-port port) + (if (output-port? port) (close-output-port port))) + ((output-port? port) (close-output-port port)) + (else (slib:error 'close-port 'port? port)))) + +(define (browse-url url) + (define (try cmd end) (zero? (system (string-append cmd url end)))) + (or (try "netscape-remote -remote 'openURL(" ")'") + (try "netscape -remote 'openURL(" ")'") + (try "netscape '" "'&") + (try "netscape '" "'"))) + ;;; "rationalize" adjunct procedures. (define (find-ratio x e) (let ((rat (rationalize x e))) @@ -216,7 +249,7 @@ (let ((cep (current-error-port))) (if (provided? 'trace) (print-call-stack cep)) (display "Warn: " cep) - (for-each (lambda (x) (display x cep)) args)))) + (for-each (lambda (x) (display #\ cep) (write x cep)) args)))) ;;; define an error procedure for the library @@ -238,7 +271,7 @@ )) -(define (promise:force p) (force p)) +;;(define force force) ;;; Define these if your implementation's syntax can support it and if ;;; they are not already defined. @@ -262,17 +295,14 @@ ;;; (SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever ;;; suffix all the module files in SLIB have. See feature 'SOURCE. - (define (slib:load-source f) (loadq (string-append f (scheme-file-suffix)))) ;;; (SLIB:LOAD-COMPILED "foo") should load the file that was produced ;;; by compiling "foo.scm" if this implementation can compile files. ;;; See feature 'COMPILED. - (define slib:load-compiled loadq) ;;; At this point SLIB:LOAD must be able to load SLIB files. - (define slib:load slib:load-source) (define defmacro:eval slib:eval) @@ -1,5 +1,5 @@ ;;;; "break.scm" Breakpoints for debugging in Scheme. -;;; Copyright (C) 1991, 1992, 1993, 1995 Aubrey Jaffer +;;; Copyright (C) 1991, 1992, 1993, 1995, 2003 Aubrey Jaffer ; ;Permission to copy this software, to modify it, to redistribute it, ;to distribute modified versions, and to use it for any purpose is @@ -8,7 +8,7 @@ ;1. Any copy made of this software must include this copyright notice ;in full. ; -;2. I have made no warrantee or representation that the operation of +;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; @@ -18,6 +18,7 @@ ;each case. (require 'qp) +(require 'alist) ;;;; BREAKPOINTS @@ -29,8 +30,8 @@ ;;; of breakpoint:continuation-stack and returns #f to it. (define breakpoint:continuation-stack '()) - -(define debug:breakpoint +;@ +(define breakpoint (let ((call-with-current-continuation call-with-current-continuation) (apply apply) (qpn qpn) (cons cons) (length length)) @@ -45,8 +46,8 @@ (debug:top-continuation (length breakpoint:continuation-stack)))))) (cond ((not (eq? ans breakpoint:continuation-stack)) ans)))))) - -(define debug:continue +;@ +(define continue (let ((null? null?) (car car) (cdr cdr)) (lambda args (cond ((null? breakpoint:continuation-stack) @@ -63,21 +64,17 @@ (if (provided? 'abort) (lambda (val) (display val) (newline) (abort)) (begin (display "; type (init-debug)") #f))) - +;@ (define (init-debug) (call-with-current-continuation (lambda (x) (set! debug:top-continuation x)))) - -(define breakpoint debug:breakpoint) -(define bkpt debug:breakpoint) -(define continue debug:continue) - +;@ (define breakf (let ((null? null?) ;These bindings are so that (not not) ;breakf will not break on parts (car car) (cdr cdr) ;of itself. (eq? eq?) (+ +) (zero? zero?) (modulo modulo) - (apply apply) (display display) (breakpoint debug:breakpoint)) + (apply apply) (display display) (breakpoint breakpoint)) (lambda (function . optname) ;; (set! trace:indent 0) (let ((name (if (null? optname) function (car optname)))) @@ -92,7 +89,7 @@ ;;; the reason I use a symbol for debug:unbreak-object is so ;;; that functions can still be unbreaked if this file is read in twice. - +;@ (define (unbreakf function) ;; (set! trace:indent 0) (function 'debug:unbreak-object)) @@ -101,7 +98,6 @@ ;;; niceties like keeping track of breakd functions and dealing with ;;; redefinition. -(require 'alist) (define break:adder (alist-associator eq?)) (define break:deler (alist-remover eq?)) @@ -131,9 +127,8 @@ ((eq? (cdr p) fun) (unbreakf fun)) (else fun)))) - ;;;; Finally, the macros break and unbreak - +;@ (defmacro break xs (if (null? xs) `(begin ,@(map (lambda (x) `(set! ,x (break:breakf ,x ',x))) @@ -1,15 +1,219 @@ ;;; "byte.scm" small integers, not necessarily chars. +; Copyright (c) 2001, 2002, 2003 Aubrey Jaffer +; +;Permission to copy this software, to modify it, to redistribute it, +;to distribute modified versions, and to use it for any purpose is +;granted, subject to the following restrictions and understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warranty or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. -(define (byte-ref str ind) (char->integer (string-ref str ind))) -(define (byte-set! str ind val) (string-set! str ind (integer->char val))) +;;@code{(require 'byte)} +;;@ftindex byte +;; +;;@noindent +;;Some algorithms are expressed in terms of arrays of small integers. +;;Using Scheme strings to implement these arrays is not portable vis-a-vis +;;the correspondence between integers and characters and non-ascii +;;character sets. These functions abstract the notion of a @dfn{byte}. +;;@cindex byte + +;;@body +;;@2 must be a valid index of @1. @0 returns byte @2 of @1 using +;;zero-origin indexing. +(define (byte-ref bytes k) (char->integer (string-ref bytes k))) + +;;@body +;;@2 must be a valid index of @1, and @var{byte} must be a small +;;nonnegative integer. @0 stores @var{byte} in element @2 of @1 and +;;returns an unspecified value. @c <!> +(define (byte-set! bytes k byte) (string-set! bytes k (integer->char byte))) + +;;@args k byte +;;@args k +;;@0 returns a newly allocated byte-array of length @1. If @2 is +;;given, then all elements of the byte-array are initialized to @2, +;;otherwise the contents of the byte-array are unspecified. (define (make-bytes len . opt) (if (null? opt) (make-string len) (make-string len (integer->char (car opt))))) + +;;@args bytes +;;@0 returns length of byte-array @1. (define bytes-length string-length) + +;;@args byte @dots{} +;;Returns a newly allocated byte-array composed of the small +;;nonnegative arguments. +(define (bytes . args) (list->bytes args)) + +;;@args bytes +;;@0 returns a newly allocated list of the bytes that make up the +;;given byte-array. +(define (bytes->list bts) (map char->integer (string->list bts))) + +;;@args bytes +;;@0 returns a newly allocated byte-array formed from the small +;;nonnegative integers in the list @1. +(define (list->bytes lst) (list->string (map integer->char lst))) + +;;@noindent +;;@code{Bytes->list} and @code{list->bytes} are inverses so far as +;;@code{equal?} is concerned. +;;@findex equal? + +;;@args bytes +;;Returns a newly allocated copy of the given @1. +(define bytes-copy string-copy) + +;;@body +;;Reverses the order of byte-array @1. +(define (bytes-reverse! bytes) + (do ((idx 0 (+ 1 idx)) + (xdi (+ -1 (bytes-length bytes)) (+ -1 xdi))) + ((>= idx xdi) bytes) + (let ((tmp (byte-ref bytes idx))) + (byte-set! bytes idx (byte-ref bytes xdi)) + (byte-set! bytes xdi tmp)))) + +;;@body +;;Returns a newly allocated bytes-array consisting of the elements of +;;@1 in reverse order. +(define (bytes-reverse bytes) + (bytes-reverse! (bytes-copy bytes))) + +;;@noindent +;;@cindex binary +;;Input and output of bytes should be with ports opened in @dfn{binary} +;;mode (@pxref{Input/Output}). Calling @code{open-file} with @r{'rb} or +;;@findex open-file +;;@r{'wb} modes argument will return a binary port if the Scheme +;;implementation supports it. + +;;@args byte port +;;@args byte +;;Writes the byte @1 (not an external representation of the byte) to +;;the given @2 and returns an unspecified value. The @2 argument may +;;be omitted, in which case it defaults to the value returned by +;;@code{current-output-port}. +;;@findex current-output-port (define (write-byte byt . opt) (apply write-char (integer->char byt) opt)) + +;;@args port +;;@args +;;Returns the next byte available from the input @1, updating the @1 +;;to point to the following byte. If no more bytes are available, an +;;end-of-file object is returned. @1 may be omitted, in which case it +;;defaults to the value returned by @code{current-input-port}. +;;@findex current-input-port (define (read-byte . opt) (let ((c (apply read-char opt))) (if (eof-object? c) c (char->integer c)))) -(define (bytes . args) (list->bytes args)) -(define (bytes->list bts) (map char->integer (string->list bts))) -(define (list->bytes lst) (list->string (map integer->char lst))) + +;;@noindent +;;When reading and writing binary numbers with @code{read-bytes} and +;;@code{write-bytes}, the sign of the length argument determines the +;;endianness (order) of bytes. Positive treats them as big-endian, +;;the first byte input or output is highest order. Negative treats +;;them as little-endian, the first byte input or output is the lowest +;;order. +;; +;;@noindent +;;Once read in, SLIB treats byte sequences as big-endian. The +;;multi-byte sequences produced and used by number conversion routines +;;@pxref{Byte/Number Conversions} are always big-endian. + +;;@args n port +;;@args n +;;@0 returns a newly allocated bytes-array filled with +;;@code{(abs @var{n})} bytes read from @2. If @1 is positive, then +;;the first byte read is stored at index 0; otherwise the last byte +;;read is stored at index 0. Note that the length of the returned +;;string will be less than @code{(abs @var{n})} if @2 reaches +;;end-of-file. +;; +;;@2 may be omitted, in which case it defaults to the value returned +;;by @code{current-input-port}. +(define (read-bytes n . port) + (let* ((len (abs n)) + (byts (make-bytes len)) + (cnt (if (positive? n) + (apply substring-read! byts 0 n port) + (apply substring-read! byts (- n) 0 port)))) + (if (= cnt len) + byts + (if (positive? n) + (substring byts 0 cnt) + (substring byts (- len cnt) len))))) + +;;@args bytes n port +;;@args bytes n +;;@0 writes @code{(abs @var{n})} bytes to output-port @3. If @2 is +;;positive, then the first byte written is index 0 of @1; otherwise +;;the last byte written is index 0 of @1. @0 returns an unspecified +;;value. +;; +;;@3 may be omitted, in which case it defaults to the value returned +;;by @code{current-output-port}. +(define (write-bytes bytes n . port) + (if (positive? n) + (apply substring-write bytes 0 n port) + (apply substring-write bytes (- n) 0 port))) + +;;@noindent +;;@code{substring-read!} and @code{substring-write} provide +;;lower-level procedures for reading and writing blocks of bytes. The +;;relative size of @var{start} and @var{end} determines the order of +;;writing. + +;;@args string start end port +;;@args string start end +;;Fills @1 with up to @code{(abs (- @var{start} @var{end}))} bytes +;;read from @4. The first byte read is stored at index @1. +;;@0 returns the number of bytes read. +;; +;;@4 may be omitted, in which case it defaults to the value returned +;;by @code{current-input-port}. +(define (substring-read! string start end . port) + (if (>= end start) + (do ((idx start (+ 1 idx))) + ((>= idx end) idx) + (let ((byt (apply read-byte port))) + (cond ((eof-object? byt) + (set! idx (+ -1 idx)) + (set! end idx)) + (else (byte-set! string idx byt))))) + (do ((idx (+ -1 start) (+ -1 idx)) + (cnt 0 (+ 1 cnt))) + ((< idx end) cnt) + (let ((byt (apply read-byte port))) + (cond ((eof-object? byt) + (set! idx start) + (set! cnt (+ -1 cnt))) + (else (byte-set! string idx byt))))))) + +;;@args string start end port +;;@args string start end +;;@0 writes @code{(abs (- @var{start} @var{end}))} bytes to +;;output-port @4. The first byte written is index @2 of @1. @0 +;;returns the number of bytes written. +;; +;;@4 may be omitted, in which case it defaults to the value returned +;;by @code{current-output-port}. +(define (substring-write string start end . port) + (if (>= end start) + (do ((idx start (+ 1 idx))) + ((>= idx end) (- end start)) + (apply write-byte (byte-ref string idx) port)) + (do ((idx (+ -1 start) (+ -1 idx))) + ((< idx end) (- start end)) + (apply write-byte (byte-ref string idx) port)))) diff --git a/byte.txi b/byte.txi new file mode 100644 index 0000000..01c725b --- /dev/null +++ b/byte.txi @@ -0,0 +1,179 @@ +@code{(require 'byte)} +@ftindex byte + +@noindent +Some algorithms are expressed in terms of arrays of small integers. +Using Scheme strings to implement these arrays is not portable vis-a-vis +the correspondence between integers and characters and non-ascii +character sets. These functions abstract the notion of a @dfn{byte}. +@cindex byte +@cindex byte + + +@defun byte-ref bytes k + +@var{k} must be a valid index of @var{bytes}. @code{byte-ref} returns byte @var{k} of @var{bytes} using +zero-origin indexing. +@end defun + +@deffn {Procedure} byte-set! bytes k byte + +@var{k} must be a valid index of @var{bytes}, and @var{byte} must be a small +nonnegative integer. @code{byte-set!} stores @var{byte} in element @var{k} of @var{bytes} and +returns an unspecified value. @c <!> +@end deffn + +@defun make-bytes k byte + + +@defunx make-bytes k +@code{make-bytes} returns a newly allocated byte-array of length @var{k}. If @var{byte} is +given, then all elements of the byte-array are initialized to @var{byte}, +otherwise the contents of the byte-array are unspecified. +@end defun + +@defun bytes-length bytes + +@code{bytes-length} returns length of byte-array @var{bytes}. +@end defun + +@defun bytes byte @dots{} + +Returns a newly allocated byte-array composed of the small +nonnegative arguments. +@end defun + +@defun bytes->list bytes + +@code{bytes->list} returns a newly allocated list of the bytes that make up the +given byte-array. +@end defun + +@defun list->bytes bytes + +@code{list->bytes} returns a newly allocated byte-array formed from the small +nonnegative integers in the list @var{bytes}. +@end defun +@noindent +@code{Bytes->list} and @code{list->bytes} are inverses so far as +@code{equal?} is concerned. +@findex equal? + + +@defun bytes-copy bytes + +Returns a newly allocated copy of the given @var{bytes}. +@end defun + +@deffn {Procedure} bytes-reverse! bytes + +Reverses the order of byte-array @var{bytes}. +@end deffn + +@defun bytes-reverse bytes + +Returns a newly allocated bytes-array consisting of the elements of +@var{bytes} in reverse order. +@end defun +@noindent +@cindex binary +Input and output of bytes should be with ports opened in @dfn{binary} +@cindex binary +mode (@pxref{Input/Output}). Calling @code{open-file} with @r{'rb} or +@findex open-file +@r{'wb} modes argument will return a binary port if the Scheme +implementation supports it. + + +@defun write-byte byte port + + +@defunx write-byte byte +Writes the byte @var{byte} (not an external representation of the byte) to +the given @var{port} and returns an unspecified value. The @var{port} argument may +be omitted, in which case it defaults to the value returned by +@code{current-output-port}. +@findex current-output-port +@end defun + +@defun read-byte port + + +@defunx read-byte +Returns the next byte available from the input @var{port}, updating the @var{port} +to point to the following byte. If no more bytes are available, an +end-of-file object is returned. @var{port} may be omitted, in which case it +defaults to the value returned by @code{current-input-port}. +@findex current-input-port +@end defun +@noindent +When reading and writing binary numbers with @code{read-bytes} and +@code{write-bytes}, the sign of the length argument determines the +endianness (order) of bytes. Positive treats them as big-endian, +the first byte input or output is highest order. Negative treats +them as little-endian, the first byte input or output is the lowest +order. + +@noindent +Once read in, SLIB treats byte sequences as big-endian. The +multi-byte sequences produced and used by number conversion routines +@pxref{Byte/Number Conversions} are always big-endian. + + +@defun read-bytes n port + + +@defunx read-bytes n +@code{read-bytes} returns a newly allocated bytes-array filled with +@code{(abs @var{n})} bytes read from @var{port}. If @var{n} is positive, then +the first byte read is stored at index 0; otherwise the last byte +read is stored at index 0. Note that the length of the returned +string will be less than @code{(abs @var{n})} if @var{port} reaches +end-of-file. + +@var{port} may be omitted, in which case it defaults to the value returned +by @code{current-input-port}. +@end defun + +@defun write-bytes bytes n port + + +@defunx write-bytes bytes n +@code{write-bytes} writes @code{(abs @var{n})} bytes to output-port @var{port}. If @var{n} is +positive, then the first byte written is index 0 of @var{bytes}; otherwise +the last byte written is index 0 of @var{bytes}. @code{write-bytes} returns an unspecified +value. + +@var{port} may be omitted, in which case it defaults to the value returned +by @code{current-output-port}. +@end defun +@noindent +@code{substring-read!} and @code{substring-write} provide +lower-level procedures for reading and writing blocks of bytes. The +relative size of @var{start} and @var{end} determines the order of +writing. + + +@deffn {Procedure} substring-read! string start end port + + +@deffnx {Procedure} substring-read! string start end +Fills @var{string} with up to @code{(abs (- @var{start} @var{end}))} bytes +read from @var{port}. The first byte read is stored at index @var{string}. +@code{substring-read!} returns the number of bytes read. + +@var{port} may be omitted, in which case it defaults to the value returned +by @code{current-input-port}. +@end deffn + +@defun substring-write string start end port + + +@defunx substring-write string start end +@code{substring-write} writes @code{(abs (- @var{start} @var{end}))} bytes to +output-port @var{port}. The first byte written is index @var{start} of @var{string}. @code{substring-write} +returns the number of bytes written. + +@var{port} may be omitted, in which case it defaults to the value returned +by @code{current-output-port}. +@end defun diff --git a/bytenumb.scm b/bytenumb.scm new file mode 100644 index 0000000..68ee748 --- /dev/null +++ b/bytenumb.scm @@ -0,0 +1,346 @@ +;;; "bytenumb.scm" Byte integer and IEEE floating-point conversions. +; Copyright (c) 2003 Aubrey Jaffer +; +;Permission to copy this software, to modify it, to redistribute it, +;to distribute modified versions, and to use it for any purpose is +;granted, subject to the following restrictions and understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warranty or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +(require 'byte) +(require 'logical) + +(define bn:expt + (if (provided? 'inexact) expt + (lambda (n k) (if (negative? k) 0 (integer-expt n k))))) + +;;@code{(require 'byte-number)} +;;@ftindex byte-number + +;;@noindent +;;The multi-byte sequences produced and used by numeric conversion +;;routines are always big-endian. Endianness can be changed during +;;reading and writing bytes using @code{read-bytes} and +;;@code{write-bytes} @xref{Byte, read-bytes}. +;; +;;@noindent +;;The sign of the length argument to bytes/integer conversion +;;procedures determines the signedness of the number. + +;;@body +;;Converts the first @code{(abs @var{n})} bytes of big-endian @1 array +;;to an integer. If @2 is negative then the integer coded by the +;;bytes are treated as two's-complement (can be negative). +;; +;;@example +;;(bytes->integer (bytes 0 0 0 15) -4) @result{} 15 +;;(bytes->integer (bytes 0 0 0 15) 4) @result{} 15 +;;(bytes->integer (bytes 255 255 255 255) -4) @result{} -1 +;;(bytes->integer (bytes 255 255 255 255) 4) @result{} 4294967295 +;;(bytes->integer (bytes 128 0 0 0) -4) @result{} -2147483648 +;;(bytes->integer (bytes 128 0 0 0) 4) @result{} 2147483648 +;;@end example +(define (bytes->integer bytes n) + (define cnt (abs n)) + (cond ((zero? n) 0) + ((and (negative? n) (> (byte-ref bytes 0) 127)) + (do ((lng (- 255 (byte-ref bytes 0)) + (+ (- 255 (byte-ref bytes idx)) (* 256 lng))) + (idx 1 (+ 1 idx))) + ((>= idx cnt) (- -1 lng)))) + (else + (do ((lng (byte-ref bytes 0) + (+ (byte-ref bytes idx) (* 256 lng))) + (idx 1 (+ 1 idx))) + ((>= idx cnt) lng))))) + +;;@body +;;Converts the integer @1 to a byte-array of @code{(abs @var{n})} +;;bytes. If @1 and @2 are both negative, then the bytes in the +;;returned array are coded two's-complement. +;; +;;@example +;;(bytes->list (integer->bytes 15 -4)) @result{} (0 0 0 15) +;;(bytes->list (integer->bytes 15 4)) @result{} (0 0 0 15) +;;(bytes->list (integer->bytes -1 -4)) @result{} (255 255 255 255) +;;(bytes->list (integer->bytes 4294967295 4)) @result{} (255 255 255 255) +;;(bytes->list (integer->bytes -2147483648 -4)) @result{} (128 0 0 0) +;;(bytes->list (integer->bytes 2147483648 4)) @result{} (128 0 0 0) +;;@end example +(define (integer->bytes n len) + (define bytes (make-bytes (abs len))) + (cond ((and (negative? n) (negative? len)) + (do ((idx (+ -1 (abs len)) (+ -1 idx)) + (res (- -1 n) (quotient res 256))) + ((negative? idx) bytes) + (byte-set! bytes idx (- 255 (modulo res 256))))) + (else + (do ((idx (+ -1 (abs len)) (+ -1 idx)) + (res n (quotient res 256))) + ((negative? idx) bytes) + (byte-set! bytes idx (modulo res 256)))))) + +;;@body +;;@1 must be a 4-element byte-array. @0 calculates and returns the +;;value of @1 interpreted as a big-endian IEEE 4-byte (32-bit) number. +(define (bytes->ieee-float bytes) + (define zero (or (string->number "0.0") 0)) + (define one (or (string->number "1.0") 1)) + (define len (bytes-length bytes)) + (define S (logbit? 7 (byte-ref bytes 0))) + (define E (+ (ash (logand #x7F (byte-ref bytes 0)) 1) + (ash (logand #x80 (byte-ref bytes 1)) -7))) + (if (not (eqv? 4 len)) + (slib:error 'bytes->ieee-float 'wrong 'length len)) + (do ((F (byte-ref bytes (+ -1 len)) + (+ (byte-ref bytes idx) (/ F 256))) + (idx (+ -2 len) (+ -1 idx))) + ((<= idx 1) + (set! F (/ (+ (logand #x7F (byte-ref bytes 1)) (/ F 256)) 128)) + (cond ((< 0 E 255) (* (if S -1 1) (bn:expt 2 (- E 127)) (+ 1 F))) + ((zero? E) + (if (zero? F) + (if S (- zero) zero) + (* (if S -1 1) (expt 2 -126) F))) + ;; E must be 255 + ((not (zero? F)) (/ zero zero)) + (else (/ (if S (- one) one) zero)))))) + +;; S EEEEEEE E FFFFFFF FFFFFFFF FFFFFFFF +;; ========= ========= ======== ======== +;; 0 1 8 9 31 + +;;@example +;;(bytes->ieee-float (bytes #x40 0 0 0)) @result{} 2.0 +;;(bytes->ieee-float (bytes #x40 #xd0 0 0)) @result{} 6.5 +;;(bytes->ieee-float (bytes #xc0 #xd0 0 0)) @result{} -6.5 +;; +;;(bytes->ieee-float (bytes 0 #x80 0 0)) @result{} 11.754943508222875e-39 +;;(bytes->ieee-float (bytes 0 #x40 0 0)) @result{} 5.877471754111437e-39 +;;(bytes->ieee-float (bytes 0 0 0 1)) @result{} 1.401298464324817e-45 +;; +;;(bytes->ieee-float (bytes #xff #x80 0 0)) @result{} -1/0 +;;(bytes->ieee-float (bytes #x7f #x80 0 0)) @result{} 1/0 +;;(bytes->ieee-float (bytes #x7f #x80 0 1)) @result{} 0/0 +;;@end example + +;;@body +;;@1 must be a 8-element byte-array. @0 calculates and returns the +;;value of @1 interpreted as a big-endian IEEE 8-byte (64-bit) number. +(define (bytes->ieee-double bytes) + (define zero (or (string->number "0.0") 0)) + (define one (or (string->number "1.0") 1)) + (define len (bytes-length bytes)) + (define S (logbit? 7 (byte-ref bytes 0))) + (define E (+ (ash (logand #x7F (byte-ref bytes 0)) 4) + (ash (logand #xF0 (byte-ref bytes 1)) -4))) + (if (not (eqv? 8 len)) + (slib:error 'bytes->ieee-double 'wrong 'length len)) + (do ((F (byte-ref bytes (+ -1 len)) + (+ (byte-ref bytes idx) (/ F 256))) + (idx (+ -2 len) (+ -1 idx))) + ((<= idx 1) + (set! F (/ (+ (logand #x0F (byte-ref bytes 1)) (/ F 256)) 16)) + (cond ((< 0 E 2047) (* (if S -1 1) (bn:expt 2 (- E 1023)) (+ 1 F))) + ((zero? E) + (if (zero? F) + (if S (- zero) zero) + (* (if S -1 1) (expt 2 -1022) F))) + ;; E must be 2047 + ((not (zero? F)) (/ zero zero)) + (else (/ (if S (- one) one) zero)))))) + +;; S EEEEEEE EEEE FFFF FFFFFFFF FFFFFFFF FFFFFFFF FFFFFFFF FFFFFFFF FFFFFFFF +;; ========= ========= ======== ======== ======== ======== ======== ======== +;; 0 1 11 12 63 + +;;@example +;;(bytes->ieee-double (bytes 0 0 0 0 0 0 0 0)) @result{} 0.0 +;;(bytes->ieee-double (bytes #x40 0 0 0 0 0 0 0)) @result{} 2 +;;(bytes->ieee-double (bytes #x40 #x1A 0 0 0 0 0 0)) @result{} 6.5 +;;(bytes->ieee-double (bytes #xC0 #x1A 0 0 0 0 0 0)) @result{} -6.5 +;; +;;(bytes->ieee-double (bytes 0 8 0 0 0 0 0 0)) @result{} 11.125369292536006e-309 +;;(bytes->ieee-double (bytes 0 4 0 0 0 0 0 0)) @result{} 5.562684646268003e-309 +;;(bytes->ieee-double (bytes 0 0 0 0 0 0 0 1)) @result{} 4.0e-324 +;; +;;(bytes->ieee-double (bytes #xFF #xF0 0 0 0 0 0 0)) @result{} -1/0 +;;(bytes->ieee-double (bytes #x7F #xF0 0 0 0 0 0 0)) @result{} 1/0 +;;(bytes->ieee-double (bytes #x7F #xF8 0 0 0 0 0 0)) @result{} 0/0 +;;@end example + +;;@args x +;;Returns a 4-element byte-array encoding the IEEE single-precision +;;floating-point of @1. +(define ieee-float->bytes + (let ((zero (or (string->number "0.0") 0)) + (exactify (if (provided? 'inexact) inexact->exact identity))) + (lambda (flt) + (define byts (make-bytes 4 0)) + (define S (negative? flt)) + (define (scale flt scl) + (cond ((zero? scl) (out (/ flt 2) scl)) + ((zero? flt) byts) + ((>= flt 16) + (let ((flt/16 (/ flt 16))) + (cond ((= flt/16 flt) + (byte-set! byts 0 (if S #xFF #x7F)) + (byte-set! byts 1 (if (= flt (* zero flt)) #xC0 #x80)) + byts) + (else (scale flt/16 (+ scl 4)))))) + ((>= flt 2) (scale (/ flt 2) (+ scl 1))) + ((and (>= scl 4) + (< (* 16 flt) 1)) (scale (* flt 16) (+ scl -4))) + ((< flt 1) (scale (* flt 2) (+ scl -1))) + (else (out (+ -1 flt) scl)))) + (define (out flt scl) + (do ((flt (* 128 flt) (* 256 (- flt val))) + (val (exactify (floor (* 128 flt))) + (exactify (floor (* 256 (- flt val))))) + (idx 1 (+ 1 idx))) + ((> idx 3) + (byte-set! byts 1 (bitwise-if #x80 (ash scl 7) (byte-ref byts 1))) + (byte-set! byts 0 (+ (if S 128 0) (ash scl -1))) + byts) + (byte-set! byts idx val))) + (scale (abs flt) 127)))) +;;@example +;;(bytes->list (ieee-float->bytes 2.0)) @result{} (64 0 0 0) +;;(bytes->list (ieee-float->bytes 6.5)) @result{} (64 208 0 0) +;;(bytes->list (ieee-float->bytes -6.5)) @result{} (192 208 0 0) +;; +;;(bytes->list (ieee-float->bytes 11.754943508222875e-39)) @result{} ( 0 128 0 0) +;;(bytes->list (ieee-float->bytes 5.877471754111438e-39)) @result{} ( 0 64 0 0) +;;(bytes->list (ieee-float->bytes 1.401298464324817e-45)) @result{} ( 0 0 0 1) +;; +;;(bytes->list (ieee-float->bytes -1/0)) @result{} (255 128 0 0) +;;(bytes->list (ieee-float->bytes 1/0)) @result{} (127 128 0 0) +;;(bytes->list (ieee-float->bytes 0/0)) @result{} (127 128 0 1) +;;@end example + + +;;@args x +;;Returns a 8-element byte-array encoding the IEEE double-precision +;;floating-point of @1. +(define ieee-double->bytes + (let ((zero (or (string->number "0.0") 0)) + (exactify (if (provided? 'inexact) inexact->exact identity))) + (lambda (flt) + (define byts (make-bytes 8 0)) + (define S (negative? flt)) + (define (scale flt scl) + (cond ((zero? scl) (out (/ flt 2) scl)) + ((zero? flt) byts) + ((>= flt 16) + (let ((flt/16 (/ flt 16))) + (cond ((= flt/16 flt) + (byte-set! byts 0 (if S #xFF #x7F)) + (byte-set! byts 1 (if (= flt (* zero flt)) #xF8 #xF0)) + byts) + (else (scale flt/16 (+ scl 4)))))) + ((>= flt 2) (scale (/ flt 2) (+ scl 1))) + ((and (>= scl 4) + (< (* 16 flt) 1)) (scale (* flt 16) (+ scl -4))) + ((< flt 1) (scale (* flt 2) (+ scl -1))) + (else (out (+ -1 flt) scl)))) + (define (out flt scl) + (do ((flt (* 16 flt) (* 256 (- flt val))) + (val (exactify (floor (* 16 flt))) + (exactify (floor (* 256 (- flt val))))) + (idx 1 (+ 1 idx))) + ((> idx 7) + (byte-set! byts 1 (bitwise-if #xF0 (ash scl 4) (byte-ref byts 1))) + (byte-set! byts 0 (+ (if S 128 0) (ash scl -4))) + byts) + (byte-set! byts idx val))) + (scale (abs flt) 1023)))) +;;@example +;;(bytes->list (ieee-double->bytes 2.0)) @result{} (64 0 0 0 0 0 0 0) +;;(bytes->list (ieee-double->bytes 6.5)) @result{} (64 26 0 0 0 0 0 0) +;;(bytes->list (ieee-double->bytes -6.5)) @result{} (192 26 0 0 0 0 0 0) +;; +;;(bytes->list (ieee-double->bytes 11.125369292536006e-309)) +;; @result{} ( 0 8 0 0 0 0 0 0) +;;(bytes->list (ieee-double->bytes 5.562684646268003e-309)) +;; @result{} ( 0 4 0 0 0 0 0 0) +;;(bytes->list (ieee-double->bytes 4.0e-324)) +;; @result{} ( 0 0 0 0 0 0 0 1) +;; +;;(bytes->list (ieee-double->bytes -1/0)) @result{} (255 240 0 0 0 0 0 0) +;;(bytes->list (ieee-double->bytes 1/0)) @result{} (127 240 0 0 0 0 0 0) +;;(bytes->list (ieee-double->bytes 0/0)) @result{} (127 248 0 0 0 0 0 0) +;;@end example + +;;@subsubheading Byte Collation Order +;; +;;@noindent +;;The @code{string<?} ordering of big-endian byte-array +;;representations of fixed and IEEE floating-point numbers agrees with +;;the numerical ordering only when those numbers are non-negative. +;; +;;@noindent +;;Straighforward modification of these formats can extend the +;;byte-collating order to work for their entire ranges. This +;;agreement enables the full range of numbers as keys in +;;@dfn{indexed-sequential-access-method} databases. + +;;@body +;;Modifies sign bit of @1 so that @code{string<?} ordering of +;;two's-complement byte-vectors matches numerical order. @0 returns +;;@1 and is its own functional inverse. +(define (integer-byte-collate! byte-vector) + (byte-set! byte-vector 0 (logxor #x80 (byte-ref byte-vector 0))) + byte-vector) + +;;@body +;;Returns copy of @1 with sign bit modified so that @code{string<?} +;;ordering of two's-complement byte-vectors matches numerical order. +;;@0 is its own functional inverse. +(define (integer-byte-collate byte-vector) + (integer-byte-collate! (bytes-copy byte-vector))) + +;;@body +;;Modifies @1 so that @code{string<?} ordering of IEEE floating-point +;;byte-vectors matches numerical order. @0 returns @1. +(define (IEEE-byte-collate! byte-vector) + (cond ((logtest #x80 (byte-ref byte-vector 0)) + (do ((idx (+ -1 (bytes-length byte-vector)) (+ -1 idx))) + ((negative? idx)) + (byte-set! byte-vector idx + (logxor #xFF (byte-ref byte-vector idx))))) + (else + (byte-set! byte-vector 0 (logxor #x80 (byte-ref byte-vector 0))))) + byte-vector) +;;@body +;;Given @1 modified by @code{IEEE-byte-collate!}, reverses the @1 +;;modifications. +(define (IEEE-byte-decollate! byte-vector) + (cond ((not (logtest #x80 (byte-ref byte-vector 0))) + (do ((idx (+ -1 (bytes-length byte-vector)) (+ -1 idx))) + ((negative? idx)) + (byte-set! byte-vector idx + (logxor #xFF (byte-ref byte-vector idx))))) + (else + (byte-set! byte-vector 0 (logxor #x80 (byte-ref byte-vector 0))))) + byte-vector) + +;;@body +;;Returns copy of @1 encoded so that @code{string<?} ordering of IEEE +;;floating-point byte-vectors matches numerical order. +(define (IEEE-byte-collate byte-vector) + (IEEE-byte-collate! (bytes-copy byte-vector))) +;;@body +;;Given @1 returned by @code{IEEE-byte-collate}, reverses the @1 +;;modifications. +(define (IEEE-byte-decollate byte-vector) + (IEEE-byte-decollate! (bytes-copy byte-vector))) diff --git a/bytenumb.txi b/bytenumb.txi new file mode 100644 index 0000000..67c340b --- /dev/null +++ b/bytenumb.txi @@ -0,0 +1,181 @@ +@code{(require 'byte-number)} +@ftindex byte-number + +@noindent +The multi-byte sequences produced and used by numeric conversion +routines are always big-endian. Endianness can be changed during +reading and writing bytes using @code{read-bytes} and +@code{write-bytes} @xref{Byte, read-bytes}. + +@noindent +The sign of the length argument to bytes/integer conversion +procedures determines the signedness of the number. + + +@defun bytes->integer bytes n + +Converts the first @code{(abs @var{n})} bytes of big-endian @var{bytes} array +to an integer. If @var{n} is negative then the integer coded by the +bytes are treated as two's-complement (can be negative). + +@example +(bytes->integer (bytes 0 0 0 15) -4) @result{} 15 +(bytes->integer (bytes 0 0 0 15) 4) @result{} 15 +(bytes->integer (bytes 255 255 255 255) -4) @result{} -1 +(bytes->integer (bytes 255 255 255 255) 4) @result{} 4294967295 +(bytes->integer (bytes 128 0 0 0) -4) @result{} -2147483648 +(bytes->integer (bytes 128 0 0 0) 4) @result{} 2147483648 +@end example +@end defun + +@defun integer->bytes n len + +Converts the integer @var{n} to a byte-array of @code{(abs @var{n})} +bytes. If @var{n} and @var{len} are both negative, then the bytes in the +returned array are coded two's-complement. + +@example +(bytes->list (integer->bytes 15 -4)) @result{} (0 0 0 15) +(bytes->list (integer->bytes 15 4)) @result{} (0 0 0 15) +(bytes->list (integer->bytes -1 -4)) @result{} (255 255 255 255) +(bytes->list (integer->bytes 4294967295 4)) @result{} (255 255 255 255) +(bytes->list (integer->bytes -2147483648 -4)) @result{} (128 0 0 0) +(bytes->list (integer->bytes 2147483648 4)) @result{} (128 0 0 0) +@end example +@end defun + +@defun bytes->ieee-float bytes + +@var{bytes} must be a 4-element byte-array. @code{bytes->ieee-float} calculates and returns the +value of @var{bytes} interpreted as a big-endian IEEE 4-byte (32-bit) number. +@end defun +@example +(bytes->ieee-float (bytes #x40 0 0 0)) @result{} 2.0 +(bytes->ieee-float (bytes #x40 #xd0 0 0)) @result{} 6.5 +(bytes->ieee-float (bytes #xc0 #xd0 0 0)) @result{} -6.5 + +(bytes->ieee-float (bytes 0 #x80 0 0)) @result{} 11.754943508222875e-39 +(bytes->ieee-float (bytes 0 #x40 0 0)) @result{} 5.877471754111437e-39 +(bytes->ieee-float (bytes 0 0 0 1)) @result{} 1.401298464324817e-45 + +(bytes->ieee-float (bytes #xff #x80 0 0)) @result{} -1/0 +(bytes->ieee-float (bytes #x7f #x80 0 0)) @result{} 1/0 +(bytes->ieee-float (bytes #x7f #x80 0 1)) @result{} 0/0 +@end example + + +@defun bytes->ieee-double bytes + +@var{bytes} must be a 8-element byte-array. @code{bytes->ieee-double} calculates and returns the +value of @var{bytes} interpreted as a big-endian IEEE 8-byte (64-bit) number. +@end defun +@example +(bytes->ieee-double (bytes 0 0 0 0 0 0 0 0)) @result{} 0.0 +(bytes->ieee-double (bytes #x40 0 0 0 0 0 0 0)) @result{} 2 +(bytes->ieee-double (bytes #x40 #x1A 0 0 0 0 0 0)) @result{} 6.5 +(bytes->ieee-double (bytes #xC0 #x1A 0 0 0 0 0 0)) @result{} -6.5 + +(bytes->ieee-double (bytes 0 8 0 0 0 0 0 0)) @result{} 11.125369292536006e-309 +(bytes->ieee-double (bytes 0 4 0 0 0 0 0 0)) @result{} 5.562684646268003e-309 +(bytes->ieee-double (bytes 0 0 0 0 0 0 0 1)) @result{} 4.0e-324 + +(bytes->ieee-double (bytes #xFF #xF0 0 0 0 0 0 0)) @result{} -1/0 +(bytes->ieee-double (bytes #x7F #xF0 0 0 0 0 0 0)) @result{} 1/0 +(bytes->ieee-double (bytes #x7F #xF8 0 0 0 0 0 0)) @result{} 0/0 +@end example + + +@defun ieee-float->bytes x + +Returns a 4-element byte-array encoding the IEEE single-precision +floating-point of @var{x}. +@end defun +@example +(bytes->list (ieee-float->bytes 2.0)) @result{} (64 0 0 0) +(bytes->list (ieee-float->bytes 6.5)) @result{} (64 208 0 0) +(bytes->list (ieee-float->bytes -6.5)) @result{} (192 208 0 0) + +(bytes->list (ieee-float->bytes 11.754943508222875e-39)) @result{} ( 0 128 0 0) +(bytes->list (ieee-float->bytes 5.877471754111438e-39)) @result{} ( 0 64 0 0) +(bytes->list (ieee-float->bytes 1.401298464324817e-45)) @result{} ( 0 0 0 1) + +(bytes->list (ieee-float->bytes -1/0)) @result{} (255 128 0 0) +(bytes->list (ieee-float->bytes 1/0)) @result{} (127 128 0 0) +(bytes->list (ieee-float->bytes 0/0)) @result{} (127 128 0 1) +@end example + + +@defun ieee-double->bytes x + +Returns a 8-element byte-array encoding the IEEE double-precision +floating-point of @var{x}. +@end defun +@example +(bytes->list (ieee-double->bytes 2.0)) @result{} (64 0 0 0 0 0 0 0) +(bytes->list (ieee-double->bytes 6.5)) @result{} (64 26 0 0 0 0 0 0) +(bytes->list (ieee-double->bytes -6.5)) @result{} (192 26 0 0 0 0 0 0) + +(bytes->list (ieee-double->bytes 11.125369292536006e-309)) + @result{} ( 0 8 0 0 0 0 0 0) +(bytes->list (ieee-double->bytes 5.562684646268003e-309)) + @result{} ( 0 4 0 0 0 0 0 0) +(bytes->list (ieee-double->bytes 4.0e-324)) + @result{} ( 0 0 0 0 0 0 0 1) + +(bytes->list (ieee-double->bytes -1/0)) @result{} (255 240 0 0 0 0 0 0) +(bytes->list (ieee-double->bytes 1/0)) @result{} (127 240 0 0 0 0 0 0) +(bytes->list (ieee-double->bytes 0/0)) @result{} (127 248 0 0 0 0 0 0) +@end example + +@subsubheading Byte Collation Order + +@noindent +The @code{string<?} ordering of big-endian byte-array +representations of fixed and IEEE floating-point numbers agrees with +the numerical ordering only when those numbers are non-negative. + +@noindent +Straighforward modification of these formats can extend the +byte-collating order to work for their entire ranges. This +agreement enables the full range of numbers as keys in +@dfn{indexed-sequential-access-method} databases. +@cindex indexed-sequential-access-method + + +@deffn {Procedure} integer-byte-collate! byte-vector + +Modifies sign bit of @var{byte-vector} so that @code{string<?} ordering of +two's-complement byte-vectors matches numerical order. @code{integer-byte-collate!} returns +@var{byte-vector} and is its own functional inverse. +@end deffn + +@defun integer-byte-collate byte-vector + +Returns copy of @var{byte-vector} with sign bit modified so that @code{string<?} +ordering of two's-complement byte-vectors matches numerical order. +@code{integer-byte-collate} is its own functional inverse. +@end defun + +@deffn {Procedure} ieee-byte-collate! byte-vector + +Modifies @var{byte-vector} so that @code{string<?} ordering of IEEE floating-point +byte-vectors matches numerical order. @code{ieee-byte-collate!} returns @var{byte-vector}. +@end deffn + +@deffn {Procedure} ieee-byte-decollate! byte-vector + +Given @var{byte-vector} modified by @code{IEEE-byte-collate!}, reverses the @var{byte-vector} +modifications. +@end deffn + +@defun ieee-byte-collate byte-vector + +Returns copy of @var{byte-vector} encoded so that @code{string<?} ordering of IEEE +floating-point byte-vectors matches numerical order. +@end defun + +@defun ieee-byte-decollate byte-vector + +Given @var{byte-vector} returned by @code{IEEE-byte-collate}, reverses the @var{byte-vector} +modifications. +@end defun @@ -1,5 +1,5 @@ ;;;; "chap.scm" Chapter ordering -*-scheme-*- -;;; Copyright 1992, 1993, 1994 Aubrey Jaffer +;;; Copyright 1992, 1993, 1994, 2003 Aubrey Jaffer ; ;Permission to copy this software, to modify it, to redistribute it, ;to distribute modified versions, and to use it for any purpose is @@ -8,7 +8,7 @@ ;1. Any copy made of this software must include this copyright notice ;in full. ; -;2. I have made no warrantee or representation that the operation of +;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; @@ -22,6 +22,27 @@ ;;; section of the string consists of consecutive numeric or ;;; consecutive aphabetic characters. + +;;@code{(require 'chapter-order)} +;;@ftindex chapter-order +;; +;;The @samp{chap:} functions deal with strings which are ordered like +;;chapter numbers (or letters) in a book. Each section of the string +;;consists of consecutive numeric or consecutive aphabetic characters of +;;like case. + +;;@args string1 string2 +;;Returns #t if the first non-matching run of alphabetic upper-case or +;;the first non-matching run of alphabetic lower-case or the first +;;non-matching run of numeric characters of @var{string1} is +;;@code{string<?} than the corresponding non-matching run of +;;characters of @var{string2}. +;; +;;@example +;;(chap:string<? "a.9" "a.10") @result{} #t +;;(chap:string<? "4c" "4aa") @result{} #t +;;(chap:string<? "Revised^@{3.99@}" "Revised^@{4@}") @result{} #t +;;@end example (define (chap:string<? s1 s2) (let ((l1 (string-length s1)) (l2 (string-length s2))) @@ -78,6 +99,11 @@ (length-race (+ 1 i) ctype1 (char<? c1 c2))) (else (char<? c1 c2))))))) (delimited 0))) +;;@body +;;Implement the corresponding chapter-order predicates. +(define (chap:string>? string1 string2) (chap:string<? string2 string1)) +(define (chap:string<=? string1 string2) (not (chap:string<? string2 string1))) +(define (chap:string>=? string1 string2) (not (chap:string<? string1 string2))) (define chap:char-incr (- (char->integer #\2) (char->integer #\1))) @@ -120,6 +146,19 @@ s) (else (slib:error "inc-string error" s p))))) +;;@args string +;;Returns the next string in the @emph{chapter order}. If @var{string} +;;has no alphabetic or numeric characters, +;;@code{(string-append @var{string} "0")} is returnd. The argument to +;;chap:next-string will always be @code{chap:string<?} than the result. +;; +;;@example +;;(chap:next-string "a.9") @result{} "a.10" +;;(chap:next-string "4c") @result{} "4d" +;;(chap:next-string "4z") @result{} "4aa" +;;(chap:next-string "Revised^@{4@}") @result{} "Revised^@{5@}" +;; +;;@end example (define (chap:next-string s) (do ((i (+ -1 (string-length s)) (+ -1 i))) ((or (negative? i) @@ -144,7 +183,3 @@ ; (display " > ") ; (display s2) ; (newline))))) - -(define (chap:string>? s1 s2) (chap:string<? s2 s1)) -(define (chap:string>=? s1 s2) (not (chap:string<? s1 s2))) -(define (chap:string<=? s1 s2) (not (chap:string<? s2 s1))) diff --git a/chap.txi b/chap.txi new file mode 100644 index 0000000..514decd --- /dev/null +++ b/chap.txi @@ -0,0 +1,46 @@ +@code{(require 'chapter-order)} +@ftindex chapter-order + +The @samp{chap:} functions deal with strings which are ordered like +chapter numbers (or letters) in a book. Each section of the string +consists of consecutive numeric or consecutive aphabetic characters of +like case. + + +@defun chap:string<? string1 string2 + +Returns #t if the first non-matching run of alphabetic upper-case or +the first non-matching run of alphabetic lower-case or the first +non-matching run of numeric characters of @var{string1} is +@code{string<?} than the corresponding non-matching run of +characters of @var{string2}. + +@example +(chap:string<? "a.9" "a.10") @result{} #t +(chap:string<? "4c" "4aa") @result{} #t +(chap:string<? "Revised^@{3.99@}" "Revised^@{4@}") @result{} #t +@end example +@end defun + +@defun chap:string>? string1 string2 +@defunx chap:string<=? string1 string2 +@defunx chap:string>=? string1 string2 + +Implement the corresponding chapter-order predicates. +@end defun + +@defun chap:next-string string + +Returns the next string in the @emph{chapter order}. If @var{string} +has no alphabetic or numeric characters, +@code{(string-append @var{string} "0")} is returnd. The argument to +chap:next-string will always be @code{chap:string<?} than the result. + +@example +(chap:next-string "a.9") @result{} "a.10" +(chap:next-string "4c") @result{} "4d" +(chap:next-string "4z") @result{} "4aa" +(chap:next-string "Revised^@{4@}") @result{} "Revised^@{5@}" + +@end example +@end defun diff --git a/charplot.scm b/charplot.scm index 3e0e019..890fca0 100644 --- a/charplot.scm +++ b/charplot.scm @@ -1,5 +1,5 @@ ;;;; "charplot.scm", plotting on character devices for Scheme -;;; Copyright (C) 1992, 1993 Aubrey Jaffer +;;; Copyright (C) 1992, 1993, 2001, 2003 Aubrey Jaffer ; ;Permission to copy this software, to modify it, to redistribute it, ;to distribute modified versions, and to use it for any purpose is @@ -8,7 +8,7 @@ ;1. Any copy made of this software must include this copyright notice ;in full. ; -;2. I have made no warrantee or representation that the operation of +;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; @@ -17,155 +17,283 @@ ;promotional, or sales literature without prior written consent in ;each case. -(require 'sort) (require 'printf) (require 'array) (require 'array-for-each) +(require 'multiarg/and-) -(define charplot:rows 24) -(define charplot:columns (output-port-width (current-output-port))) +;;;@ These determine final graph size. +(define charplot:dimensions #f) -(define charplot:xborder #\_) -(define charplot:yborder #\|) -(define charplot:xaxchar #\-) -(define charplot:yaxchar #\:) -(define charplot:curve1 #\*) -(define charplot:xtick #\.) +;;; The left margin and legends +(define charplot:left-margin 12) -(define charplot:height (- charplot:rows 5)) -(define charplot:width (- charplot:columns 15)) +(define char:xborder #\_) +(define char:yborder #\|) +(define char:xaxis #\-) +(define char:yaxis #\:) +(define char:xtick #\.) +(define char:bar #\I) +(define char:curves "*+x@#$%&='") -(define (charplot:printn! n char) - (cond ((positive? n) - (write-char char) - (charplot:printn! (+ n -1) char)))) +;;;Converts X to a string whose length is at most MWID. +(define (charplot:number->string x mwid) + (define str (sprintf #f "%g" x)) + (if (> (string-length str) mwid) + (substring str 0 mwid) + str)) -(define (charplot:center-print! str width) - (let ((lpad (quotient (- width (string-length str)) 2))) - (charplot:printn! lpad #\ ) - (display str) - (charplot:printn! (- width (+ (string-length str) lpad)) #\ ))) - -(define (charplot:number->string x) - (sprintf #f "%g" x)) - -(define (charplot:scale-it z scale) - (if (and (exact? z) (integer? z)) - (quotient (* z (car scale)) (cadr scale)) - (inexact->exact (round (/ (* z (car scale)) (cadr scale)))))) +;;;SCALE is a list of numerator and denominator. +(define charplot:scale-it + (if (provided? 'inexact) + (lambda (z scale) + (inexact->exact (round (/ (* z (car scale)) (cadr scale))))) + (lambda (z scale) + (quotient (+ (* z (car scale)) (quotient (cadr scale) 2)) + (cadr scale))))) +;;; Given the width or height (in characters) and the data-span, +;;; returns a list of numerator and denominator (NUM DEN) suitable for +;;; passing as a second argument to CHARPLOT:SCALE-IT. +;;; +;;; NUM will be 1, 2, 3, 4, 5, 6, or 8 times a power of ten. +;;; DEN will be a power of ten. +;;; +;;; num isize +;;; === < ===== +;;; den delta (define (charplot:find-scale isize delta) - (define (fs2) - (cond ((< (* delta 8) isize) 8) - ((< (* delta 6) isize) 6) - ((< (* delta 5) isize) 5) - ((< (* delta 4) isize) 4) - ((< (* delta 3) isize) 3) - ((< (* delta 2) isize) 2) - (else 1))) (cond ((zero? delta) (set! delta 1)) ((inexact? delta) (set! isize (exact->inexact isize)))) - (do ((d 1 (* d 10))) + (do ((d 1 (* d 10)) + (isize isize (* isize 10))) ((<= delta isize) - (do ((n 1 (* n 10))) + (do ((n 1 (* n 10)) + (delta delta (* delta 10))) ((>= (* delta 10) isize) - (list (* n (fs2)) d)) - (set! delta (* delta 10)))) - (set! isize (* isize 10)))) + (list (* n (cond ((<= (* delta 8) isize) 8) + ((<= (* delta 6) isize) 6) + ((<= (* delta 5) isize) 5) + ((<= (* delta 4) isize) 4) + ((<= (* delta 3) isize) 3) + ((<= (* delta 2) isize) 2) + (else 1))) + d)))))) + +(define (charplot:make-array) + (let ((height (or (and charplot:dimensions (car charplot:dimensions)) + (output-port-height (current-output-port)))) + (width (or (and charplot:dimensions (cadr charplot:dimensions)) + (output-port-width (current-output-port))))) + (define pra (create-array " " height width)) + ;;Put newlines on right edge + (do ((idx (+ -1 height) (+ -1 idx))) + ((negative? idx)) + (array-set! pra #\newline idx (+ -1 width))) + pra)) -(define (charplot:iplot! data xlabel ylabel xmin xscale ymin yscale) +;;;Creates and initializes character array with axes, scales, and +;;;labels. +(define (charplot:init-array pra xlabel ylabel xmin xscale ymin yscale) + (define plot-height (- (car (array-dimensions pra)) 3)) + (define plot-width (- (cadr (array-dimensions pra)) charplot:left-margin 4)) (define xaxis (- (charplot:scale-it ymin yscale))) (define yaxis (- (charplot:scale-it xmin xscale))) - (charplot:center-print! ylabel 11) - (charplot:printn! (+ charplot:width 1) charplot:xborder) - (newline) - (set! data (sort! data (lambda (x y) (if (= (cdr x) (cdr y)) - (< (car x) (car y)) - (> (cdr x) (cdr y)))))) - (do ((ht (- charplot:height 1) (- ht 1))) + (define xstep (if (zero? (modulo (car xscale) 3)) 12 10)) + ;;CL is the left edge of WIDTH field + (define (center-field str width ln cl) + (define len (string-length str)) + (if (< width len) + (center-field (substring str 0 width) width ln cl) + (do ((cnt (+ -1 len) (+ -1 cnt)) + (adx (+ (quotient (- width len) 2) cl) (+ 1 adx)) + (idx 0 (+ 1 idx))) + ((negative? cnt)) + (array-set! pra (string-ref str idx) ln adx)))) + + ;;x and y labels + (center-field ylabel (+ charplot:left-margin -1) 0 0) + (center-field xlabel (+ -1 charplot:left-margin) (+ 2 plot-height) 0) + + ;;horizontal borders, x-axis, and ticking + (let ((xstep/2 (quotient (- xstep 2) 2))) + (define faxis (modulo (+ charplot:left-margin yaxis) xstep)) + (define faxis/2 (modulo (+ charplot:left-margin yaxis xstep/2 1) xstep)) + (define xfudge (modulo yaxis xstep)) + (do ((cl (+ charplot:left-margin -1) (+ 1 cl))) + ((>= cl (+ plot-width charplot:left-margin))) + (array-set! pra char:xborder 0 cl) + (array-set! pra + (cond ((eqv? faxis (modulo cl xstep)) char:yaxis) + ((eqv? faxis/2 (modulo cl xstep)) char:xtick) + (else char:xborder)) + (+ 1 plot-height) cl) + (if (<= 0 xaxis plot-height) + (array-set! pra char:xaxis (- plot-height xaxis) cl))) + + ;;horizontal coordinates + (do ((i xfudge (+ i xstep)) + (cl (+ charplot:left-margin xfudge (- xstep/2)) (+ xstep cl))) + ((> i plot-width)) + (center-field (charplot:number->string + (/ (* (- i yaxis) (cadr xscale)) + (car xscale)) + xstep) + xstep (+ 2 plot-height) cl))) + + ;;vertical borders and y-axis + (do ((ht plot-height (- ht 1))) + ((negative? ht)) + (array-set! pra char:yborder (+ 1 ht) (+ charplot:left-margin -2)) + (array-set! pra char:yborder (+ 1 ht) (+ charplot:left-margin plot-width)) + (if (< -1 yaxis plot-width) + (array-set! pra char:yaxis (+ 1 ht) (+ charplot:left-margin yaxis)))) + + ;;vertical ticking and coordinates + (do ((ht (- plot-height 1) (- ht 1)) + (ln 1 (+ 1 ln))) ((negative? ht)) - (let ((a (make-string (+ charplot:width 1) - (if (= ht xaxis) charplot:xaxchar #\ ))) - (ystep (if (= 1 (gcd (car yscale) 3)) 2 3))) - (string-set! a charplot:width charplot:yborder) - (if (< -1 yaxis charplot:width) (string-set! a yaxis charplot:yaxchar)) - (do () - ((or (null? data) (not (>= (cdar data) ht)))) - (string-set! a (caar data) charplot:curve1) - (set! data (cdr data))) + (let ((ystep (if (zero? (modulo (car yscale) 3)) 3 2))) (if (zero? (modulo (- ht xaxis) ystep)) (let* ((v (charplot:number->string (/ (* (- ht xaxis) (cadr yscale)) - (car yscale)))) - (l (string-length v))) - (if (> l 10) - (display (substring v 0 10)) - (begin - (charplot:printn! (- 10 l) #\ ) - (display v))) - (display charplot:yborder) - (display charplot:xaxchar)) - (begin - (charplot:printn! 10 #\ ) - (display charplot:yborder) - (display #\ ))) - (display a) (newline))) - (let* ((xstep (if (= 1 (gcd (car xscale) 3)) 10 12)) - (xstep/2 (quotient (- xstep 2) 2)) - (fudge (modulo yaxis xstep))) - (charplot:printn! 10 #\ ) (display charplot:yborder) - (charplot:printn! (+ 1 fudge) charplot:xborder) - (display charplot:yaxchar) - (do ((i fudge (+ i xstep))) - ((> (+ i xstep) charplot:width) - (charplot:printn! (modulo (- charplot:width (+ i 1)) xstep) - charplot:xborder)) - (charplot:printn! xstep/2 charplot:xborder) - (display charplot:xtick) - (charplot:printn! xstep/2 charplot:xborder) - (display charplot:yaxchar)) - (display charplot:yborder) (newline) - (charplot:center-print! xlabel (+ 12 fudge (- xstep/2))) - (do ((i fudge (+ i xstep))) - ((>= i charplot:width)) - (charplot:center-print! (charplot:number->string - (/ (* (- i yaxis) (cadr xscale)) - (car xscale))) - xstep)) - (newline))) - -(define (charplot:plot! data xlabel ylabel) + (car yscale)) + (+ charplot:left-margin -2))) + (len (string-length v))) + (center-field v len ln (- charplot:left-margin 2 len)) ;Actually flush right + (array-set! pra char:xaxis ln (+ charplot:left-margin -1)))))) + ;;return initialized array + pra) + +(define (charplot:array->list ra) + (define dims (array-dimensions ra)) + (do ((idx (+ -1 (car dims)) (+ -1 idx)) + (cols '() (cons (do ((jdx (+ -1 (cadr dims)) (+ -1 jdx)) + (row '() (cons (array-ref ra idx jdx) row))) + ((negative? jdx) row)) + cols))) + ((negative? idx) cols))) + +;;;Converts data to list of coordinates (list). +(define (charplot:data->lists data) (cond ((array? data) (case (array-rank data) - ((1) (set! data (map cons - (let ((ra (apply make-array #f + ((1) (set! data (map list + (let ((ra (apply create-array '#() (array-shape data)))) (array-index-map! ra identity) - (array->list ra)) - (array->list data)))) - ((2) (set! data (map (lambda (lst) (cons (car lst) (cadr lst))) - (array->list data))))))) - (let* ((xmax (apply max (map car data))) - (xmin (apply min (map car data))) - (xscale (charplot:find-scale charplot:width (- xmax xmin))) - (ymax (apply max (map cdr data))) - (ymin (apply min (map cdr data))) - (yscale (charplot:find-scale charplot:height (- ymax ymin))) - (ixmin (charplot:scale-it xmin xscale)) - (iymin (charplot:scale-it ymin yscale))) - (charplot:iplot! (map (lambda (p) - (cons (- (charplot:scale-it (car p) xscale) ixmin) - (- (charplot:scale-it (cdr p) yscale) iymin))) - data) - xlabel ylabel xmin xscale ymin yscale))) - -(define (plot-function! func vlo vhi . npts) - (set! npts (if (null? npts) 100 (car npts))) - (let ((dats (make-array 0.0 npts 2))) + (charplot:array->list ra)) + (charplot:array->list data)))) + ((2) (set! data (charplot:array->list data))))) + ((and (pair? (car data)) (not (list? (car data)))) + (set! data (map (lambda (lst) (list (car lst) (cdr lst))) data)))) + (cond ((list? (cadar data)) + (set! data (map (lambda (lst) (cons (car lst) (cadr lst))) data)))) + data) + +;;;An extremum is a list of the maximum and minimum values. +;;;COORDINATE-EXTREMA returns a rank-length list of these. +(define (coordinate-extrema data) + (define extrema (map (lambda (x) (list x x)) (car data))) + (for-each (lambda (lst) + (set! extrema (map (lambda (x max-min) + (list (max x (car max-min)) + (min x (cadr max-min)))) + lst extrema))) + data) + extrema) + +;;;Count occurrences of numbers within evenly spaced ranges; and return +;;;lists of coordinates for graph. +(define (histobins data plot-width) + (define datcnt (length data)) + (define xmax (apply max data)) + (define xmin (apply min data)) + (if (null? data) + '() + (let* ((xscale (charplot:find-scale plot-width (- xmax xmin))) + (actual-width (- (charplot:scale-it xmax xscale) + (charplot:scale-it xmin xscale) + -1))) + (define ix-min (charplot:scale-it xmin xscale)) + (define xinc (/ (- xmax xmin) actual-width)) + (define bins (make-vector actual-width 0)) + (for-each (lambda (x) + (define idx (- (charplot:scale-it x xscale) ix-min)) + (if (< -1 idx actual-width) + (vector-set! bins idx (+ 1 (vector-ref bins idx))) + (slib:error x (/ (* x (car xscale)) (cadr xscale)) + (+ ix-min idx)))) + data) + (map list + (do ((idx (+ -1 (vector-length bins)) (+ -1 idx)) + (xvl xmax (- xvl xinc)) + (lst '() (cons xvl lst))) + ((negative? idx) lst)) + (vector->list bins))))) + +;;;@ Plot histogram of DATA. +(define (histograph data label) + (if (vector? data) (set! data (vector->list data))) + (charplot:plot (histobins data + (- (or (and charplot:dimensions + (cadr charplot:dimensions)) + (output-port-width (current-output-port))) + charplot:left-margin 3)) + label "" #t)) + +(define (charplot:plot data xlabel ylabel . histogram?) + (define clen (string-length char:curves)) + (set! histogram? (if (null? histogram?) #f (car histogram?))) + (set! data (charplot:data->lists data)) + (let* ((pra (charplot:make-array)) + (plot-height (- (car (array-dimensions pra)) 3)) + (plot-width (- (cadr (array-dimensions pra)) charplot:left-margin 4)) + (extrema (coordinate-extrema data)) + (xmax (caar extrema)) + (xmin (cadar extrema)) + (ymax (apply max (map car (cdr extrema)))) + (ymin (apply min (map cadr (cdr extrema)))) + (xscale (charplot:find-scale plot-width (- xmax xmin))) + (yscale (charplot:find-scale plot-height (- ymax ymin))) + (ix-min (- (charplot:scale-it xmin xscale) charplot:left-margin)) + (ybot (charplot:scale-it ymin yscale)) + (iy-min (+ ybot plot-height))) + (charplot:init-array pra xlabel ylabel xmin xscale ymin yscale) + (for-each (if histogram? + ;;display data bars + (lambda (datum) + (define x (- (charplot:scale-it (car datum) xscale) ix-min)) + (do ((y (charplot:scale-it (cadr datum) yscale) (+ -1 y))) + ((< y ybot)) + (array-set! pra char:bar (- iy-min y) x))) + ;;display data points + (lambda (datum) + (define x (- (charplot:scale-it (car datum) xscale) ix-min)) + (define cdx 0) + (for-each + (lambda (y) + (array-set! pra (string-ref char:curves cdx) + (- iy-min (charplot:scale-it y yscale)) x) + (set! cdx (modulo (+ 1 cdx) clen))) + (cdr datum)))) + data) + (array-for-each write-char pra) + (if (not (eqv? #\newline (apply array-ref pra + (map cadr (array-shape pra))))) + (newline)))) + +(define (charplot:plot-function func vlo vhi . npts) + (set! npts (if (null? npts) 64 (car npts))) + (let ((dats (create-array (Ar64) npts 2))) (array-index-map! (make-shared-array dats (lambda (idx) (list idx 0)) npts) - (lambda (idx) (+ vlo (* (- vhi vlo) (/ idx npts))))) + (lambda (idx) + (+ vlo (* (- vhi vlo) (/ idx (+ -1 npts)))))) (array-map! (make-shared-array dats (lambda (idx) (list idx 1)) npts) func (make-shared-array dats (lambda (idx) (list idx 0)) npts)) - (charplot:plot! dats "" ""))) - -(define plot! charplot:plot!) + (charplot:plot dats "" ""))) +;@ +(define (plot . args) + (if (procedure? (car args)) + (apply charplot:plot-function args) + (apply charplot:plot args))) @@ -8,36 +8,30 @@ ;;; (software-type) should be set to the generic operating system type. ;;; UNIX, VMS, MACOS, AMIGA and MS-DOS are supported. - (define (software-type) 'UNIX) ;;; (scheme-implementation-type) should return the name of the scheme ;;; implementation loading this file. - (define (scheme-implementation-type) 'chez) ;;; (scheme-implementation-home-page) should return a (string) URI ;;; (Uniform Resource Identifier) for this scheme implementation's home ;;; page; or false if there isn't one. - (define (scheme-implementation-home-page) - "http://www.cs.indiana.edu/chezscheme/") + "http://www.scheme.com/") ;;; (scheme-implementation-version) should return a string describing ;;; the version the scheme implementation loading this file. - (define (scheme-implementation-version) "6.0a") ;;; (implementation-vicinity) should be defined to be the pathname of ;;; the directory where any auxillary files to your Scheme ;;; implementation reside. - (define implementation-vicinity (lambda () "/usr/unsup/scheme/chez/")) ;;; (library-vicinity) should be defined to be the pathname of the ;;; directory where files of Scheme library functions reside. - (define library-vicinity (let ((library-path (or @@ -55,14 +49,18 @@ ;;; (home-vicinity) should return the vicinity of the user's HOME ;;; directory, the directory which typically contains files which ;;; customize a computer environment for a user. - -(define home-vicinity - (let ((home-path (getenv "HOME"))) - (lambda () home-path))) +(define (home-vicinity) + (let ((home (getenv "HOME"))) + (and home + (case (software-type) + ((UNIX COHERENT MS-DOS) ;V7 unix has a / on HOME + (if (eqv? #\/ (string-ref home (+ -1 (string-length home)))) + home + (string-append home "/"))) + (else home))))) ;;; *FEATURES* should be set to a list of symbols describing features ;;; of this implementation. Suggestions for features are: - (define *features* '( source ;can load scheme source files @@ -72,7 +70,7 @@ ;; Scheme report features - rev5-report ;conforms to + r5rs ;conforms to eval ;R5RS two-argument eval values ;R5RS multiple values dynamic-wind ;R5RS dynamic-wind @@ -86,11 +84,11 @@ ;STRING-FILL!, LIST->VECTOR, ;VECTOR->LIST, and VECTOR-FILL! - rev4-report ;conforms to + r4rs ;conforms to ieee-p1178 ;conforms to - rev3-report ;conforms to + r3rs ;conforms to ; rev2-procedures ;SUBSTRING-MOVE-LEFT!, ;SUBSTRING-MOVE-RIGHT!, @@ -101,7 +99,7 @@ multiarg/and- ;/ and - can take more than 2 args. with-file ;has WITH-INPUT-FROM-FILE and - ;WITH-OUTPUT-FROM-FILE + ;WITH-OUTPUT-TO-FILE transcript ;TRANSCRIPT-ON and TRANSCRIPT-OFF ; ieee-floating-point ;conforms to IEEE Standard 754-1985 ;IEEE Standard for Binary @@ -132,13 +130,12 @@ ;; Implementation Specific features +;;; random ;Not the same as SLIB random fluid-let - random )) ;;; (OUTPUT-PORT-WIDTH <port>) returns the number of graphic characters ;;; that can reliably be displayed on one line of the standard output port. - (define output-port-width (lambda arg (let ((env-width-string (getenv "COLUMNS"))) @@ -154,7 +151,6 @@ ;;; (OUTPUT-PORT-HEIGHT <port>) returns the number of lines of text that ;;; can reliably be displayed simultaneously in the standard output port. - (define output-port-height (lambda arg (let ((env-height-string (getenv "LINES"))) @@ -189,6 +185,37 @@ ;; port to be transferred all the way out to its ultimate destination. (define force-output flush-output-port) +(define (make-exchanger obj) + (lambda (rep) (let ((old obj)) (set! obj rep) old))) +(define (open-file filename modes) + (case modes + ((r rb) (open-input-file filename)) + ((w wb) (open-output-file filename)) + (else (slib:error 'open-file 'mode? modes)))) +(define (port? obj) (or (input-port? port) (output-port? port))) +(define (call-with-open-ports . ports) + (define proc (car ports)) + (cond ((procedure? proc) (set! ports (cdr ports))) + (else (set! ports (reverse ports)) + (set! proc (car ports)) + (set! ports (reverse (cdr ports))))) + (let ((ans (apply proc ports))) + (for-each close-port ports) + ans)) +(define (close-port port) + (cond ((input-port? port) + (close-input-port port) + (if (output-port? port) (close-output-port port))) + ((output-port? port) (close-output-port port)) + (else (slib:error 'close-port 'port? port)))) + +(define (browse-url url) + (define (try cmd end) (zero? (system (string-append cmd url end)))) + (or (try "netscape-remote -remote 'openURL(" ")'") + (try "netscape -remote 'openURL(" ")'") + (try "netscape '" "'&") + (try "netscape '" "'"))) + ;;; "rationalize" adjunct procedures. (define (find-ratio x e) (let ((rat (rationalize x e))) @@ -218,7 +245,7 @@ (let ((cep (current-error-port))) (if (provided? 'trace) (print-call-stack cep)) (display "Error: " cep) - (for-each (lambda (x) (display x cep)) args) + (for-each (lambda (x) (display #\ cep) (write x cep)) args) (error #f "")))) ;;; define these as appropriate for your system. @@ -269,17 +296,14 @@ ;;; (SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever ;;; suffix all the module files in SLIB have. See feature 'SOURCE. - (define (slib:load-source f) (load (string-append f ".scm"))) ;;; (SLIB:LOAD-COMPILED "foo") should load the file that was produced ;;; by compiling "foo.scm" if this implementation can compile files. ;;; See feature 'COMPILED. - (define slib:load-compiled load) ;;; At this point SLIB:LOAD must be able to load SLIB files. - (define slib:load slib:load-source) ;;; The following make procedures in Chez Scheme compatible with @@ -309,7 +333,6 @@ ;;; Chez's (FORMAT F . A) corresponds to SLIB's (FORMAT #F F . A) ;;; See the FORMAT feature. - (define chez:format format) (define format @@ -325,7 +348,6 @@ ;;; CALL-WITH-INPUT-STRING and CALL-WITH-OUTPUT-STRING are the string ;;; port versions of CALL-WITH-INPUT-FILE and CALL-WITH-OUTPUT-FILE. ;;; See the STRING-PORT feature. - (define call-with-output-string (lambda (f) (let ((outsp (open-output-string))) @@ -397,10 +419,9 @@ (let ((cep (current-error-port))) (if (provided? 'trace) (print-call-stack cep)) (display "Warn: " cep) - (for-each (lambda (x) (display x cep)) args)))) + (for-each (lambda (x) (display #\ cep) (write x cep)) args)))) ;;; Load the REQUIRE package. - (slib:load (in-vicinity (library-vicinity) "require")) ;; end of chez.init diff --git a/cie1931.xyz b/cie1931.xyz new file mode 100644 index 0000000..ce74214 --- /dev/null +++ b/cie1931.xyz @@ -0,0 +1,82 @@ +;;; "cie1931.xyz" CIE XYZ(1931) Spectra from 380.nm to 780.nm. +380 0.0014 0.0000 0.0065 +385 0.0022 0.0001 0.0105 +390 0.0042 0.0001 0.0201 +395 0.0076 0.0002 0.0362 +400 0.0143 0.0004 0.0679 +405 0.0232 0.0006 0.1102 +410 0.0435 0.0012 0.2074 +415 0.0776 0.0022 0.3713 +420 0.1344 0.0040 0.6456 +425 0.2148 0.0073 1.0391 +430 0.2839 0.0116 1.3856 +435 0.3285 0.0168 1.6230 +440 0.3483 0.0230 1.7471 +445 0.3481 0.0298 1.7826 +450 0.3362 0.0380 1.7721 +455 0.3187 0.0480 1.7441 +460 0.2908 0.0600 1.6692 +465 0.2511 0.0739 1.5281 +470 0.1954 0.0910 1.2876 +475 0.1421 0.1126 1.0419 +480 0.0956 0.1390 0.8130 +485 0.0580 0.1693 0.6162 +490 0.0320 0.2080 0.4652 +495 0.0147 0.2586 0.3533 +500 0.0049 0.3230 0.2720 +505 0.0024 0.4073 0.2123 +510 0.0093 0.5030 0.1582 +515 0.0291 0.6082 0.1117 +520 0.0633 0.7100 0.0782 +525 0.1096 0.7932 0.0573 +530 0.1655 0.8620 0.0422 +535 0.2257 0.9149 0.0298 +540 0.2904 0.9540 0.0203 +545 0.3597 0.9803 0.0134 +550 0.4334 0.9950 0.0087 +555 0.5121 1.0000 0.0057 +560 0.5945 0.9950 0.0039 +565 0.6784 0.9786 0.0027 +570 0.7621 0.9520 0.0021 +575 0.8425 0.9154 0.0018 +580 0.9163 0.8700 0.0017 +585 0.9786 0.8163 0.0014 +590 1.0263 0.7570 0.0011 +595 1.0567 0.6949 0.0010 +600 1.0622 0.6310 0.0008 +605 1.0456 0.5668 0.0006 +610 1.0026 0.5030 0.0003 +615 0.9384 0.4412 0.0002 +620 0.8544 0.3810 0.0002 +625 0.7514 0.3210 0.0001 +630 0.6424 0.2650 0.0000 +635 0.5419 0.2170 0.0000 +640 0.4479 0.1750 0.0000 +645 0.3608 0.1382 0.0000 +650 0.2835 0.1070 0.0000 +655 0.2187 0.0816 0.0000 +660 0.1649 0.0610 0.0000 +665 0.1212 0.0446 0.0000 +670 0.0874 0.0320 0.0000 +675 0.0636 0.0232 0.0000 +680 0.0468 0.0170 0.0000 +685 0.0329 0.0119 0.0000 +690 0.0227 0.0082 0.0000 +695 0.0158 0.0057 0.0000 +700 0.0114 0.0041 0.0000 +705 0.0081 0.0029 0.0000 +710 0.0058 0.0021 0.0000 +715 0.0041 0.0015 0.0000 +720 0.0029 0.0010 0.0000 +725 0.0020 0.0007 0.0000 +730 0.0014 0.0005 0.0000 +735 0.0010 0.0004 0.0000 +740 0.0007 0.0002 0.0000 +745 0.0005 0.0002 0.0000 +750 0.0003 0.0001 0.0000 +755 0.0002 0.0001 0.0000 +760 0.0002 0.0001 0.0000 +765 0.0001 0.0000 0.0000 +770 0.0001 0.0000 0.0000 +775 0.0001 0.0000 0.0000 +780 0.0000 0.0000 0.0000 diff --git a/cie1964.xyz b/cie1964.xyz new file mode 100644 index 0000000..89fa244 --- /dev/null +++ b/cie1964.xyz @@ -0,0 +1,82 @@ +;;; "cie1964.xyz" CIE XYZ(1964) Spectra from 380.nm to 780.nm. +380 0.0002 0.0000 0.0007 +385 0.0007 0.0001 0.0029 +390 0.0024 0.0003 0.0105 +395 0.0072 0.0008 0.0323 +400 0.0191 0.0020 0.0860 +405 0.0434 0.0045 0.1971 +410 0.0847 0.0088 0.3894 +415 0.1406 0.0145 0.6568 +420 0.2045 0.0214 0.9725 +425 0.2647 0.0295 1.2825 +430 0.3147 0.0387 1.5535 +435 0.3577 0.0496 1.7985 +440 0.3837 0.0621 1.9673 +445 0.3867 0.0747 2.0273 +450 0.3707 0.0895 1.9948 +455 0.3430 0.1063 1.9007 +460 0.3023 0.1282 1.7454 +465 0.2541 0.1528 1.5549 +470 0.1956 0.1852 1.3176 +475 0.1323 0.2199 1.0302 +480 0.0805 0.2536 0.7721 +485 0.0411 0.2977 0.5701 +490 0.0162 0.3391 0.4153 +495 0.0051 0.3954 0.3024 +500 0.0038 0.4608 0.2185 +505 0.0154 0.5314 0.1592 +510 0.0375 0.6067 0.1120 +515 0.0714 0.6857 0.0822 +520 0.1177 0.7618 0.0607 +525 0.1730 0.8233 0.0431 +530 0.2365 0.8752 0.0305 +535 0.3042 0.9238 0.0206 +540 0.3768 0.9620 0.0137 +545 0.4516 0.9822 0.0079 +550 0.5298 0.9918 0.0040 +555 0.6161 0.9991 0.0011 +560 0.7052 0.9973 0.0000 +565 0.7938 0.9824 0.0000 +570 0.8787 0.9556 0.0000 +575 0.9512 0.9152 0.0000 +580 1.0142 0.8689 0.0000 +585 1.0743 0.8256 0.0000 +590 1.1185 0.7774 0.0000 +595 1.1343 0.7204 0.0000 +600 1.1240 0.6583 0.0000 +605 1.0891 0.5939 0.0000 +610 1.0305 0.5280 0.0000 +615 0.9507 0.4618 0.0000 +620 0.8563 0.3981 0.0000 +625 0.7549 0.3396 0.0000 +630 0.6475 0.2835 0.0000 +635 0.5351 0.2283 0.0000 +640 0.4316 0.1798 0.0000 +645 0.3437 0.1402 0.0000 +650 0.2683 0.1076 0.0000 +655 0.2043 0.0812 0.0000 +660 0.1526 0.0603 0.0000 +665 0.1122 0.0441 0.0000 +670 0.0813 0.0318 0.0000 +675 0.0579 0.0226 0.0000 +680 0.0409 0.0159 0.0000 +685 0.0286 0.0111 0.0000 +690 0.0199 0.0077 0.0000 +695 0.0138 0.0054 0.0000 +700 0.0096 0.0037 0.0000 +705 0.0066 0.0026 0.0000 +710 0.0046 0.0018 0.0000 +715 0.0031 0.0012 0.0000 +720 0.0022 0.0008 0.0000 +725 0.0015 0.0006 0.0000 +730 0.0010 0.0004 0.0000 +735 0.0007 0.0003 0.0000 +740 0.0005 0.0002 0.0000 +745 0.0004 0.0001 0.0000 +750 0.0003 0.0001 0.0000 +755 0.0002 0.0001 0.0000 +760 0.0001 0.0000 0.0000 +765 0.0001 0.0000 0.0000 +770 0.0001 0.0000 0.0000 +775 0.0000 0.0000 0.0000 +780 0.0000 0.0000 0.0000 @@ -8,7 +8,7 @@ ;1. Any copy made of this software must include this copyright notice ;in full. ; -;2. I have made no warrantee or representation that the operation of +;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; @@ -22,13 +22,13 @@ (require 'posix-time) (define time:1900 (time:invert time:gmtime '#(0 0 0 1 0 0 #f #f 0 0 "GMT"))) - +;@ (define (get-decoded-time) (decode-universal-time (get-universal-time))) - +;@ (define (get-universal-time) (difftime (current-time) time:1900)) - +;@ (define (decode-universal-time utime . tzarg) (let ((tv (apply time:split (offset-time time:1900 utime) @@ -48,7 +48,7 @@ (inexact->exact (/ (vector-ref tv 9) 3600)) (/ (vector-ref tv 9) 3600)) ;time-zone [-24..24] ))) - +;@ (define (encode-universal-time second minute hour date month year . tzarg) (let* ((tz (if (null? tzarg) (tzset) @@ -8,7 +8,7 @@ ;1. Any copy made of this software must include this copyright notice ;in full. ; -;2. I have made no warrantee or representation that the operation of +;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; diff --git a/collect.scm b/collect.scm index 35a333d..05bc2cf 100644 --- a/collect.scm +++ b/collect.scm @@ -2,49 +2,55 @@ ; COPYRIGHT (c) Kenneth Dickey 1992 ; ; This software may be used for any purpose whatever -; without warrantee of any kind. +; without warranty of any kind. ; AUTHOR Ken Dickey ; DATE 1992 September 1 ; LAST UPDATED 1992 September 2 ; NOTES Expository (optimizations & checks elided). ; Requires YASOS (Yet Another Scheme Object System). +(require 'object) (require 'yasos) -(define-operation (collect:collection? obj) +(define collect:size size) +(define collect:print print) + +;@ +(define-operation (collection? obj) ;; default (cond ((or (list? obj) (vector? obj) (string? obj)) #t) (else #f) ) ) - -(define (collect:empty? collection) (zero? (yasos:size collection))) - -(define-operation (collect:gen-elts <collection>) ;; return element generator +;@ +(define (empty? collection) (zero? (collect:size collection))) +;@ +(define-operation (gen-elts <collection>) ;; return element generator ;; default behavior (cond ;; see utilities, below, for generators ((vector? <collection>) (collect:vector-gen-elts <collection>)) ((list? <collection>) (collect:list-gen-elts <collection>)) ((string? <collection>) (collect:string-gen-elts <collection>)) (else - (slib:error "Operation not supported: GEN-ELTS " (yasos:print obj #f))) + (slib:error 'gen-elts 'operation-not-supported + (collect:print <collection> #f))) ) ) - -(define-operation (collect:gen-keys collection) +;@ +(define-operation (gen-keys collection) (if (or (vector? collection) (list? collection) (string? collection)) - (let ( (max+1 (yasos:size collection)) (index 0) ) + (let ( (max+1 (collect:size collection)) (index 0) ) (lambda () (cond ((< index max+1) (set! index (collect:add1 index)) (collect:sub1 index)) - (else (slib:error "no more keys in generator")) + (else (slib:error 'no-more 'keys 'in 'generator)) ) ) ) - (slib:error "Operation not handled: GEN-KEYS " collection) + (slib:error 'gen-keys 'operation-not-handled collection) ) ) - -(define (collect:do-elts <proc> . <collections>) - (let ( (max+1 (yasos:size (car <collections>))) +;@ +(define (do-elts <proc> . <collections>) + (let ( (max+1 (collect:size (car <collections>))) (generators (map collect:gen-elts <collections>)) ) (let loop ( (counter 0) ) @@ -56,9 +62,9 @@ (else 'unspecific) ; done ) ) ) ) - -(define (collect:do-keys <proc> . <collections>) - (let ( (max+1 (yasos:size (car <collections>))) +;@ +(define (do-keys <proc> . <collections>) + (let ( (max+1 (collect:size (car <collections>))) (generators (map collect:gen-keys <collections>)) ) (let loop ( (counter 0) ) @@ -70,11 +76,11 @@ (else 'unspecific) ; done ) ) ) ) - -(define (collect:map-elts <proc> . <collections>) - (let ( (max+1 (yasos:size (car <collections>))) +;@ +(define (map-elts <proc> . <collections>) + (let ( (max+1 (collect:size (car <collections>))) (generators (map collect:gen-elts <collections>)) - (vec (make-vector (yasos:size (car <collections>)))) + (vec (make-vector (collect:size (car <collections>)))) ) (let loop ( (index 0) ) (cond @@ -85,11 +91,11 @@ (else vec) ; done ) ) ) ) - -(define (collect:map-keys <proc> . <collections>) - (let ( (max+1 (yasos:size (car <collections>))) +;@ +(define (map-keys <proc> . <collections>) + (let ( (max+1 (collect:size (car <collections>))) (generators (map collect:gen-keys <collections>)) - (vec (make-vector (yasos:size (car <collections>)))) + (vec (make-vector (collect:size (car <collections>)))) ) (let loop ( (index 0) ) (cond @@ -100,18 +106,18 @@ (else vec) ; done ) ) ) ) - -(define-operation (collect:for-each-key <collection> <proc>) +;@ +(define-operation (for-each-key <collection> <proc>) ;; default (collect:do-keys <proc> <collection>) ;; talk about lazy! ) - -(define-operation (collect:for-each-elt <collection> <proc>) +;@ +(define-operation (for-each-elt <collection> <proc>) (collect:do-elts <proc> <collection>) ) - -(define (collect:reduce <proc> <seed> . <collections>) - (let ( (max+1 (yasos:size (car <collections>))) +;@ +(define (reduce <proc> <seed> . <collections>) + (let ( (max+1 (collect:size (car <collections>))) (generators (map collect:gen-elts <collections>)) ) (let loop ( (count 0) ) @@ -127,9 +133,9 @@ -;; pred true for every elt? -(define (collect:every? <pred?> . <collections>) - (let ( (max+1 (yasos:size (car <collections>))) +;;@ pred true for every elt? +(define (every? <pred?> . <collections>) + (let ( (max+1 (collect:size (car <collections>))) (generators (map collect:gen-elts <collections>)) ) (let loop ( (count 0) ) @@ -143,9 +149,9 @@ ) ) ) ) -;; pred true for any elt? -(define (collect:any? <pred?> . <collections>) - (let ( (max+1 (yasos:size (car <collections>))) +;;@ pred true for any elt? +(define (any? <pred?> . <collections>) + (let ( (max+1 (collect:size (car <collections>))) (generators (map collect:gen-elts <collections>)) ) (let loop ( (count 0) ) @@ -191,7 +197,7 @@ (define (collect:list-gen-elts <list>) (lambda () (if (null? <list>) - (slib:error "No more list elements in generator") + (slib:error 'no-more 'list-elements 'in 'generator) (let ( (elt (car <list>)) ) (set! <list> (cdr <list>)) elt)) @@ -200,7 +206,7 @@ ;; generator for vector elements (define (collect:make-vec-gen-elts <accessor>) (lambda (vec) - (let ( (max+1 (yasos:size vec)) + (let ( (max+1 (collect:size vec)) (index 0) ) (lambda () @@ -219,18 +225,9 @@ ;;; exports: -(define collection? collect:collection?) -(define empty? collect:empty?) -(define gen-keys collect:gen-keys) -(define gen-elts collect:gen-elts) -(define do-elts collect:do-elts) -(define do-keys collect:do-keys) -(define map-elts collect:map-elts) -(define map-keys collect:map-keys) -(define for-each-key collect:for-each-key) -(define for-each-elt collect:for-each-elt) -(define reduce collect:reduce) ; reduce is also in comlist.scm -(define every? collect:every?) -(define any? collect:any?) +(define collect:gen-keys gen-keys) +(define collect:gen-elts gen-elts) +(define collect:do-elts do-elts) +(define collect:do-keys do-keys) ;; --- E O F "collect.oo" --- ;; diff --git a/collectx.scm b/collectx.scm new file mode 100644 index 0000000..7ba46b9 --- /dev/null +++ b/collectx.scm @@ -0,0 +1,247 @@ +;"collect.scm" Sample collection operations +; COPYRIGHT (c) Kenneth Dickey 1992 +; +; This software may be used for any purpose whatever +; without warranty of any kind. +; AUTHOR Ken Dickey +; DATE 1992 September 1 +; LAST UPDATED 1992 September 2 +; NOTES Expository (optimizations & checks elided). +; Requires YASOS (Yet Another Scheme Object System). + +(require 'object) +(require 'yasos) + +(define collect:size size) +(define collect:print print) + +;@ +(define collection? + (make-generic-method + (lambda (obj!2) + (cond ((or (list? obj!2) + (vector? obj!2) + (string? obj!2)) + #t) + (else #f))))) +;@ +(define empty? + (lambda (collection!1) + (zero? (collect:size collection!1)))) +;@ +(define gen-elts + (make-generic-method + (lambda (<collection>!2) + (cond ((vector? <collection>!2) + (collect:vector-gen-elts <collection>!2)) + ((list? <collection>!2) + (collect:list-gen-elts <collection>!2)) + ((string? <collection>!2) + (collect:string-gen-elts <collection>!2)) + (else + (slib:error + 'gen-elts + 'operation-not-supported + (collect:print <collection>!2 #f))))))) +;@ +(define gen-keys + (make-generic-method + (lambda (collection!2) + (if (or (vector? collection!2) + (list? collection!2) + (string? collection!2)) + (let ((max+1!3 (collect:size collection!2)) + (index!3 0)) + (lambda () + (cond ((< index!3 max+1!3) + (set! index!3 (collect:add1 index!3)) + (collect:sub1 index!3)) + (else (slib:error 'no-more 'keys 'in 'generator))))) + (slib:error + 'gen-keys + 'operation-not-handled + collection!2))))) +;@ +(define do-elts + (lambda (<proc>!1 . <collections>!1) + (let ((max+1!2 (collect:size (car <collections>!1))) + (generators!2 + (map collect:gen-elts <collections>!1))) + (let loop!4 ((counter!3 0)) + (cond ((< counter!3 max+1!2) + (apply <proc>!1 + (map (lambda (g!5) (g!5)) generators!2)) + (loop!4 (collect:add1 counter!3))) + (else 'unspecific)))))) +;@ +(define do-keys + (lambda (<proc>!1 . <collections>!1) + (let ((max+1!2 (collect:size (car <collections>!1))) + (generators!2 + (map collect:gen-keys <collections>!1))) + (let loop!4 ((counter!3 0)) + (cond ((< counter!3 max+1!2) + (apply <proc>!1 + (map (lambda (g!5) (g!5)) generators!2)) + (loop!4 (collect:add1 counter!3))) + (else 'unspecific)))))) +;@ +(define map-elts + (lambda (<proc>!1 . <collections>!1) + (let ((max+1!2 (collect:size (car <collections>!1))) + (generators!2 + (map collect:gen-elts <collections>!1)) + (vec!2 (make-vector + (collect:size (car <collections>!1))))) + (let loop!4 ((index!3 0)) + (cond ((< index!3 max+1!2) + (vector-set! + vec!2 + index!3 + (apply <proc>!1 + (map (lambda (g!5) (g!5)) generators!2))) + (loop!4 (collect:add1 index!3))) + (else vec!2)))))) +;@ +(define map-keys + (lambda (<proc>!1 . <collections>!1) + (let ((max+1!2 (collect:size (car <collections>!1))) + (generators!2 + (map collect:gen-keys <collections>!1)) + (vec!2 (make-vector + (collect:size (car <collections>!1))))) + (let loop!4 ((index!3 0)) + (cond ((< index!3 max+1!2) + (vector-set! + vec!2 + index!3 + (apply <proc>!1 + (map (lambda (g!5) (g!5)) generators!2))) + (loop!4 (collect:add1 index!3))) + (else vec!2)))))) +;@ +(define for-each-key + (make-generic-method + (lambda (<collection>!2 <proc>!2) + (collect:do-keys <proc>!2 <collection>!2)))) +;@ +(define for-each-elt + (make-generic-method + (lambda (<collection>!2 <proc>!2) + (collect:do-elts <proc>!2 <collection>!2)))) +;@ +(define reduce + (lambda (<proc>!1 <seed>!1 . <collections>!1) + (let ((max+1!2 (collect:size (car <collections>!1))) + (generators!2 + (map collect:gen-elts <collections>!1))) + (let loop!4 ((count!3 0)) + (cond ((< count!3 max+1!2) + (set! <seed>!1 + (apply <proc>!1 + <seed>!1 + (map (lambda (g!5) (g!5)) generators!2))) + (loop!4 (collect:add1 count!3))) + (else <seed>!1)))))) + + + +;;@ pred true for every elt? +(define every? + (lambda (<pred?>!1 . <collections>!1) + (let ((max+1!2 (collect:size (car <collections>!1))) + (generators!2 + (map collect:gen-elts <collections>!1))) + (let loop!4 ((count!3 0)) + (cond ((< count!3 max+1!2) + (if (apply <pred?>!1 + (map (lambda (g!5) (g!5)) generators!2)) + (loop!4 (collect:add1 count!3)) + #f)) + (else #t)))))) + +;;@ pred true for any elt? +(define any? + (lambda (<pred?>!1 . <collections>!1) + (let ((max+1!2 (collect:size (car <collections>!1))) + (generators!2 + (map collect:gen-elts <collections>!1))) + (let loop!4 ((count!3 0)) + (cond ((< count!3 max+1!2) + (if (apply <pred?>!1 + (map (lambda (g!5) (g!5)) generators!2)) + #t + (loop!4 (collect:add1 count!3)))) + (else #f)))))) + + +;; MISC UTILITIES + +(define collect:add1 + (lambda (obj!1) (+ obj!1 1))) +(define collect:sub1 + (lambda (obj!1) (- obj!1 1))) + +;; Nota Bene: list-set! is bogus for element 0 + +(define collect:list-set! + (lambda (<list>!1 <index>!1 <value>!1) + (letrec ((set-loop!3 + (lambda (last!4 this!4 idx!4) + (cond ((zero? idx!4) + (set-cdr! last!4 (cons <value>!1 (cdr this!4))) + <list>!1) + (else + (set-loop!3 + (cdr last!4) + (cdr this!4) + (collect:sub1 idx!4))))))) + (if (zero? <index>!1) + (cons <value>!1 (cdr <list>!1)) + (set-loop!3 + <list>!1 + (cdr <list>!1) + (collect:sub1 <index>!1)))))) + +(add-setter list-ref collect:list-set!) + ; for (setter list-ref) + + +;; generator for list elements +(define collect:list-gen-elts + (lambda (<list>!1) + (lambda () + (if (null? <list>!1) + (slib:error + 'no-more + 'list-elements + 'in + 'generator) + (let ((elt!3 (car <list>!1))) + (begin (set! <list>!1 (cdr <list>!1)) elt!3)))))) + +;; generator for vector elements +(define collect:make-vec-gen-elts + (lambda (<accessor>!1) + (lambda (vec!2) + (let ((max+1!3 (collect:size vec!2)) (index!3 0)) + (lambda () + (cond ((< index!3 max+1!3) + (set! index!3 (collect:add1 index!3)) + (<accessor>!1 vec!2 (collect:sub1 index!3))) + (else #f))))))) + +(define collect:vector-gen-elts + (collect:make-vec-gen-elts vector-ref)) + +(define collect:string-gen-elts + (collect:make-vec-gen-elts string-ref)) + +;;; exports: + +(define collect:gen-keys gen-keys) +(define collect:gen-elts gen-elts) +(define collect:do-elts do-elts) +(define collect:do-keys do-keys) + +;; --- E O F "collect.oo" --- ;; diff --git a/color.scm b/color.scm new file mode 100644 index 0000000..7f80fe5 --- /dev/null +++ b/color.scm @@ -0,0 +1,674 @@ +;;; "color.scm" color data-type +;Copyright 2001, 2002 Aubrey Jaffer +; +;Permission to copy this software, to modify it, to redistribute it, +;to distribute modified versions, and to use it for any purpose is +;granted, subject to the following restrictions and understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warranty or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +(require 'record) +(require 'color-space) +(require 'scanf) +(require 'printf) +(require 'string-case) + +(define color:rtd + (make-record-type "color" + '(encoding ;symbol + coordinates ;list of coordinates + parameter ;white-point or precision + ))) + +(define color:construct + (record-constructor color:rtd '(encoding coordinates parameter))) + +(define color:encoding (record-accessor color:rtd 'encoding)) + +(define color:coordinates (record-accessor color:rtd 'coordinates)) + +(define color:parameter (record-accessor color:rtd 'parameter)) +(define color:precision color:parameter) + +(define color:color? (record-predicate color:rtd)) + +(define (color:white-point color) + (case (color:encoding color) + ((CIEXYZ + RGB709 + sRGB + xRGB + e-sRGB) CIEXYZ:D65) + ((L*a*b* + L*u*v* + L*C*h) + (or (color:parameter color) CIEXYZ:D65)))) + +;;@subsubheading Measurement-based Color Spaces + +(define (color:helper num-of-nums name list->color) + (lambda args + (define cnt 0) + (for-each (lambda (x) + (if (and (< cnt num-of-nums) (not (real? x))) + (slib:error name ': 'wrong-type x)) + (set! cnt (+ 1 cnt))) + args) + (or (list->color args) + (slib:error name ': 'out-of-range args)))) + +;;@noindent +;;@cindex tristimulus +;;The @dfn{tristimulus} color spaces are those whose component values +;;are proportional measurements of light intensity. The CIEXYZ(1931) +;;system provides 3 sets of spectra to convolve with a spectrum of +;;interest. The result of those convolutions is coordinates in CIEXYZ +;;space. All tristimuls color spaces are related to CIEXYZ by linear +;;transforms, namely matrix multiplication. Of the color spaces listed +;;here, CIEXYZ and RGB709 are tristimulus spaces. + +;;@deftp {Color Space} CIEXYZ +;;The CIEXYZ color space covers the full @dfn{gamut}. +;;It is the basis for color-space conversions. +;; +;;CIEXYZ is a list of three inexact numbers between 0 and 1.1. +;;'(0. 0. 0.) is black; '(1. 1. 1.) is white. +;;@end deftp + +;;@body +;;@1 must be a list of 3 numbers. If @1 is valid CIEXYZ coordinates, +;;then @0 returns the color specified by @1; otherwise returns #f. +(define (CIEXYZ->color XYZ) + (and (eqv? 3 (length XYZ)) + (apply (lambda (x y z) + (and (real? x) (<= -0.001 x) + (real? y) (<= -0.001 y 1.001) + (real? z) (<= -0.001 z) + (color:construct 'CIEXYZ XYZ #f))) + XYZ))) + +;;@args x y z +;;Returns the CIEXYZ color composed of @1, @2, @3. If the +;;coordinates do not encode a valid CIEXYZ color, then an error is +;;signaled. +(define color:CIEXYZ (color:helper 3 'color:CIEXYZ CIEXYZ->color)) + +;;@body Returns the list of 3 numbers encoding @1 in CIEXYZ. +(define (color->CIEXYZ color) + (if (not (color:color? color)) + (slib:error 'color->CIEXYZ ': 'not 'color? color)) + (case (color:encoding color) + ((CIEXYZ) (append (color:coordinates color) '())) + ((RGB709) (RGB709->CIEXYZ (color:coordinates color))) + ((L*a*b*) (L*a*b*->CIEXYZ (color:coordinates color) + (color:white-point color))) + ((L*u*v*) (L*u*v*->CIEXYZ (color:coordinates color) + (color:white-point color))) + ((sRGB) (sRGB->CIEXYZ (color:coordinates color))) + ((e-sRGB) (e-sRGB->CIEXYZ (color:precision color) + (color:coordinates color))) + ((L*C*h) (L*a*b*->CIEXYZ (L*C*h->L*a*b* (color:coordinates color)) + (color:white-point color))) + (else (slib:error 'color->CIEXYZ ': (color:encoding color) color)))) + + +;;@deftp {Color Space} RGB709 +;;BT.709-4 (03/00) @cite{Parameter values for the HDTV standards for +;;production and international programme exchange} specifies parameter +;;values for chromaticity, sampling, signal format, frame rates, etc., of +;;high definition television signals. +;; +;;An RGB709 color is represented by a list of three inexact numbers +;;between 0 and 1. '(0. 0. 0.) is black '(1. 1. 1.) is white. +;;@end deftp + +;;@body +;;@1 must be a list of 3 numbers. If @1 is valid RGB709 coordinates, +;;then @0 returns the color specified by @1; otherwise returns #f. +(define (RGB709->color RGB) + (and (eqv? 3 (length RGB)) + (apply (lambda (r g b) + (and (real? r) (<= -0.001 r 1.001) + (real? g) (<= -0.001 g 1.001) + (real? b) (<= -0.001 b 1.001) + (color:construct 'RGB709 RGB #f))) + RGB))) + +;;@args r g b +;;Returns the RGB709 color composed of @1, @2, @3. If the +;;coordinates do not encode a valid RGB709 color, then an error is +;;signaled. +(define color:RGB709 (color:helper 3 'color:RGB709 RGB709->color)) + +;;@body Returns the list of 3 numbers encoding @1 in RGB709. +(define (color->RGB709 color) + (if (not (color:color? color)) + (slib:error 'color->RGB709 ': 'not 'color? color)) + (case (color:encoding color) + ((RGB709) (append (color:coordinates color) '())) + ((CIEXYZ) (CIEXYZ->RGB709 (color:coordinates color))) + (else (CIEXYZ->RGB709 (color->CIEXYZ color))))) + +;;@subsubheading Perceptual Uniformity + +;;@noindent +;;Although properly encoding the chromaticity, tristimulus spaces do not +;;match the logarithmic response of human visual systems to intensity. +;;Minimum detectable differences between colors correspond to a smaller +;;range of distances (6:1) in the L*a*b* and L*u*v* spaces than in +;;tristimulus spaces (80:1). For this reason, color distances are +;;computed in L*a*b* (or L*C*h). + +;;@deftp {Color Space} L*a*b* +;;Is a CIE color space which better matches the human visual system's +;;perception of color. It is a list of three numbers: + +;;@itemize @bullet +;;@item +;;0 <= L* <= 100 (CIE @dfn{Lightness}) + +;;@item +;;-500 <= a* <= 500 +;;@item +;;-200 <= b* <= 200 +;;@end itemize +;;@end deftp + +;;@args L*a*b* white-point +;;@1 must be a list of 3 numbers. If @1 is valid L*a*b* coordinates, +;;then @0 returns the color specified by @1; otherwise returns #f. +(define (L*a*b*->color L*a*b* . white-point) + (and (list? L*a*b*) + (eqv? 3 (length L*a*b*)) + (<= 0 (length white-point) 1) + (apply (lambda (L* a* b*) + (and (real? L*) (<= 0 L* 100) + (real? a*) (<= -500 a* 500) + (real? b*) (<= -200 b* 200) + (color:construct + 'L*a*b* L*a*b* + (if (null? white-point) #f + (color->CIEXYZ (car white-point)))))) + L*a*b*))) + +;;@args L* a* b* white-point +;;Returns the L*a*b* color composed of @1, @2, @3 with @4. +;;@args L* a* b* +;;Returns the L*a*b* color composed of @1, @2, @3. If the coordinates +;;do not encode a valid L*a*b* color, then an error is signaled. +(define color:L*a*b* (color:helper 3 'color:L*a*b* L*a*b*->color)) + +;;@args color white-point +;;Returns the list of 3 numbers encoding @1 in L*a*b* with @2. +;;@args color +;;Returns the list of 3 numbers encoding @1 in L*a*b*. +(define (color->L*a*b* color . white-point) + (define (wp) (if (null? white-point) + CIEXYZ:D65 + (color:coordinates (car white-point)))) + (if (not (color:color? color)) + (slib:error 'color->L*a*b* ': 'not 'color? color)) + (case (color:encoding color) + ((L*a*b*) (if (equal? (wp) (color:white-point color)) + (append (color:coordinates color) '()) + (CIEXYZ->L*a*b* (L*a*b*->CIEXYZ color + (color:white-point color)) + (wp)))) + ((L*u*v*) (CIEXYZ->L*a*b* (L*u*v*->CIEXYZ (color:coordinates color) + (color:white-point color)) + (wp))) + ((L*C*h) (if (equal? (wp) (color:white-point color)) + (L*C*h->L*a*b* (color:coordinates color)) + (CIEXYZ->L*a*b* (L*a*b*->CIEXYZ + (L*C*h->L*a*b* (color:coordinates color)) + (color:white-point color)) + (wp)))) + ((CIEXYZ) (CIEXYZ->L*a*b* (color:coordinates color) (wp))) + (else (CIEXYZ->L*a*b* (color->CIEXYZ color) (wp))))) + +;;@deftp {Color Space} L*u*v* +;;Is another CIE encoding designed to better match the human visual +;;system's perception of color. +;;@end deftp + +;;@args L*u*v* white-point +;;@1 must be a list of 3 numbers. If @1 is valid L*u*v* coordinates, +;;then @0 returns the color specified by @1; otherwise returns #f. +(define (L*u*v*->color L*u*v* . white-point) + (and (list? L*u*v*) + (eqv? 3 (length L*u*v*)) + (<= 0 (length white-point) 1) + (apply (lambda (L* u* v*) + (and (real? L*) (<= 0 L* 100) + (real? u*) (<= -500 u* 500) + (real? v*) (<= -200 v* 200) + (color:construct + 'L*u*v* L*u*v* + (if (null? white-point) #f + (color->CIEXYZ (car white-point)))))) + L*u*v*))) + +;;@args L* u* v* white-point +;;Returns the L*u*v* color composed of @1, @2, @3 with @4. +;;@args L* u* v* +;;Returns the L*u*v* color composed of @1, @2, @3. If the coordinates +;;do not encode a valid L*u*v* color, then an error is signaled. +(define color:L*u*v* (color:helper 3 'color:L*u*v* L*u*v*->color)) + +;;@args color white-point +;;Returns the list of 3 numbers encoding @1 in L*u*v* with @2. +;;@args color +;;Returns the list of 3 numbers encoding @1 in L*u*v*. +(define (color->L*u*v* color . white-point) + (define (wp) (if (null? white-point) + (color:white-point color) + (car white-point))) + (if (not (color:color? color)) + (slib:error 'color->L*u*v* ': 'not 'color? color)) + (case (color:encoding color) + ((L*u*v*) (append (color:coordinates color) '())) + ((L*a*b*) (CIEXYZ->L*u*v* (L*a*b*->CIEXYZ (color:coordinates color) + (color:white-point color)) + (wp))) + ((L*C*h) (CIEXYZ->L*u*v* + (L*a*b*->CIEXYZ (L*C*h->L*a*b* (color:coordinates color)) + (color:white-point color)) + (wp))) + ((CIEXYZ) (CIEXYZ->L*u*v* (color:coordinates color) (wp))) + (else (CIEXYZ->L*u*v* (color->CIEXYZ color) (wp))))) + +;;@subsubheading Cylindrical Coordinates + +;;@noindent +;;HSL (Hue Saturation Lightness), HSV (Hue Saturation Value), HSI (Hue +;;Saturation Intensity) and HCI (Hue Chroma Intensity) are cylindrical +;;color spaces (with angle hue). But these spaces are all defined in +;;terms device-dependent RGB spaces. + +;;@noindent +;;One might wonder if there is some fundamental reason why intuitive +;;specification of color must be device-dependent. But take heart! A +;;cylindrical system can be based on L*a*b* and is used for predicting how +;;close colors seem to observers. + +;;@deftp {Color Space} L*C*h +;;Expresses the *a and b* of L*a*b* in polar coordinates. It is a list of +;;three numbers: + +;;@itemize @bullet +;;@item +;;0 <= L* <= 100 (CIE @dfn{Lightness}) + +;;@item +;;C* (CIE @dfn{Chroma}) is the distance from the neutral (gray) axis. +;;@item +;;0 <= h <= 360 (CIE @dfn{Hue}) is the angle. +;;@end itemize +;; +;;The colors by quadrant of h are: + +;;@multitable @columnfractions .20 .60 .20 +;;@item 0 @tab red, orange, yellow @tab 90 +;;@item 90 @tab yellow, yellow-green, green @tab 180 +;;@item 180 @tab green, cyan (blue-green), blue @tab 270 +;;@item 270 @tab blue, purple, magenta @tab 360 +;;@end multitable + +;;@end deftp + + +;;@args L*C*h white-point +;;@1 must be a list of 3 numbers. If @1 is valid L*C*h coordinates, +;;then @0 returns the color specified by @1; otherwise returns #f. +(define (L*C*h->color L*C*h . white-point) + (and (list? L*C*h) + (eqv? 3 (length L*C*h)) + (<= 0 (length white-point) 1) + (apply (lambda (L* C* h) + (and (real? L*) (<= 0 L* 100) + (real? C*) (<= 0 C*) + (real? h) (<= 0 h 360) + (color:construct + 'L*C*h L*C*h + (if (null? white-point) #f + (color->CIEXYZ (car white-point)))))) + L*C*h))) + +;;@args L* C* h white-point +;;Returns the L*C*h color composed of @1, @2, @3 with @4. +;;@args L* C* h +;;Returns the L*C*h color composed of @1, @2, @3. If the coordinates +;;do not encode a valid L*C*h color, then an error is signaled. +(define color:L*C*h (color:helper 3 'color:L*C*h L*C*h->color)) + +;;@args color white-point +;;Returns the list of 3 numbers encoding @1 in L*C*h with @2. +;;@args color +;;Returns the list of 3 numbers encoding @1 in L*C*h. +(define (color->L*C*h color . white-point) + (if (not (color:color? color)) + (slib:error 'color->L*C*h ': 'not 'color? color)) + (if (and (eqv? 'L*C*h (color:encoding color)) + (equal? (color:white-point color) + (if (null? white-point) + CIEXYZ:D65 + (color:coordinates (car white-point))))) + (append (color:coordinates color) '()) + (L*a*b*->L*C*h (apply color->L*a*b* color white-point)))) + +;;@subsubheading Digital Color Spaces + +;;@noindent +;;The color spaces discussed so far are impractical for image data because +;;of numerical precision and computational requirements. In 1998 the IEC +;;adopted @cite{A Standard Default Color Space for the Internet - sRGB} +;;(@url{http://www.w3.org/Graphics/Color/sRGB}). sRGB was cleverly +;;designed to employ the 24-bit (256x256x256) color encoding already in +;;widespread use; and the 2.2 gamma intrinsic to CRT monitors. + +;;@noindent +;;Conversion from CIEXYZ to digital (sRGB) color spaces is accomplished by +;;conversion first to a RGB709 tristimulus space with D65 white-point; +;;then each coordinate is individually subjected to the same non-linear +;;mapping. Inverse operations in the reverse order create the inverse +;;transform. + +;;@deftp {Color Space} sRGB +;;Is "A Standard Default Color Space for the Internet". Most display +;;monitors will work fairly well with sRGB directly. Systems using ICC +;;profiles +;;@ftindex ICC Profile +;;@footnote{ +;;@noindent +;;A comprehensive encoding of transforms between CIEXYZ and device color +;;spaces is the International Color Consortium profile format, +;;ICC.1:1998-09: + +;;@quotation +;;The intent of this format is to provide a cross-platform device profile +;;format. Such device profiles can be used to translate color data +;;created on one device into another device's native color space. +;;@end quotation +;;} +;;should work very well with sRGB. + +;;An sRGB color is a triplet of integers ranging 0 to 255. D65 is the +;;white-point for sRGB. +;;@end deftp + +;;@body +;;@1 must be a list of 3 numbers. If @1 is valid sRGB coordinates, +;;then @0 returns the color specified by @1; otherwise returns #f. +(define (sRGB->color RGB) + (and (eqv? 3 (length RGB)) + (apply (lambda (r g b) + (and (integer? r) (<= 0 r 255) + (integer? g) (<= 0 g 255) + (integer? b) (<= 0 b 255) + (color:construct 'sRGB RGB #f))) + RGB))) + +;;@args r g b +;;Returns the sRGB color composed of @1, @2, @3. If the +;;coordinates do not encode a valid sRGB color, then an error is +;;signaled. +(define color:sRGB (color:helper 3 'color:sRGB sRGB->color)) + +;;@deftp {Color Space} xRGB +;;Represents the equivalent sRGB color with a single 24-bit integer. The +;;most significant 8 bits encode red, the middle 8 bits blue, and the +;;least significant 8 bits green. +;;@end deftp + +;;@body +;;Returns the list of 3 integers encoding @1 in sRGB. +(define (color->sRGB color) + (if (not (color:color? color)) + (slib:error 'color->sRGB ': 'not 'color? color)) + (case (color:encoding color) + ((CIEXYZ) (CIEXYZ->sRGB (color:coordinates color))) + ((sRGB) (append (color:coordinates color) '())) + (else (CIEXYZ->sRGB (color->CIEXYZ color))))) + +;;@body Returns the 24-bit integer encoding @1 in sRGB. +(define (color->xRGB color) (sRGB->xRGB (color->sRGB color))) + +;;@args k +;;Returns the sRGB color composed of the 24-bit integer @1. +(define (xRGB->color xRGB) + (and (integer? xRGB) (<= 0 xRGB #xffffff) + (sRGB->color (xRGB->sRGB xRGB)))) + + +;;@deftp {Color Space} e-sRGB +;;Is "Photography - Electronic still picture imaging - Extended sRGB color +;;encoding" (PIMA 7667:2001). It extends the gamut of sRGB; and its +;;higher precision numbers provide a larger dynamic range. +;; +;;A triplet of integers represent e-sRGB colors. Three precisions are +;;supported: + +;;@table @r +;;@item e-sRGB10 +;;0 to 1023 +;;@item e-sRGB12 +;;0 to 4095 +;;@item e-sRGB16 +;;0 to 65535 +;;@end table +;;@end deftp + +(define (esRGB->color prec-RGB) + (and (eqv? 4 (length prec-RGB)) + (let ((range (and (pair? prec-RGB) + (case (car prec-RGB) + ((10) 1023) + ((12) 4095) + ((16) 65535) + (else #f))))) + (apply (lambda (precision r g b) + (and (integer? r) (<= 0 r range) + (integer? g) (<= 0 g range) + (integer? b) (<= 0 b range) + (color:construct 'e-sRGB (cdr prec-RGB) precision))) + prec-RGB)))) + +;;@body @1 must be the integer 10, 12, or 16. @2 must be a list of 3 +;;numbers. If @2 is valid e-sRGB coordinates, then @0 returns the color +;;specified by @2; otherwise returns #f. +(define (e-sRGB->color precision RGB) + (esRGB->color (cons precision RGB))) + +;;@args 10 r g b +;;Returns the e-sRGB10 color composed of integers @2, @3, @4. +;;@args 12 r g b +;;Returns the e-sRGB12 color composed of integers @2, @3, @4. +;;@args 16 r g b +;;Returns the e-sRGB16 color composed of integers @2, @3, @4. +;;If the coordinates do not encode a valid e-sRGB color, then an error +;;is signaled. +(define color:e-sRGB (color:helper 4 'color:e-sRGB esRGB->color)) + +;;@body @1 must be the integer 10, 12, or 16. @0 returns the list of 3 +;;integers encoding @2 in sRGB10, sRGB12, or sRGB16. +(define (color->e-sRGB precision color) + (case precision + ((10 12 16) + (if (not (color:color? color)) + (slib:error 'color->e-sRGB ': 'not 'color? color))) + (else (slib:error 'color->e-sRGB ': 'invalid 'precision precision))) + (case (color:encoding color) + ((e-sRGB) (e-sRGB->e-sRGB (color:precision color) + (color:coordinates color) + precision)) + ((sRGB) (sRGB->e-sRGB precision (color:coordinates color))) + (else (CIEXYZ->e-sRGB precision (color->CIEXYZ color))))) + +;;;; Polytypic Colors + +;;; The rest of documentation is in "slib.texi" +;@ +(define D65 (CIEXYZ->color CIEXYZ:D65)) +(define D50 (CIEXYZ->color CIEXYZ:D50)) +;@ +(define (color? obj . typ) + (cond ((not (color:color? obj)) #f) + ((null? typ) #t) + (else (eqv? (car typ) (color:encoding obj))))) +;@ +(define (make-color space . args) + (case space + ((CIEXYZ) (CIEXYZ->color args)) + ((RGB709) (RGB709->color args)) + ((L*a*b*) (L*a*b*->color args)) + ((L*u*v*) (L*u*v*->color args)) + ((L*C*h) (L*C*h->color args)) + ((sRGB) (sRGB->color args)) + ((xRGB) (apply xRGB->color args)) + ((e-sRGB) (e-sRGB->color args)) + (else (slib:error 'make-color ': 'not 'space? space)))) +;@ +(define color-space color:encoding) +;@ +(define (color-precision color) + (if (not (color:color? color)) + (slib:error 'color-precision ': 'not 'color? color)) + (case (color:encoding color) + ((e-sRGB) (color:precision color)) + ((sRGB) 8) + (else #f))) +;@ +(define (color-white-point color) + (if (not (color:color? color)) + (slib:error 'color-white-point ': 'not 'color? color)) + (case (color:encoding color) + ((L*a*b*) (color:CIEXYZ (color:white-point color))) + ((L*u*v*) (color:CIEXYZ (color:white-point color))) + ((L*C*h) (color:CIEXYZ (color:white-point color))) + ((RGB709) D65) + ((sRGB) D65) + ((e-sRGB) D65) + (else #f))) +;@ +(define (convert-color color encoding . opt-arg) + (define (noarg) + (if (not (null? opt-arg)) + (slib:error 'convert-color ': 'too-many 'arguments opt-arg))) + (if (not (color:color? color)) + (slib:error 'convert-color ': 'not 'color? color)) + (case encoding + ((CIEXYZ) (noarg) (CIEXYZ->color (color->CIEXYZ color))) + ((RGB709) (noarg) (RGB709->color (color->RGB709 color))) + ((sRGB) (noarg) (sRGB->color (color->sRGB color))) + ((e-sRGB) (e-sRGB->color (car opt-arg) (color->e-sRGB (car opt-arg) color))) + ((L*a*b*) (apply L*a*b*->color (color->L*a*b* color) opt-arg)) + ((L*u*v*) (apply L*u*v*->color (color->L*u*v* color) opt-arg)) + ((L*C*h) (apply L*C*h->color (color->L*C*h color) opt-arg)) + (else (slib:error 'convert-color ': encoding '?)))) + +;;; External color representations +;@ +(define (color->string color) + (if (not (color:color? color)) + (slib:error 'color->string ': 'not 'color? color)) + (case (color:encoding color) + ((CIEXYZ) (apply sprintf #f "CIEXYZ:%g/%g/%g" + (color:coordinates color))) + ((L*a*b*) (apply sprintf #f "CIELab:%.4f/%.4f/%.4f" + (if (equal? CIEXYZ:D65 (color:white-point color)) + (color:coordinates color) + (CIEXYZ->L*a*b* (L*a*b*->CIEXYZ + (color:coordinates color) + (color:white-point color)))))) + ((L*u*v*) (apply sprintf #f "CIELuv:%.4f/%.4f/%.4f" + (if (equal? CIEXYZ:D65 (color:white-point color)) + (color:coordinates color) + (CIEXYZ->L*u*v* (L*u*v*->CIEXYZ + (color:coordinates color) + (color:white-point color)))))) + ((L*C*h) (apply sprintf #f "CIELCh:%.4f/%.4f/%.4f" + (if (equal? CIEXYZ:D65 (color:white-point color)) + (color:coordinates color) + (L*a*b*->L*C*h + (CIEXYZ->L*a*b* (L*a*b*->CIEXYZ + (L*C*h->L*a*b* + (color:coordinates color)) + (color:white-point color))))))) + ((RGB709) (apply sprintf #f "RGBi:%g/%g/%g" (color:coordinates color))) + ((sRGB) (apply sprintf #f "sRGB:%d/%d/%d" (color:coordinates color))) + ((e-sRGB) (apply sprintf #f "e-sRGB%d:%d/%d/%d" + (color:precision color) (color:coordinates color))) + (else (slib:error 'color->string ': (color:encoding color) color)))) +;@ +(define (string->color str) + (define prec #f) (define coding #f) + (define x #f) (define y #f) (define z #f) + (cond ((eqv? 4 (sscanf str " %[CIEXYZciexyzLABUVlabuvHhRrGg709]:%f/%f/%f" + coding x y z)) + (case (string-ci->symbol coding) + ((CIEXYZ) (color:CIEXYZ x y z)) + ((CIELab) (color:L*a*b* x y z)) + ((CIELuv) (color:L*u*v* x y z)) + ((CIELCh) (color:L*C*h x y z)) + ((RGBi ; Xlib - C Language X Interface + RGB709) (color:RGB709 x y z)) + (else #f))) + ((eqv? 4 (sscanf str " %[sRGBSrgb]:%d/%d/%d" coding x y z)) + (case (string-ci->symbol coding) + ((sRGB) (color:sRGB x y z)) + (else #f))) + ((eqv? 5 (sscanf str " %[-esRGBESrgb]%d:%d/%d/%d" coding prec x y z)) + (case (string-ci->symbol coding) + ((e-sRGB) (color:e-sRGB prec x y z)) + (else #f))) + ((eqv? 2 (sscanf str " %[sRGBxXXRGB]:%6x%[/0-9a-fA-F]" coding x y)) + (case (string-ci->symbol coding) + ((sRGB + xRGB + sRGBx) (xRGB->color x)) + (else #f))) + ((and (eqv? 2 (sscanf str " %[#0xX]%6[0-9a-fA-F]%[0-9a-fA-F]" + coding x y)) + (eqv? 6 (string-length x)) + (member coding '("#" "#x" "0x" "#X" "0X"))) + (xRGB->color (string->number x 16))) + (else #f))) + +;;;; visual color metrics +;@ +(define (CIE:DE* color1 color2 . white-point) + (L*a*b*:DE* (apply color->L*a*b* color1 white-point) + (apply color->L*a*b* color2 white-point))) +;@ +(define (CIE:DE*94 color1 color2 . parametric-factors) + (apply L*C*h:DE*94 + (color->L*C*h color1) + (color->L*C*h color2) + parametric-factors)) +;@ +(define (CMC:DE* color1 color2 . parametric-factors) + (apply CMC-DE + (color->L*C*h color1) + (color->L*C*h color2) + parametric-factors)) + +;;; Short names + +;; (define CIEXYZ color:CIEXYZ) +;; (define RGB709 color:RGB709) +;; (define L*a*b* color:L*a*b*) +;; (define L*u*v* color:L*u*v*) +;; (define L*C*h color:L*C*h) +;; (define sRGB color:sRGB) +;; (define xRGB xRGB->color) +;; (define e-sRGB color:e-sRGB) diff --git a/color.txi b/color.txi new file mode 100644 index 0000000..ccbb3de --- /dev/null +++ b/color.txi @@ -0,0 +1,345 @@ +@subsubheading Measurement-based Color Spaces + +@noindent +@cindex tristimulus +The @dfn{tristimulus} color spaces are those whose component values +@cindex tristimulus +are proportional measurements of light intensity. The CIEXYZ(1931) +system provides 3 sets of spectra to convolve with a spectrum of +interest. The result of those convolutions is coordinates in CIEXYZ +space. All tristimuls color spaces are related to CIEXYZ by linear +transforms, namely matrix multiplication. Of the color spaces listed +here, CIEXYZ and RGB709 are tristimulus spaces. + +@deftp {Color Space} CIEXYZ +The CIEXYZ color space covers the full @dfn{gamut}. +@cindex gamut +It is the basis for color-space conversions. + +CIEXYZ is a list of three inexact numbers between 0 and 1.1. +'(0. 0. 0.) is black; '(1. 1. 1.) is white. +@end deftp + + +@defun ciexyz->color xyz + +@var{xyz} must be a list of 3 numbers. If @var{xyz} is valid CIEXYZ coordinates, +then @code{ciexyz->color} returns the color specified by @var{xyz}; otherwise returns #f. +@end defun + +@defun color:ciexyz x y z + +Returns the CIEXYZ color composed of @var{x}, @var{y}, @var{z}. If the +coordinates do not encode a valid CIEXYZ color, then an error is +signaled. +@end defun + +@defun color->ciexyz color +Returns the list of 3 numbers encoding @var{color} in CIEXYZ. +@end defun +@deftp {Color Space} RGB709 +BT.709-4 (03/00) @cite{Parameter values for the HDTV standards for +production and international programme exchange} specifies parameter +values for chromaticity, sampling, signal format, frame rates, etc., of +high definition television signals. + +An RGB709 color is represented by a list of three inexact numbers +between 0 and 1. '(0. 0. 0.) is black '(1. 1. 1.) is white. +@end deftp + + +@defun rgb709->color rgb + +@var{rgb} must be a list of 3 numbers. If @var{rgb} is valid RGB709 coordinates, +then @code{rgb709->color} returns the color specified by @var{rgb}; otherwise returns #f. +@end defun + +@defun color:rgb709 r g b + +Returns the RGB709 color composed of @var{r}, @var{g}, @var{b}. If the +coordinates do not encode a valid RGB709 color, then an error is +signaled. +@end defun + +@defun color->rgb709 color +Returns the list of 3 numbers encoding @var{color} in RGB709. +@end defun +@subsubheading Perceptual Uniformity + +@noindent +Although properly encoding the chromaticity, tristimulus spaces do not +match the logarithmic response of human visual systems to intensity. +Minimum detectable differences between colors correspond to a smaller +range of distances (6:1) in the L*a*b* and L*u*v* spaces than in +tristimulus spaces (80:1). For this reason, color distances are +computed in L*a*b* (or L*C*h). + +@deftp {Color Space} L*a*b* +Is a CIE color space which better matches the human visual system's +perception of color. It is a list of three numbers: + +@itemize @bullet +@item +0 <= L* <= 100 (CIE @dfn{Lightness}) +@cindex Lightness + +@item +-500 <= a* <= 500 +@item +-200 <= b* <= 200 +@end itemize +@end deftp + + +@defun l*a*b*->color L*a*b* white-point + +@var{L*a*b*} must be a list of 3 numbers. If @var{L*a*b*} is valid L*a*b* coordinates, +then @code{l*a*b*->color} returns the color specified by @var{L*a*b*}; otherwise returns #f. +@end defun + +@defun color:l*a*b* L* a* b* white-point + +Returns the L*a*b* color composed of @var{L*}, @var{a*}, @var{b*} with @var{white-point}. + +@defunx color:l*a*b* L* a* b* +Returns the L*a*b* color composed of @var{L*}, @var{a*}, @var{b*}. If the coordinates +do not encode a valid L*a*b* color, then an error is signaled. +@end defun + +@defun color->l*a*b* color white-point + +Returns the list of 3 numbers encoding @var{color} in L*a*b* with @var{white-point}. + +@defunx color->l*a*b* color +Returns the list of 3 numbers encoding @var{color} in L*a*b*. +@end defun +@deftp {Color Space} L*u*v* +Is another CIE encoding designed to better match the human visual +system's perception of color. +@end deftp + + +@defun l*u*v*->color L*u*v* white-point + +@var{L*u*v*} must be a list of 3 numbers. If @var{L*u*v*} is valid L*u*v* coordinates, +then @code{l*u*v*->color} returns the color specified by @var{L*u*v*}; otherwise returns #f. +@end defun + +@defun color:l*u*v* L* u* v* white-point + +Returns the L*u*v* color composed of @var{L*}, @var{u*}, @var{v*} with @var{white-point}. + +@defunx color:l*u*v* L* u* v* +Returns the L*u*v* color composed of @var{L*}, @var{u*}, @var{v*}. If the coordinates +do not encode a valid L*u*v* color, then an error is signaled. +@end defun + +@defun color->l*u*v* color white-point + +Returns the list of 3 numbers encoding @var{color} in L*u*v* with @var{white-point}. + +@defunx color->l*u*v* color +Returns the list of 3 numbers encoding @var{color} in L*u*v*. +@end defun +@subsubheading Cylindrical Coordinates + +@noindent +HSL (Hue Saturation Lightness), HSV (Hue Saturation Value), HSI (Hue +Saturation Intensity) and HCI (Hue Chroma Intensity) are cylindrical +color spaces (with angle hue). But these spaces are all defined in +terms device-dependent RGB spaces. + +@noindent +One might wonder if there is some fundamental reason why intuitive +specification of color must be device-dependent. But take heart! A +cylindrical system can be based on L*a*b* and is used for predicting how +close colors seem to observers. + +@deftp {Color Space} L*C*h +Expresses the *a and b* of L*a*b* in polar coordinates. It is a list of +three numbers: + +@itemize @bullet +@item +0 <= L* <= 100 (CIE @dfn{Lightness}) +@cindex Lightness + +@item +C* (CIE @dfn{Chroma}) is the distance from the neutral (gray) axis. +@cindex Chroma +@item +0 <= h <= 360 (CIE @dfn{Hue}) is the angle. +@cindex Hue +@end itemize + +The colors by quadrant of h are: + +@multitable @columnfractions .20 .60 .20 +@item 0 @tab red, orange, yellow @tab 90 +@item 90 @tab yellow, yellow-green, green @tab 180 +@item 180 @tab green, cyan (blue-green), blue @tab 270 +@item 270 @tab blue, purple, magenta @tab 360 +@end multitable + +@end deftp + + +@defun l*c*h->color L*C*h white-point + +@var{L*C*h} must be a list of 3 numbers. If @var{L*C*h} is valid L*C*h coordinates, +then @code{l*c*h->color} returns the color specified by @var{L*C*h}; otherwise returns #f. +@end defun + +@defun color:l*c*h L* C* h white-point + +Returns the L*C*h color composed of @var{L*}, @var{C*}, @var{h} with @var{white-point}. + +@defunx color:l*c*h L* C* h +Returns the L*C*h color composed of @var{L*}, @var{C*}, @var{h}. If the coordinates +do not encode a valid L*C*h color, then an error is signaled. +@end defun + +@defun color->l*c*h color white-point + +Returns the list of 3 numbers encoding @var{color} in L*C*h with @var{white-point}. + +@defunx color->l*c*h color +Returns the list of 3 numbers encoding @var{color} in L*C*h. +@end defun +@subsubheading Digital Color Spaces + +@noindent +The color spaces discussed so far are impractical for image data because +of numerical precision and computational requirements. In 1998 the IEC +adopted @cite{A Standard Default Color Space for the Internet - sRGB} +(@url{http://www.w3.org/Graphics/Color/sRGB}). sRGB was cleverly +designed to employ the 24-bit (256x256x256) color encoding already in +widespread use; and the 2.2 gamma intrinsic to CRT monitors. + +@noindent +Conversion from CIEXYZ to digital (sRGB) color spaces is accomplished by +conversion first to a RGB709 tristimulus space with D65 white-point; +then each coordinate is individually subjected to the same non-linear +mapping. Inverse operations in the reverse order create the inverse +transform. + +@deftp {Color Space} sRGB +Is "A Standard Default Color Space for the Internet". Most display +monitors will work fairly well with sRGB directly. Systems using ICC +profiles +@ftindex ICC Profile +@footnote{ +@noindent +A comprehensive encoding of transforms between CIEXYZ and device color +spaces is the International Color Consortium profile format, +ICC.1:1998-09: + +@quotation +The intent of this format is to provide a cross-platform device profile +format. Such device profiles can be used to translate color data +created on one device into another device's native color space. +@end quotation +} +should work very well with sRGB. + +@end deftp + + +@defun srgb->color rgb + +@var{rgb} must be a list of 3 numbers. If @var{rgb} is valid sRGB coordinates, +then @code{srgb->color} returns the color specified by @var{rgb}; otherwise returns #f. +@end defun + +@defun color:srgb r g b + +Returns the sRGB color composed of @var{r}, @var{g}, @var{b}. If the +coordinates do not encode a valid sRGB color, then an error is +signaled. +@end defun +@deftp {Color Space} xRGB +Represents the equivalent sRGB color with a single 24-bit integer. The +most significant 8 bits encode red, the middle 8 bits blue, and the +least significant 8 bits green. +@end deftp + + +@defun color->srgb color + +Returns the list of 3 integers encoding @var{color} in sRGB. +@end defun + +@defun color->xrgb color +Returns the 24-bit integer encoding @var{color} in sRGB. +@end defun + +@defun xrgb->color k + +Returns the sRGB color composed of the 24-bit integer @var{k}. +@end defun +@deftp {Color Space} e-sRGB +Is "Photography - Electronic still picture imaging - Extended sRGB color +encoding" (PIMA 7667:2001). It extends the gamut of sRGB; and its +higher precision numbers provide a larger dynamic range. + +A triplet of integers represent e-sRGB colors. Three precisions are +supported: + +@table @r +@item e-sRGB10 +0 to 1023 +@item e-sRGB12 +0 to 4095 +@item e-sRGB16 +0 to 65535 +@end table +@end deftp + + +@defun e-srgb->color precision rgb +@var{precision} must be the integer 10, 12, or 16. @var{rgb} must be a list of 3 +numbers. If @var{rgb} is valid e-sRGB coordinates, then @code{e-srgb->color} returns the color +specified by @var{rgb}; otherwise returns #f. +@end defun + +@defun color:e-srgb 10 r g b + +Returns the e-sRGB10 color composed of integers @var{r}, @var{g}, @var{b}. + +@defunx color:e-srgb 12 r g b +Returns the e-sRGB12 color composed of integers @var{r}, @var{g}, @var{b}. + +@defunx color:e-srgb 16 r g b +Returns the e-sRGB16 color composed of integers @var{r}, @var{g}, @var{b}. +If the coordinates do not encode a valid e-sRGB color, then an error +is signaled. +@end defun + +@defun color->e-srgb precision color +@var{precision} must be the integer 10, 12, or 16. @code{color->e-srgb} returns the list of 3 +integers encoding @var{color} in sRGB10, sRGB12, or sRGB16. +@end defun + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/colornam.scm b/colornam.scm new file mode 100644 index 0000000..e8e8812 --- /dev/null +++ b/colornam.scm @@ -0,0 +1,117 @@ +;;; "colornam.scm" color name databases +;Copyright 2001, 2002 Aubrey Jaffer +; +;Permission to copy this software, to modify it, to redistribute it, +;to distribute modified versions, and to use it for any purpose is +;granted, subject to the following restrictions and understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warranty or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +(require 'databases) +(require 'color) + +;;@code{(require 'color-names)} +;;@ftindex color-names + +;;@noindent +;;Rather than ballast the color dictionaries with numbered grays, +;;@code{file->color-dictionary} discards them. They are provided +;;through the @code{grey} procedure: + +;;@body +;;Returns @code{(inexact->exact (round (* k 2.55)))}, the X11 color +;;grey@i{<k>}. +(define (grey k) + (define int (inexact->exact (round (* k 2.55)))) + (color:sRGB int int int)) + +;;@noindent +;;A color dictionary is a database table relating @dfn{canonical} +;;color-names to color-strings +;;(@pxref{Color Data-Type, External Representation}). +;; +;;@noindent +;;The column names in a color dictionary are unimportant; the first +;;field is the key, and the second is the color-string. + +;;@body Returns a downcased copy of the string or symbol @1 with +;;@samp{_}, @samp{-}, and whitespace removed. +(define (color-name:canonicalize name) + (list->string + (apply append (map (lambda (c) (if (or (char-alphabetic? c) + (char-numeric? c)) + (list (char-downcase c)) + '())) + (string->list (if (symbol? name) + (symbol->string name) + name)))))) + +;;@args name table1 table2 @dots{} +;; +;;@2, @3, @dots{} must be color-dictionary tables. @0 searches for the +;;canonical form of @1 in @2, @3, @dots{} in order; returning the +;;color-string of the first matching record; #f otherwise. +(define (color-name->color name . tables) + (define cancol (color-name:canonicalize name)) + (define found #f) + (do ((tabs tables (cdr tabs))) + ((or found (null? tabs)) (and found (string->color found))) + (set! found (((car tabs) 'get 2) cancol)))) + +;;@args table1 table2 @dots{} +;; +;;@1, @2, @dots{} must be color-dictionary tables. @0 returns a +;;procedure which searches for the canonical form of its string argument +;;in @1, @2, @dots{}; returning the color-string of the first matching +;;record; and #f otherwise. +(define (color-dictionaries->lookup . tables) + (define procs (map (lambda (tab) (tab 'get 2)) tables)) + (lambda (name) + (define cancol (color-name:canonicalize name)) + (define found #f) + (do ((procs procs (cdr procs))) + ((or found (null? procs)) (and found (string->color found))) + (set! found ((car procs) cancol))))) + +;;@args name rdb base-table-type +;; +;;@2 must be a string naming a relational database file; and the symbol +;;@1 a table therein. The database will be opened as +;;@var{base-table-type}. @0 returns the read-only table @1 in database +;;@1 if it exists; #f otherwise. +;; +;;@args name rdb +;; +;;@2 must be an open relational database or a string naming a relational +;;database file; and the symbol @1 a table therein. @0 returns the +;;read-only table @1 in database @1 if it exists; #f otherwise. +(define (color-dictionary table-name . *db*) + (define rdb (apply open-database *db*)) + (and rdb ((rdb 'open-table) table-name #f))) + + +;;@args name rdb base-table-type +;;@args name rdb +;; +;;@2 must be a string naming a relational database file; and the symbol +;;@1 a table therein. If the symbol @3 is provided, the database will +;;be opened as @3. @0 creates a top-level definition of the symbol @1 +;;to a lookup procedure for the color dictionary @1 in @2. +;; +;;The value returned by @0 is unspecified. +(define (load-color-dictionary table-name . db) + (slib:eval + `(define ,table-name + (color-dictionaries->lookup + (color-dictionary ',table-name + ,@(map (lambda (arg) (list 'quote arg)) db)))))) diff --git a/colornam.txi b/colornam.txi new file mode 100644 index 0000000..f72167b --- /dev/null +++ b/colornam.txi @@ -0,0 +1,75 @@ +@code{(require 'color-names)} +@ftindex color-names + +@noindent +Rather than ballast the color dictionaries with numbered grays, +@code{file->color-dictionary} discards them. They are provided +through the @code{grey} procedure: + + +@defun grey k + +Returns @code{(inexact->exact (round (* k 2.55)))}, the X11 color +grey@i{<k>}. +@end defun +@noindent +A color dictionary is a database table relating @dfn{canonical} +@cindex canonical +color-names to color-strings +(@pxref{Color Data-Type, External Representation}). + +@noindent +The column names in a color dictionary are unimportant; the first +field is the key, and the second is the color-string. + + +@defun color-name:canonicalize name +Returns a downcased copy of the string or symbol @var{name} with +@samp{_}, @samp{-}, and whitespace removed. +@end defun + +@defun color-name->color name table1 table2 @dots{} + + +@var{table1}, @var{table2}, @dots{} must be color-dictionary tables. @code{color-name->color} searches for the +canonical form of @var{name} in @var{table1}, @var{table2}, @dots{} in order; returning the +color-string of the first matching record; #f otherwise. +@end defun + +@defun color-dictionaries->lookup table1 table2 @dots{} + + +@var{table1}, @var{table2}, @dots{} must be color-dictionary tables. @code{color-dictionaries->lookup} returns a +procedure which searches for the canonical form of its string argument +in @var{table1}, @var{table2}, @dots{}; returning the color-string of the first matching +record; and #f otherwise. +@end defun + +@defun color-dictionary name rdb base-table-type + + +@var{rdb} must be a string naming a relational database file; and the symbol +@var{name} a table therein. The database will be opened as +@var{base-table-type}. @code{color-dictionary} returns the read-only table @var{name} in database +@var{name} if it exists; #f otherwise. + + +@defunx color-dictionary name rdb + +@var{rdb} must be an open relational database or a string naming a relational +database file; and the symbol @var{name} a table therein. @code{color-dictionary} returns the +read-only table @var{name} in database @var{name} if it exists; #f otherwise. +@end defun + +@defun load-color-dictionary name rdb base-table-type + + +@defunx load-color-dictionary name rdb + +@var{rdb} must be a string naming a relational database file; and the symbol +@var{name} a table therein. If the symbol @var{base-table-type} is provided, the database will +be opened as @var{base-table-type}. @code{load-color-dictionary} creates a top-level definition of the symbol @var{name} +to a lookup procedure for the color dictionary @var{name} in @var{rdb}. + +The value returned by @code{load-color-dictionary} is unspecified. +@end defun diff --git a/colorspc.scm b/colorspc.scm new file mode 100644 index 0000000..3a88767 --- /dev/null +++ b/colorspc.scm @@ -0,0 +1,536 @@ +;;; "colorspc.scm" color-space conversions +;Copyright 2001, 2002 Aubrey Jaffer +; +;Permission to copy this software, to modify it, to redistribute it, +;to distribute modified versions, and to use it for any purpose is +;granted, subject to the following restrictions and understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warranty or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +(require 'logical) +(require 'multiarg/and-) +(require-if 'compiling 'sort) +(require-if 'compiling 'ciexyz) +;@ +(define (color:linear-transform matrix row) + (map (lambda (mrow) (apply + (map * mrow row))) + matrix)) + +(define RGB709:into-matrix + '(( 3.240479 -1.537150 -0.498535 ) + ( -0.969256 1.875992 0.041556 ) + ( 0.055648 -0.204043 1.057311 ))) + +;;; http://www.pima.net/standards/it10/PIMA7667/PIMA7667-2001.PDF gives +;;; matrix identical to sRGB:from-matrix, but colors drift under +;;; repeated conversions to and from CIEXYZ. Instead use RGB709. + +(define RGB709:from-matrix + '(( 0.412453 0.357580 0.180423 ) + ( 0.212671 0.715160 0.072169 ) + ( 0.019334 0.119193 0.950227 ))) + +;; From http://www.cs.rit.edu/~ncs/color/t_convert.html +;@ +(define (CIEXYZ->RGB709 XYZ) + (color:linear-transform RGB709:into-matrix XYZ)) +(define (RGB709->CIEXYZ rgb) + (color:linear-transform RGB709:from-matrix rgb)) + +;;; From http://www.w3.org/Graphics/Color/sRGB.html + +(define sRGB-log + (lambda (sv) + (if (<= sv 0.00304) + (* 12.92 sv) + (+ -0.055 (* 1.055 (expt sv 10/24)))))) +(define sRGB-exp + (lambda (x) + (if (<= x 0.03928) + (/ x 12.92) + (expt (/ (+ 0.055 x) 1.055) 2.4)))) + +;; Clipping as recommended by sRGB spec. +;@ +(define (CIEXYZ->sRGB XYZ) + (map (lambda (sv) + (inexact->exact (round (* 255 (sRGB-log (max 0 (min 1 sv))))))) + (color:linear-transform RGB709:into-matrix XYZ))) +(define (sRGB->CIEXYZ sRGB) + (color:linear-transform + RGB709:from-matrix + (map sRGB-exp + (map (lambda (b8v) (/ b8v 255.0)) sRGB)))) + +;;; sRGB values are sometimes written as 24-bit integers 0xRRGGBB +;@ +(define (xRGB->sRGB xRGB) + (list (ash xRGB -16) + (logand (ash xRGB -8) 255) + (logand xRGB 255))) +(define (sRGB->xRGB sRGB) + (apply + (map * sRGB '(#x10000 #x100 #x1)))) +;@ +(define (xRGB->CIEXYZ xRGB) (sRGB->CIEXYZ (xRGB->sRGB xRGB))) +(define (CIEXYZ->xRGB xyz) (sRGB->xRGB (CIEXYZ->sRGB xyz))) + +;;; http://www.pima.net/standards/it10/PIMA7667/PIMA7667-2001.PDF +;;; Photography Electronic still picture imaging +;;; Extended sRGB color encoding e-sRGB + +(define e-sRGB-log + (lambda (sv) + (cond ((< sv -0.0031308) + (- 0.055 (* 1.055 (expt (- sv) 10/24)))) + ((<= sv 0.0031308) + (* 12.92 sv)) + (else (+ -0.055 (* 1.055 (expt sv 10/24))))))) +(define e-sRGB-exp + (lambda (x) + (cond ((< x -0.04045) + (- (expt (/ (- 0.055 x) 1.055) 2.4))) + ((<= x 0.04045) + (/ x 12.92)) + (else (expt (/ (+ 0.055 x) 1.055) 2.4))))) +;@ +(define (CIEXYZ->e-sRGB n XYZ) + (define two^n-9 (ash 1 (- n 9))) + (define offset (* 3 (ash 1 (- n 3)))) + (map (lambda (x) + (+ (inexact->exact (round (* x 255 two^n-9))) offset)) + (map e-sRGB-log + (color:linear-transform + RGB709:into-matrix + XYZ)))) +;@ +(define (e-sRGB->CIEXYZ n rgb) + (define two^n-9 (ash 1 (- n 9))) + (define offset (* 3 (ash 1 (- n 3)))) + (color:linear-transform + RGB709:from-matrix + (map e-sRGB-exp + (map (lambda (b8v) (/ (- b8v offset) 255.0 two^n-9)) + rgb)))) +;@ +(define (sRGB->e-sRGB n sRGB) + (define two^n-9 (ash 1 (- n 9))) + (define offset (* 3 (ash 1 (- n 3)))) + (map (lambda (x) (+ offset (* two^n-9 x))) sRGB)) +;@ +(define (e-sRGB->sRGB n rgb) + (define two^n-9 (ash 1 (- n 9))) + (define offset (* 3 (ash 1 (- n 3)))) + (map (lambda (x) (/ (- x offset) two^n-9)) rgb)) +;@ +(define (e-sRGB->e-sRGB n rgb m) + (define shft (- m n)) + (cond ((zero? shft) rgb) + (else (map (lambda (x) (ash x shft)) rgb)))) + +;;; From http://www.cs.rit.edu/~ncs/color/t_convert.html + +;;; CIE 1976 L*a*b* is based directly on CIE XYZ and is an attampt to +;;; linearize the perceptibility of color differences. The non-linear +;;; relations for L*, a*, and b* are intended to mimic the logarithmic +;;; response of the eye. Coloring information is referred to the color +;;; of the white point of the system, subscript n. + +;;;; L* is CIE lightness +;;; L* = 116 * (Y/Yn)^1/3 - 16 for Y/Yn > 0.008856 +;;; L* = 903.3 * Y/Yn otherwise + +(define (CIE:Y/Yn->L* Y/Yn) + (if (> Y/Yn 0.008856) + (+ -16 (* 116 (expt Y/Yn 1/3))) + (* 903.3 Y/Yn))) +(define (CIE:L*->Y/Yn L*) + (cond ((<= L* (* 903.3 0.008856)) + (/ L* 903.3)) + ((<= L* 100.) + (expt (/ (+ L* 16) 116) 3)) + (else 1))) + +;;; a* = 500 * ( f(X/Xn) - f(Y/Yn) ) +;;; b* = 200 * ( f(Y/Yn) - f(Z/Zn) ) +;;; where f(t) = t^1/3 for t > 0.008856 +;;; f(t) = 7.787 * t + 16/116 otherwise + +(define (ab-log t) + (if (> t 0.008856) + (expt t 1/3) + (+ 16/116 (* t 7.787)))) +(define (ab-exp f) + (define f3 (expt f 3)) + (if (> f3 0.008856) + f3 + (/ (- f 16/116) 7.787))) +;@ +(define (CIEXYZ->L*a*b* XYZ . white-point) + (apply (lambda (X/Xn Y/Yn Z/Zn) + (list (CIE:Y/Yn->L* Y/Yn) + (* 500 (- (ab-log X/Xn) (ab-log Y/Yn))) + (* 200 (- (ab-log Y/Yn) (ab-log Z/Zn))))) + (map / XYZ (if (null? white-point) + CIEXYZ:D65 + (car white-point))))) + +;;; Here Xn, Yn and Zn are the tristimulus values of the reference white. +;@ +(define (L*a*b*->CIEXYZ L*a*b* . white-point) + (apply (lambda (Xn Yn Zn) + (apply (lambda (L* a* b*) + (let* ((Y/Yn (CIE:L*->Y/Yn L*)) + (fY/Yn (ab-log Y/Yn))) + (list (* Xn (ab-exp (+ fY/Yn (/ a* 500)))) + (* Yn Y/Yn) + (* Zn (ab-exp (+ fY/Yn (/ b* -200))))))) + L*a*b*)) + (if (null? white-point) + CIEXYZ:D65 + (car white-point)))) + +;;; XYZ to CIELUV + +;;; CIE 1976 L*u*u* (CIELUV) is based directly on CIE XYZ and is another +;;; attampt to linearize the perceptibility of color differences. L* is +;;; CIE lightness as for L*a*b* above. The non-linear relations for u* +;;; and v* are: + +;;; u* = 13 L* ( u' - un' ) +;;; v* = 13 L* ( v' - vn' ) + +;;; The quantities un' and vn' refer to the reference white or the light +;;; source; for the 2° observer and illuminant C, un' = 0.2009, vn' = +;;; 0.4610. Equations for u' and v' are given below: + +;;; u' = 4 X / (X + 15 Y + 3 Z) +;;; v' = 9 Y / (X + 15 Y + 3 Z) + +(define (XYZ->uv XYZ) + (apply (lambda (X Y Z) + (define denom (+ X (* 15 Y) (* 3 Z))) + (if (zero? denom) + '(4. 9.) + (list (/ (* 4 X) denom) + (/ (* 9 Y) denom)))) + XYZ)) +;@ +(define (CIEXYZ->L*u*v* XYZ . white-point) + (set! white-point (if (null? white-point) + CIEXYZ:D65 + (car white-point))) + (let* ((Y/Yn (/ (cadr XYZ) (cadr white-point))) + (L* (CIE:Y/Yn->L* Y/Yn))) + (cons L* (map (lambda (q) (* 13 L* q)) + (map - (XYZ->uv XYZ) (XYZ->uv white-point)))))) + +;;; CIELUV to XYZ + +;;; The transformation from CIELUV to XYZ is performed as following: + +;;; u' = u / ( 13 L* ) + un +;;; v' = v / ( 13 L* ) + vn +;;; X = 9 Y u' / 4 v' +;;; Z = ( 12 Y - 3 Y u' - 20 Y v' ) / 4 v' +;@ +(define (L*u*v*->CIEXYZ L*u*v* . white-point) + (set! white-point (if (null? white-point) + CIEXYZ:D65 + (car white-point))) + (apply (lambda (un vn) + (apply (lambda (L* u* v*) + (if (not (positive? L*)) + '(0. 0. 0.) + (let* ((up (+ (/ u* 13 L*) un)) + (vp (+ (/ v* 13 L*) vn)) + (Y (* (CIE:L*->Y/Yn L*) (cadr white-point)))) + (list (/ (* 9 Y up) 4 vp) + Y + (/ (* Y (+ 12 (* -3 up) (* -20 vp))) 4 vp))))) + L*u*v*)) + (XYZ->uv white-point))) + +;;; http://www.inforamp.net/~poynton/PDFs/coloureq.pdf + +(define pi (* 4 (atan 1))) +(define pi/180 (/ pi 180)) +;@ +(define (L*a*b*->L*C*h lab) + (define h (/ (atan (caddr lab) (cadr lab)) pi/180)) + (list (car lab) + (sqrt (apply + (map * (cdr lab) (cdr lab)))) + (if (negative? h) (+ 360 h) h))) +;@ +(define (L*C*h->L*a*b* lch) + (apply (lambda (L* C* h) + (set! h (* h pi/180)) + (list L* + (* C* (cos h)) + (* C* (sin h)))) + lch)) +;@ +(define (L*a*b*:DE* lab1 lab2) + (sqrt (apply + (map (lambda (x) (* x x)) (map - lab1 lab2))))) + +;;; http://www.colorpro.com/info/data/cie94.html + +(define (color:process-params parametric-factors) + (define ans + (case (length parametric-factors) + ((0) #f) + ((1) (if (list? parametric-factors) + (apply color:process-params parametric-factors) + (append parametric-factors '(1 1)))) + ((2) (append parametric-factors '(1))) + ((3) parametric-factors) + (else (slib:error 'parametric-factors 'too-many parametric-factors)))) + (and ans + (for-each (lambda (obj) + (if (not (number? obj)) + (slib:error 'parametric-factors 'not 'number? obj))) + ans)) + ans) +;@ +(define (L*C*h:DE*94 lch1 lch2 . parametric-factors) + (define C* (sqrt (* (cadr lch1) (cadr lch2)))) ;Geometric mean + (sqrt (apply + (map / + (map (lambda (x) (* x x)) (map - lch1 lch2)) + (list 1 ; S_l + (+ 1 (* .045 C*)) ; S_c + (+ 1 (* .015 C*))) ; S_h + (or (color:process-params parametric-factors) + '(1 1 1)))))) + +;;; CMC-DE is designed only for small color-differences. But try to do +;;; something reasonable for large differences. Use bisector (h*) of +;;; the hue angles if separated by less than 90.o; otherwise, pick h of +;;; the color with larger C*. +;@ +(define (CMC-DE lch1 lch2 . parametric-factors) + (apply (lambda (L* C* h_) ;Geometric means + (let ((ang1 (* pi/180 (caddr lch1))) + (ang2 (* pi/180 (caddr lch2)))) + (cond ((>= 90 (abs (/ (atan (sin (- ang1 ang2)) + (cos (- ang1 ang2))) + pi/180))) + (set! h_ (/ (atan (+ (sin ang1) (sin ang2)) + (+ (cos ang1) (cos ang2))) + pi/180))) + ((>= (cadr lch1) (cadr lch2)) (caddr lch1)) + (else (caddr lch2)))) + (let* ((C*^4 (expt C* 4)) + (f (sqrt (/ C*^4 (+ C*^4 1900)))) + (T (if (and (> h_ 164) (< h_ 345)) + (+ 0.56 (abs (* 0.2 (cos (* (+ h_ 168) pi/180))))) + (+ 0.36 (abs (* 0.4 (cos (* (+ h_ 35) pi/180))))))) + (S_l (if (< L* 16) + 0.511 + (/ (* 0.040975 L*) (+ 1 (* 0.01765 L*))))) + (S_c (+ (/ (* 0.0638 C*) (+ 1 (* 0.0131 C*))) 0.638)) + (S_h (* S_c (+ (* (+ -1 T) f) 1)))) + (sqrt (apply + + (map / + (map (lambda (x) (* x x)) (map - lch1 lch2)) + (list S_l S_c S_h) + (or (color:process-params parametric-factors) + '(2 1 1))))))) + (map sqrt (map * lch1 lch2)))) +;@ +(define (XYZ:normalize-colors lst) + (define sum (apply max (map (lambda (XYZ) (apply + XYZ)) lst))) + (map (lambda (XYZ) (map (lambda (x) (/ x sum)) XYZ)) lst)) +;@ +(define (XYZ:normalize XYZ) + (car (XYZ:normalize-colors (list XYZ)))) + +;;; Chromaticity +;@ +(define (XYZ->chromaticity XYZ) + (define sum (apply + XYZ)) + (list (/ (car XYZ) sum) (/ (cadr XYZ) sum))) +;@ +(define (chromaticity->CIEXYZ x y) + (list x y (- 1 x y))) +(define (chromaticity->whitepoint x y) + (list (/ x y) 1 (/ (- 1 x y) y))) +;@ +(define (XYZ->xyY XYZ) + (define sum (apply + XYZ)) + (if (zero? sum) + '(0 0 0) + (list (/ (car XYZ) sum) (/ (cadr XYZ) sum) (cadr XYZ)))) +;@ +(define (xyY->XYZ xyY) + (define x (car xyY)) + (define y (cadr xyY)) + (if (zero? y) + '(0 0 0) + (let ((Y/y (/ (caddr xyY) y))) + (list (* Y/y x) (caddr xyY) (* Y/y (- 1 x y)))))) +;@ +(define (xyY:normalize-colors lst . n) + (define (nthcdr n lst) (if (zero? n) lst (nthcdr (+ -1 n) (cdr lst)))) + (define Ys (map caddr lst)) + (set! n (if (null? n) 1 (car n))) + (let ((max-Y (if (positive? n) + (* n (apply max Ys)) + (let () + (require 'sort) + (apply max (nthcdr (- n) (sort Ys >=))))))) + (map (lambda (xyY) + (let ((x (max 0 (car xyY))) + (y (max 0 (cadr xyY)))) + (define sum (max 1 (+ x y))) + (list (/ x sum) + (/ y sum) + (max 0 (min 1 (/ (caddr xyY) max-Y)))))) + lst))) + +;;; http://www.aim-dtp.net/aim/technology/cie_xyz/cie_xyz.htm: +;;; Illuminant D65 0.312713 0.329016 +;; (define CIEXYZ:D65 (chromaticity->whitepoint 0.312713 0.329016)) +;; (define CIEXYZ:D65 (chromaticity->whitepoint 0.3127 0.3290)) +;@ +(define CIEXYZ:D50 (chromaticity->whitepoint 0.3457 0.3585)) + +;;; With its 16-bit resolution, e-sRGB-16 is extremely sensitive to +;;; whitepoint. Even the 6 digits of precision specified above is +;;; insufficient to make (color->e-srgb 16 d65) ==> (57216 57216 57216) +;@ +(define CIEXYZ:D65 (e-sRGB->CIEXYZ 16 '(57216 57216 57216))) + +;;; http://www.efg2.com/Lab/Graphics/Colors/Chromaticity.htm CIE 1931: +;@ +(define CIEXYZ:A (chromaticity->whitepoint 0.44757 0.40745)) ; 2856.K +(define CIEXYZ:B (chromaticity->whitepoint 0.34842 0.35161)) ; 4874.K +(define CIEXYZ:C (chromaticity->whitepoint 0.31006 0.31616)) ; 6774.K +(define CIEXYZ:E (chromaticity->whitepoint 1/3 1/3)) ; 5400.K + +;;; Converting spectra +(define cie:x-bar #f) +(define cie:y-bar #f) +(define cie:z-bar #f) +;@ +(define (load-ciexyz . path) + (let ((path (if (null? path) + (in-vicinity (library-vicinity) "cie1931.xyz") + (car path)))) + (set! cie:x-bar (make-vector 80)) + (set! cie:y-bar (make-vector 80)) + (set! cie:z-bar (make-vector 80)) + (call-with-input-file path + (lambda (iprt) + (do ((wlen 380 (+ 5 wlen)) + (idx 0 (+ 1 idx))) + ((>= wlen 780)) + (let ((rlen (read iprt))) + (if (not (eqv? wlen rlen)) + (slib:error path 'expected wlen 'not rlen)) + (vector-set! cie:x-bar idx (read iprt)) + (vector-set! cie:y-bar idx (read iprt)) + (vector-set! cie:z-bar idx (read iprt)))))))) +;@ +(define (wavelength->XYZ wl) + (if (not cie:y-bar) (require 'ciexyz)) + (set! wl (- (/ wl 5.e-9) 380/5)) + (if (<= 0 wl (+ -1 400/5)) + (let* ((wlf (inexact->exact (floor wl))) + (res (- wl wlf))) + (define (interpolate vect idx res) + (+ (* res (vector-ref vect idx)) + (* (- 1 res) (vector-ref vect (+ 1 idx))))) + (list (interpolate cie:x-bar wlf res) + (interpolate cie:y-bar wlf res) + (interpolate cie:z-bar wlf res))) + (slib:error 'wavelength->XYZ 'out-of-range wl))) +(define (wavelength->CIEXYZ wl) + (XYZ:normalize (wavelength->XYZ wl))) +(define (wavelength->chromaticity wl) + (XYZ->chromaticity (wavelength->XYZ wl))) +;@ +(define (spectrum->XYZ . args) + (define x 0) + (define y 0) + (define z 0) + (if (not cie:y-bar) (require 'ciexyz)) + (case (length args) + ((1) + (set! args (car args)) + (do ((wvln 380.e-9 (+ 5.e-9 wvln)) + (idx 0 (+ 1 idx))) + ((>= idx 80) (map (lambda (x) (/ x 80)) (list x y z))) + (let ((inten (args wvln))) + (set! x (+ x (* (vector-ref cie:x-bar idx) inten))) + (set! y (+ y (* (vector-ref cie:y-bar idx) inten))) + (set! z (+ z (* (vector-ref cie:z-bar idx) inten)))))) + ((3) + (let* ((vect (if (list? (car args)) (list->vector (car args)) (car args))) + (vlen (vector-length vect)) + (x1 (cadr args)) + (x2 (caddr args)) + (xinc (/ (- x2 x1) (+ -1 vlen))) + (x->j (lambda (x) (inexact->exact (round (/ (- x x1) xinc))))) + (x->k (lambda (x) (inexact->exact (round (/ (- x 380.e-9) 5.e-9))))) + (j->x (lambda (j) (+ x1 (* j xinc)))) + (k->x (lambda (k) (+ 380.e-9 (* k 5.e-9)))) + (xlo (max (min x1 x2) 380.e-9)) + (xhi (min (max x1 x2) 780.e-9)) + (jhi (x->j xhi)) + (khi (x->k xhi)) + (jinc (if (negative? xinc) -1 1))) + (if (<= (abs xinc) 5.e-9) + (do ((wvln (j->x (x->j xlo)) (+ wvln (abs xinc))) + (jdx (x->j xlo) (+ jdx jinc))) + ((>= jdx jhi) + (let ((nsmps (abs (- jhi (x->j xlo))))) + (map (lambda (x) (/ x nsmps)) (list x y z)))) + (let ((ciedex (min 79 (x->k wvln))) + (inten (vector-ref vect jdx))) + (set! x (+ x (* (vector-ref cie:x-bar ciedex) inten))) + (set! y (+ y (* (vector-ref cie:y-bar ciedex) inten))) + (set! z (+ z (* (vector-ref cie:z-bar ciedex) inten))))) + (do ((wvln (k->x (x->k xlo)) (+ wvln 5.e-9)) + (kdx (x->k xlo) (+ kdx 1))) + ((>= kdx khi) + (let ((nsmps (abs (- khi (x->k xlo))))) + (map (lambda (x) (/ x nsmps)) (list x y z)))) + (let ((inten (vector-ref vect (x->j wvln)))) + (set! x (+ x (* (vector-ref cie:x-bar kdx) inten))) + (set! y (+ y (* (vector-ref cie:y-bar kdx) inten))) + (set! z (+ z (* (vector-ref cie:z-bar kdx) inten)))))))) + (else (slib:error 'spectrum->XYZ 'wna args)))) +(define (spectrum->CIEXYZ . args) + (XYZ:normalize (apply spectrum->XYZ args))) +(define (spectrum->chromaticity . args) + (XYZ->chromaticity (apply spectrum->XYZ args))) +;@ +(define blackbody-spectrum + (let* ((c 2.998e8) + (h 6.626e-34) + (h*c (* h c)) + (k 1.381e-23) + (pi*2*h*c*c (* 2 pi h*c c))) + (lambda (temp . span) + (define h*c/kT (/ h*c k temp)) + (define pi*2*h*c*c*span (* pi*2*h*c*c (if (null? span) 1.e-9 (car span)))) + (lambda (x) + (/ pi*2*h*c*c*span + (expt x 5) + (- (exp (/ h*c/kT x)) 1)))))) +;@ +(define (temperature->XYZ temp) + (spectrum->XYZ (blackbody-spectrum temp 5.e-9))) +(define (temperature->CIEXYZ temp) + (XYZ:normalize (temperature->XYZ temp))) +(define (temperature->chromaticity temp) + (XYZ->chromaticity (temperature->XYZ temp))) diff --git a/comlist.scm b/comlist.scm index 008a2b0..2e3a6ef 100644 --- a/comlist.scm +++ b/comlist.scm @@ -1,5 +1,5 @@ ;;"comlist.scm" Implementation of COMMON LISP list functions for Scheme -; Copyright (C) 1991, 1993, 1995, 2001 Aubrey Jaffer. +; Copyright (C) 1991, 1993, 1995, 2001, 2003 Aubrey Jaffer. ; Copyright (C) 2000 Colin Walters ; ;Permission to copy this software, to modify it, to redistribute it, @@ -9,7 +9,7 @@ ;1. Any copy made of this software must include this copyright notice ;in full. ; -;2. I have made no warrantee or representation that the operation of +;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; @@ -27,25 +27,32 @@ ;;; Colin Walters <walters@cis.ohio-state.edu> ;;; AGJ restored order July 2001. -;;;From: hugh@ear.mit.edu (Hugh Secker-Walker) -(define (comlist:make-list k . init) +;;;@ From: hugh@ear.mit.edu (Hugh Secker-Walker) +(define (make-list k . init) (set! init (if (pair? init) (car init))) (do ((k k (+ -1 k)) (result '() (cons init result))) ((<= k 0) result))) - -(define (comlist:copy-list lst) (append lst '())) - -(define (comlist:adjoin obj lst) (if (memv obj lst) lst (cons obj lst))) - -(define (comlist:union lst1 lst2) - (define ans (if (null? lst1) lst2 lst1)) - (cond ((null? lst2) lst1) - (else (for-each (lambda (elt) (set! ans (comlist:adjoin elt ans))) - lst2) - ans))) - -(define (comlist:intersection lst1 lst2) +;@ +(define (copy-list lst) (append lst '())) +;@ +(define (adjoin obj lst) (if (memv obj lst) lst (cons obj lst))) +;@ +(define union + (letrec ((onion + (lambda (lst1 lst2) + (if (null? lst1) + lst2 + (onion (cdr lst1) (comlist:adjoin (car lst1) lst2)))))) + (lambda (lst1 lst2) + (cond ((null? lst1) lst2) + ((null? lst2) lst1) + ((null? (cdr lst1)) (comlist:adjoin (car lst1) lst2)) + ((null? (cdr lst2)) (comlist:adjoin (car lst2) lst1)) + ((< (length lst2) (length lst1)) (onion (reverse lst2) lst1)) + (else (onion (reverse lst1) lst2)))))) +;@ +(define (intersection lst1 lst2) (if (null? lst2) lst2 (let build-intersection ((lst1 lst1) @@ -55,8 +62,8 @@ (build-intersection (cdr lst1) (cons (car lst1) result))) (else (build-intersection (cdr lst1) result)))))) - -(define (comlist:set-difference lst1 lst2) +;@ +(define (set-difference lst1 lst2) (if (null? lst2) lst1 (let build-difference ((lst1 lst1) @@ -64,25 +71,32 @@ (cond ((null? lst1) (reverse result)) ((memv (car lst1) lst2) (build-difference (cdr lst1) result)) (else (build-difference (cdr lst1) (cons (car lst1) result))))))) - -(define (comlist:position obj lst) - (letrec ((pos (lambda (n lst) - (cond ((null? lst) #f) - ((eqv? obj (car lst)) n) - (else (pos (+ 1 n) (cdr lst))))))) - (pos 0 lst))) - -(define (comlist:reduce-init pred? init lst) +;@ +(define (subset? lst1 lst2) + (or (eq? lst1 lst2) + (let loop ((lst1 lst1)) + (or (null? lst1) + (and (memv (car lst1) lst2) + (loop (cdr lst1))))))) +;@ +(define (position obj lst) + (define pos (lambda (n lst) + (cond ((null? lst) #f) + ((eqv? obj (car lst)) n) + (else (pos (+ 1 n) (cdr lst)))))) + (pos 0 lst)) +;@ +(define (reduce-init pred? init lst) (if (null? lst) init (comlist:reduce-init pred? (pred? init (car lst)) (cdr lst)))) - -(define (comlist:reduce pred? lst) +;@ +(define (reduce pred? lst) (cond ((null? lst) lst) ((null? (cdr lst)) (car lst)) (else (comlist:reduce-init pred? (car lst) (cdr lst))))) - -(define (comlist:some pred lst . rest) +;@ +(define (some pred lst . rest) (cond ((null? rest) (let mapf ((lst lst)) (and (not (null? lst)) @@ -91,8 +105,8 @@ (and (not (null? lst)) (or (apply pred (car lst) (map car rest)) (mapf (cdr lst) (map cdr rest)))))))) - -(define (comlist:every pred lst . rest) +;@ +(define (every pred lst . rest) (cond ((null? rest) (let mapf ((lst lst)) (or (null? lst) @@ -101,18 +115,18 @@ (or (null? lst) (and (apply pred (car lst) (map car rest)) (mapf (cdr lst) (map cdr rest)))))))) - -(define (comlist:notany pred . ls) (not (apply comlist:some pred ls))) - -(define (comlist:notevery pred . ls) (not (apply comlist:every pred ls))) - -(define (comlist:list-of?? predicate . bound) +;@ +(define (notany pred . ls) (not (apply comlist:some pred ls))) +;@ +(define (notevery pred . ls) (not (apply comlist:every pred ls))) +;@ +(define (list-of?? predicate . bound) (define (errout) (apply slib:error 'list-of?? predicate bound)) (case (length bound) ((0) (lambda (obj) (and (list? obj) - (every predicate obj)))) + (comlist:every predicate obj)))) ((1) (set! bound (car bound)) (cond ((negative? bound) @@ -120,12 +134,12 @@ (lambda (obj) (and (list? obj) (<= bound (length obj)) - (every predicate obj)))) + (comlist:every predicate obj)))) (else (lambda (obj) (and (list? obj) (<= (length obj) bound) - (every predicate obj)))))) + (comlist:every predicate obj)))))) ((2) (let ((low (car bound)) (high (cadr bound))) @@ -136,45 +150,45 @@ (lambda (obj) (and (list? obj) (<= low (length obj) high) - (every predicate obj))))) + (comlist:every predicate obj))))) (else (errout)))) - -(define (comlist:find-if pred? lst) +;@ +(define (find-if pred? lst) (cond ((null? lst) #f) ((pred? (car lst)) (car lst)) (else (comlist:find-if pred? (cdr lst))))) - -(define (comlist:member-if pred? lst) +;@ +(define (member-if pred? lst) (cond ((null? lst) #f) ((pred? (car lst)) lst) (else (comlist:member-if pred? (cdr lst))))) - -(define (comlist:remove pred? lst) +;@ +(define (remove obj lst) (define head (list '*head*)) (let remove ((lst lst) (tail head)) (cond ((null? lst)) - ((eqv? pred? (car lst)) (remove (cdr lst) tail)) + ((eqv? obj (car lst)) (remove (cdr lst) tail)) (else (set-cdr! tail (list (car lst))) (remove (cdr lst) (cdr tail))))) (cdr head)) - -(define (comlist:remove-if pred? lst) +;@ +(define (remove-if pred? lst) (let remove-if ((lst lst) (result '())) (cond ((null? lst) (reverse result)) ((pred? (car lst)) (remove-if (cdr lst) result)) (else (remove-if (cdr lst) (cons (car lst) result)))))) - -(define (comlist:remove-if-not pred? lst) +;@ +(define (remove-if-not pred? lst) (let remove-if-not ((lst lst) (result '())) (cond ((null? lst) (reverse result)) ((pred? (car lst)) (remove-if-not (cdr lst) (cons (car lst) result))) (else (remove-if-not (cdr lst) result))))) - -(define comlist:nconc +;@ +(define nconc (if (provided? 'rev2-procedures) append! (lambda args (cond ((null? args) '()) @@ -185,8 +199,8 @@ (apply comlist:nconc (cdr args))) (car args)))))) -;;;From: hugh@ear.mit.edu (Hugh Secker-Walker) -(define (comlist:nreverse rev-it) +;;;@ From: hugh@ear.mit.edu (Hugh Secker-Walker) +(define (nreverse rev-it) ;;; Reverse order of elements of LIST by mutating cdrs. (cond ((null? rev-it) rev-it) ((not (list? rev-it)) @@ -195,100 +209,85 @@ (rev-cdr (cdr rev-it) (cdr rev-cdr)) (rev-it rev-it rev-cdr)) ((begin (set-cdr! rev-it reved) (null? rev-cdr)) rev-it))))) - -(define (comlist:last lst n) +;@ +(define (last lst n) (comlist:nthcdr (- (length lst) n) lst)) - -(define (comlist:butlast lst n) - (letrec - ((len (- (length lst) n)) - (bl (lambda (lst n) - (let build-until-zero ((lst lst) - (n n) - (result '())) - (cond ((null? lst) (reverse result)) - ((positive? n) - (build-until-zero - (cdr lst) (- n 1) (cons (car lst) result))) - (else (reverse result))))))) - (bl lst (if (negative? n) - (slib:error "negative argument to butlast" n) - len)))) - -(define (comlist:nthcdr n lst) +;@ +(define (butlast lst n) + (comlist:butnthcdr (- (length lst) n) lst)) +;@ +(define (nthcdr n lst) (if (zero? n) lst (comlist:nthcdr (+ -1 n) (cdr lst)))) - -(define (comlist:butnthcdr n lst) - (letrec - ((bl (lambda (lst n) - (let build-until-zero ((lst lst) - (n n) - (result '())) - (cond ((null? lst) (reverse result)) - ((positive? n) - (build-until-zero - (cdr lst) (- n 1) (cons (car lst) result))) - (else (reverse result))))))) - (bl lst (if (negative? n) - (slib:error "negative argument to butnthcdr" n) - n)))) +;@ +(define (butnthcdr k lst) + (cond ((negative? k) lst) ;(slib:error "negative argument to butnthcdr" k) + ; SIMSYNCH FIFO8 uses negative k. + ((or (zero? k) (null? lst)) '()) + (else (let ((ans (list (car lst)))) + (do ((lst (cdr lst) (cdr lst)) + (tail ans (cdr tail)) + (k (+ -2 k) (+ -1 k))) + ((or (negative? k) (null? lst)) ans) + (set-cdr! tail (list (car lst)))))))) ;;;; CONDITIONALS - -(define (comlist:and? . args) +;@ +(define (and? . args) (cond ((null? args) #t) ((car args) (apply comlist:and? (cdr args))) (else #f))) - -(define (comlist:or? . args) +;@ +(define (or? . args) (cond ((null? args) #f) ((car args) #t) (else (apply comlist:or? (cdr args))))) -;;; Checks to see if a list has any duplicate MEMBERs. -(define (comlist:has-duplicates? lst) +;;;@ Checks to see if a list has any duplicate MEMBERs. +(define (has-duplicates? lst) (cond ((null? lst) #f) ((member (car lst) (cdr lst)) #t) (else (comlist:has-duplicates? (cdr lst))))) -;;; remove duplicates of MEMBERs of a list -(define (comlist:remove-duplicates lst) +;;;@ remove duplicates of MEMBERs of a list +(define remove-duplicates (letrec ((rem-dup (lambda (lst nlst) (cond ((null? lst) (reverse nlst)) ((member (car lst) nlst) (rem-dup (cdr lst) nlst)) (else (rem-dup (cdr lst) (cons (car lst) nlst))))))) - (rem-dup lst '()))) - -(define (comlist:list* obj1 . obj2) - (define (list*1 obj) - (if (null? (cdr obj)) - (car obj) - (cons (car obj) (list*1 (cdr obj))))) - (if (null? obj2) - obj1 - (cons obj1 (list*1 obj2)))) - -(define (comlist:atom? obj) + (lambda (lst) + (rem-dup lst '())))) +;@ +(define list* + (letrec ((list*1 (lambda (obj) + (if (null? (cdr obj)) + (car obj) + (cons (car obj) (list*1 (cdr obj))))))) + (lambda (obj1 . obj2) + (if (null? obj2) + obj1 + (cons obj1 (list*1 obj2)))))) +;@ +(define (atom? obj) (not (pair? obj))) - -(define (comlist:delete obj lst) +;@ +(define (delete obj lst) (let delete ((lst lst)) (cond ((null? lst) '()) ((equal? obj (car lst)) (delete (cdr lst))) (else (set-cdr! lst (delete (cdr lst))) lst)))) - -(define (comlist:delete-if pred lst) +;@ +(define (delete-if pred lst) (let delete-if ((lst lst)) (cond ((null? lst) '()) ((pred (car lst)) (delete-if (cdr lst))) (else (set-cdr! lst (delete-if (cdr lst))) lst)))) - -(define (comlist:delete-if-not pred lst) +;@ +(define (delete-if-not pred lst) (let delete-if ((lst lst)) (cond ((null? lst) '()) ((not (pred (car lst))) (delete-if (cdr lst))) @@ -296,42 +295,42 @@ (set-cdr! lst (delete-if (cdr lst))) lst)))) -;;; exports - -(define make-list comlist:make-list) -(define copy-list comlist:copy-list) -(define adjoin comlist:adjoin) -(define union comlist:union) -(define intersection comlist:intersection) -(define set-difference comlist:set-difference) -(define position comlist:position) -(define reduce-init comlist:reduce-init) -(define reduce comlist:reduce) ; reduce is also in collect.scm -(define some comlist:some) -(define every comlist:every) -(define notevery comlist:notevery) -(define notany comlist:notany) -(define find-if comlist:find-if) -(define member-if comlist:member-if) -(define remove comlist:remove) -(define remove-if comlist:remove-if) -(define remove-if-not comlist:remove-if-not) -(define nconc comlist:nconc) -(define nreverse comlist:nreverse) -(define last comlist:last) -(define butlast comlist:butlast) -(define nthcdr comlist:nthcdr) -(define butnthcdr comlist:butnthcdr) -(define and? comlist:and?) -(define or? comlist:or?) -(define has-duplicates? comlist:has-duplicates?) -(define remove-duplicates comlist:remove-duplicates) - -(define delete-if-not comlist:delete-if-not) -(define delete-if comlist:delete-if) -(define delete comlist:delete) -(define comlist:atom comlist:atom?) -(define atom comlist:atom?) -(define atom? comlist:atom?) -(define list* comlist:list*) -(define list-of?? comlist:list-of??) +;;; internal versions safe from name collisions. + +;;(define comlist:make-list make-list) +;;(define comlist:copy-list copy-list) +(define comlist:adjoin adjoin) +;;(define comlist:union union) +;;(define comlist:intersection intersection) +;;(define comlist:set-difference set-difference) +;;(define comlist:subset? subset?) +;;(define comlist:position position) +(define comlist:reduce-init reduce-init) +;;(define comlist:reduce reduce) ; reduce is also in collect.scm +(define comlist:some some) +(define comlist:every every) +;;(define comlist:notevery notevery) +;;(define comlist:notany notany) +(define comlist:find-if find-if) +(define comlist:member-if member-if) +;;(define comlist:remove remove) +;;(define comlist:remove-if remove-if) +;;(define comlist:remove-if-not remove-if-not) +(define comlist:nconc nconc) +;;(define comlist:nreverse nreverse) +;;(define comlist:last last) +;;(define comlist:butlast butlast) +(define comlist:nthcdr nthcdr) +(define comlist:butnthcdr butnthcdr) +(define comlist:and? and?) +(define comlist:or? or?) +(define comlist:has-duplicates? has-duplicates?) +;;(define comlist:remove-duplicates remove-duplicates) +;;(define comlist:delete-if-not delete-if-not) +;;(define comlist:delete-if delete-if) +;;(define comlist:delete delete) +;;(define comlist:atom? atom?) +;;(define atom atom?) +;;(define comlist:atom atom?) +;;(define comlist:list* list*) +;;(define comlist:list-of?? list-of??) diff --git a/comparse.scm b/comparse.scm index 5a007b6..5dc1a50 100644 --- a/comparse.scm +++ b/comparse.scm @@ -1,5 +1,5 @@ ;;; "comparse.scm" Break command line into arguments. -;Copyright (C) 1995, 1997 Aubrey Jaffer +;Copyright (C) 1995, 1997, 2003 Aubrey Jaffer ; ;Permission to copy this software, to modify it, to redistribute it, ;to distribute modified versions, and to use it for any purpose is @@ -8,7 +8,7 @@ ;1. Any copy made of this software must include this copyright notice ;in full. ; -;2. I have made no warrantee or representation that the operation of +;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; @@ -24,6 +24,10 @@ ;;; reading files of options -- therefore READ-OPTIONS-FILE. (require 'string-port) + +;;@code{(require 'read-command)} +;;@ftindex read-command + (define (read-command-from-port port nl-term?) (define argv '()) (define obj "") @@ -86,6 +90,64 @@ (cond ((and (null? argv) (eof-object? c)) c) (else (reverse argv))))) +;;@args port +;;@args +;;@code{read-command} converts a @dfn{command line} into a list of strings +;;@cindex command line +;;suitable for parsing by @code{getopt}. The syntax of command lines +;;supported resembles that of popular @dfn{shell}s. @code{read-command} +;;updates @var{port} to point to the first character past the command +;;delimiter. +;; +;;If an end of file is encountered in the input before any characters are +;;found that can begin an object or comment, then an end of file object is +;;returned. +;; +;;The @var{port} argument may be omitted, in which case it defaults to the +;;value returned by @code{current-input-port}. +;; +;;The fields into which the command line is split are delimited by +;;whitespace as defined by @code{char-whitespace?}. The end of a command +;;is delimited by end-of-file or unescaped semicolon (@key{;}) or +;;@key{newline}. Any character can be literally included in a field by +;;escaping it with a backslach (@key{\}). +;; +;;The initial character and types of fields recognized are: +;;@table @asis +;;@item @samp{\} +;;The next character has is taken literally and not interpreted as a field +;;delimiter. If @key{\} is the last character before a @key{newline}, +;;that @key{newline} is just ignored. Processing continues from the +;;characters after the @key{newline} as though the backslash and +;;@key{newline} were not there. +;;@item @samp{"} +;;The characters up to the next unescaped @key{"} are taken literally, +;;according to [R4RS] rules for literal strings (@pxref{Strings, , ,r4rs, +;;Revised(4) Scheme}). +;;@item @samp{(}, @samp{%'} +;;One scheme expression is @code{read} starting with this character. The +;;@code{read} expression is evaluated, converted to a string +;;(using @code{display}), and replaces the expression in the returned +;;field. +;;@item @samp{;} +;;Semicolon delimits a command. Using semicolons more than one command +;;can appear on a line. Escaped semicolons and semicolons inside strings +;;do not delimit commands. +;;@end table +;; +;;@noindent +;;The comment field differs from the previous fields in that it must be +;;the first character of a command or appear after whitespace in order to +;;be recognized. @key{#} can be part of fields if these conditions are +;;not met. For instance, @code{ab#c} is just the field ab#c. +;; +;;@table @samp +;;@item # +;;Introduces a comment. The comment continues to the end of the line on +;;which the semicolon appears. Comments are treated as whitespace by +;;@code{read-dommand-line} and backslashes before @key{newline}s in +;;comments are also ignored. +;;@end table (define (read-command . port) (read-command-from-port (cond ((null? port) (current-input-port)) ((= 1 (length port)) (car port)) @@ -94,6 +156,16 @@ "Wrong Number of ARGs:" port))) #t)) +;;@body +;;@code{read-options-file} converts an @dfn{options file} into a list of +;;@cindex options file +;;strings suitable for parsing by @code{getopt}. The syntax of options +;;files is the same as the syntax for command +;;lines, except that @key{newline}s do not terminate reading (only @key{;} +;;or end of file). +;; +;;If an end of file is encountered before any characters are found that +;;can begin an object or comment, then an end of file object is returned. (define (read-options-file filename) (call-with-input-file filename (lambda (port) (read-command-from-port port #f)))) diff --git a/comparse.txi b/comparse.txi new file mode 100644 index 0000000..3ebe785 --- /dev/null +++ b/comparse.txi @@ -0,0 +1,81 @@ +@code{(require 'read-command)} +@ftindex read-command + + +@defun read-command port + + +@defunx read-command +@code{read-command} converts a @dfn{command line} into a list of strings +@cindex command line +@cindex command line +suitable for parsing by @code{getopt}. The syntax of command lines +supported resembles that of popular @dfn{shell}s. @code{read-command} +@cindex shell +updates @var{port} to point to the first character past the command +delimiter. + +If an end of file is encountered in the input before any characters are +found that can begin an object or comment, then an end of file object is +returned. + +The @var{port} argument may be omitted, in which case it defaults to the +value returned by @code{current-input-port}. + +The fields into which the command line is split are delimited by +whitespace as defined by @code{char-whitespace?}. The end of a command +is delimited by end-of-file or unescaped semicolon (@key{;}) or +@key{newline}. Any character can be literally included in a field by +escaping it with a backslach (@key{\}). + +The initial character and types of fields recognized are: +@table @asis +@item @samp{\} +The next character has is taken literally and not interpreted as a field +delimiter. If @key{\} is the last character before a @key{newline}, +that @key{newline} is just ignored. Processing continues from the +characters after the @key{newline} as though the backslash and +@key{newline} were not there. +@item @samp{"} +The characters up to the next unescaped @key{"} are taken literally, +according to [R4RS] rules for literal strings (@pxref{Strings, , ,r4rs, +Revised(4) Scheme}). +@item @samp{(}, @samp{%'} +One scheme expression is @code{read} starting with this character. The +@code{read} expression is evaluated, converted to a string +(using @code{display}), and replaces the expression in the returned +field. +@item @samp{;} +Semicolon delimits a command. Using semicolons more than one command +can appear on a line. Escaped semicolons and semicolons inside strings +do not delimit commands. +@end table + +@noindent +The comment field differs from the previous fields in that it must be +the first character of a command or appear after whitespace in order to +be recognized. @key{#} can be part of fields if these conditions are +not met. For instance, @code{ab#c} is just the field ab#c. + +@table @samp +@item # +Introduces a comment. The comment continues to the end of the line on +which the semicolon appears. Comments are treated as whitespace by +@code{read-dommand-line} and backslashes before @key{newline}s in +comments are also ignored. +@end table +@end defun + +@defun read-options-file filename + +@code{read-options-file} converts an @dfn{options file} into a list of +@cindex options file +@cindex options file +strings suitable for parsing by @code{getopt}. The syntax of options +files is the same as the syntax for command +lines, except that @key{newline}s do not terminate reading (only @key{;} +or end of file). + +If an end of file is encountered before any characters are found that +can begin an object or comment, then an end of file object is returned. +@end defun @@ -0,0 +1,137 @@ +;;;; "crc.scm" Compute Cyclic Checksums +;;; Copyright (C) 1995, 1996, 1997, 2001, 2002 Aubrey Jaffer +; +;Permission to copy this software, to modify it, to redistribute it, +;to distribute modified versions, and to use it for any purpose is +;granted, subject to the following restrictions and understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warranty or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +(require 'byte) +(require 'logical) + +;;@ (define CRC-32-polynomial "100000100100000010001110110110111") ; IEEE-802, FDDI +(define CRC-32-polynomial "100000100110000010001110110110111") ; IEEE-802, AAL5 +;@ +(define CRC-CCITT-polynomial "10001000000100001") ; X25 +;@ +(define CRC-16-polynomial "11000000000000101") ; IBM Bisync, HDLC, SDLC, USB-Data + +;;@ (define CRC-12-polynomial "1100000001101") +(define CRC-12-polynomial "1100000001111") + +;;@ (define CRC-10-polynomial "11000110001") +(define CRC-10-polynomial "11000110011") +;@ +(define CRC-08-polynomial "100000111") +;@ +(define ATM-HEC-polynomial "100000111") +;@ +(define DOWCRC-polynomial "100110001") +;@ +(define USB-Token-polynomial "100101") + +;;This procedure is careful not to use more than DEG bits in +;;computing (- (expt 2 DEG) 1). It returns #f if the integer would +;;be larger than the implementation supports. +(define (crc:make-mask deg) + (string->number (make-string deg #\1) 2)) +;@ +(define (crc:make-table str) + (define deg (+ -1 (string-length str))) + (define generator (string->number (substring str 1 (string-length str)) 2)) + (define crctab (make-vector 256)) + (if (not (eqv? #\1 (string-ref str 0))) + (slib:error 'crc:make-table 'first-digit-of-polynomial-must-be-1 str)) + (if (< deg 8) + (slib:error 'crc:make-table 'degree-must-be>7 deg str)) + (and + generator + (do ((i 0 (+ 1 i)) + (deg-1-mask (crc:make-mask (+ -1 deg))) + (gen generator + (if (logbit? (+ -1 deg) gen) + (logxor (ash (logand deg-1-mask gen) 1) generator) + (ash (logand deg-1-mask gen) 1))) + (gens '() (cons gen gens))) + ((>= i 8) (set! gens (reverse gens)) + (do ((crc 0 0) + (m 0 (+ 1 m))) + ((> m 255) crctab) + (for-each (lambda (gen i) + (set! crc (if (logbit? i m) (logxor crc gen) crc))) + gens '(0 1 2 3 4 5 6 7)) + (vector-set! crctab m crc)))))) + +(define crc-32-table (crc:make-table CRC-32-polynomial)) + +;;@ Computes the P1003.2/D11.2 (POSIX.2) 32-bit checksum. +(define (cksum file) + (cond ((not crc-32-table) #f) + ((input-port? file) (cksum-port file)) + (else (call-with-input-file file cksum-port)))) + +(define cksum-port + (let ((mask-24 (crc:make-mask 24)) + (mask-32 (crc:make-mask 32))) + (lambda (port) + (define crc 0) + (define (accumulate-crc byt) + (set! crc + (logxor (ash (logand mask-24 crc) 8) + (vector-ref crc-32-table (logxor (ash crc -24) byt))))) + (do ((byt (read-byte port) (read-byte port)) + (byte-count 0 (+ 1 byte-count))) + ((eof-object? byt) + (do ((byte-count byte-count (ash byte-count -8))) + ((zero? byte-count) (logxor mask-32 crc)) + (accumulate-crc (logand #xff byte-count)))) + (accumulate-crc byt))))) +;@ +(define (crc16 file) + (cond ((not crc-16-table) #f) + ((input-port? file) (crc16-port file)) + (else (call-with-input-file file crc16-port)))) + +(define crc-16-table (crc:make-table CRC-16-polynomial)) + +(define crc16-port + (let ((mask-8 (crc:make-mask 8)) + (mask-16 (crc:make-mask 16))) + (lambda (port) + (define crc mask-16) + (define (accumulate-crc byt) + (set! crc + (logxor (ash (logand mask-8 crc) 8) + (vector-ref crc-16-table (logxor (ash crc -8) byt))))) + (do ((byt (read-byte port) (read-byte port))) + ((eof-object? byt) (logxor mask-16 crc)) + (accumulate-crc byt))))) +;@ +(define (crc5 file) + (cond ((input-port? file) (crc5-port file)) + (else (call-with-input-file file crc5-port)))) + +(define (crc5-port port) + (define generator #b00101) + (define crc #b11111) + (do ((byt (read-byte port) (read-byte port))) + ((eof-object? byt) (logxor #b11111 crc)) + (do ((data byt (ash data 1)) + (len (+ -1 8) (+ -1 len))) + ((negative? len)) + (set! crc + (logand #b11111 + (if (eqv? (logbit? 7 data) (logbit? 4 crc)) + (ash crc 1) + (logxor (ash crc 1) generator))))))) @@ -1,5 +1,5 @@ ;;;"cring.scm" Extend Scheme numerics to any commutative ring. -;Copyright (C) 1997, 1998 Aubrey Jaffer +;Copyright (C) 1997, 1998, 2001 Aubrey Jaffer ; ;Permission to copy this software, to modify it, to redistribute it, ;to distribute modified versions, and to use it for any purpose is @@ -8,7 +8,7 @@ ;1. Any copy made of this software must include this copyright notice ;in full. ; -;2. I have made no warrantee or representation that the operation of +;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; @@ -19,10 +19,21 @@ (require 'common-list-functions) (require 'relational-database) -(require 'database-utilities) +(require 'databases) (require 'sort) +(require-if '(not inexact) 'logical) ;for integer-expt +(define number^ (if (provided? 'inexact) expt integer-expt)) + +(define number* *) +(define number+ +) +(define number- -) +(define number/ /) +(define number0? zero?) +(define (zero? x) (and (number? x) (number0? x))) +;;(define (sign x) (if (positive? x) 1 (if (negative? x) -1 0))) (define cring:db (create-database #f 'alist-table)) +;@ (define (make-ruleset . rules) (define name #f) (cond ((and (not (null? rules)) (symbol? (car rules))) @@ -41,12 +52,13 @@ (list (table 'get 'reduction) (table 'row:update) table)))) +;@ (define *ruleset* (make-ruleset 'default)) (define (cring:define-rule . args) (if *ruleset* ((cadr *ruleset*) args) (slib:warn "No ruleset in *ruleset*"))) - +;@ (define (combined-rulesets . rulesets) (define name #f) (cond ((symbol? (car rulesets)) @@ -59,6 +71,7 @@ rulesets)))) ;;; Distribute * over + (and -) +;@ (define distribute* (make-ruleset 'distribute* @@ -72,6 +85,7 @@ (apply - (map (lambda (trm) (* trm exp2)) (cdr exp1))))))) ;;; Distribute / over + (and -) +;@ (define distribute/ (make-ruleset 'distribute/ @@ -103,15 +117,7 @@ (else (expression-< (cdr x) (cdr y))))) (define (expression-sort seq) (sort! seq expression-<)) -(define number* *) -(define number+ +) -(define number- -) -(define number/ /) -(define number^ integer-expt) (define is-term-op? (lambda (term op) (and (pair? term) (eq? op (car term))))) -;;(define (sign x) (if (positive? x) 1 (if (negative? x) -1 0))) -(define number0? zero?) -(define (zero? x) (and (number? x) (number0? x))) ;; To convert to CR internal form, NUMBER-op all the `numbers' in the ;; argument list and remove them from the argument list. Collect the @@ -0,0 +1,140 @@ +;;;;"cvs.scm" enumerate files under CVS control. +;;; Copyright 2002 Aubrey Jaffer +; +;Permission to copy this software, to modify it, to redistribute it, +;to distribute modified versions, and to use it for any purpose is +;granted, subject to the following restrictions and understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warranty or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +(require 'scanf) +(require 'line-i/o) +(require 'string-search) + +;;@body Returns a list of the local pathnames (with prefix @1) of all +;;CVS controlled files in @1 and in @1's subdirectories. +(define (cvs-files directory/) + (cvs:entries directory/ #t)) + +;;@body Returns a list of all of @1 and all @1's CVS controlled +;;subdirectories. +(define (cvs-directories directory/) + (and (file-exists? (in-vicinity directory/ "CVS/Entries")) + (cons directory/ (cvs:entries directory/ #f)))) + +(define (cvs:entries directory do-files?) + (define files '()) + (define cvse (in-vicinity directory "CVS/Entries")) + (define cvsel (in-vicinity directory "CVS/Entries.Log")) + (set! directory (substring directory + (if (eqv? 0 (substring? "./" directory)) 2 0) + (string-length directory))) + (if (file-exists? cvse) + (call-with-input-file cvse + (lambda (port) + (do ((line (read-line port) (read-line port))) + ((eof-object? line)) + (let ((fname #f)) + (cond ((eqv? 1 (sscanf line "/%[^/]" fname)) + (and do-files? + (set! files + (cons (in-vicinity directory fname) files)))) + ((eqv? 1 (sscanf line "D/%[^/]" fname)) + (set! files + (append (cvs:entries (sub-vicinity directory fname) + do-files?) + (if do-files? '() + (list (sub-vicinity directory fname))) + files)))))))) + (slib:warn 'cvs:entries 'missing cvse)) + (set! files (reverse files)) + (if (file-exists? cvsel) + (call-with-input-file cvsel + (lambda (port) + (do ((line (read-line port) (read-line port))) + ((eof-object? line) files) + (let ((fname #f)) + (cond ((eqv? 1 (sscanf line "A D/%[^/]/" fname)) + (set! files + (append files + (if do-files? '() + (list (sub-vicinity directory fname))) + (cvs:entries (sub-vicinity directory fname) + do-files?))))))))) + files)) + +;;@body Returns the (string) contents of @var{path/}CVS/Root; +;;or @code{(getenv "CVSROOT")} if Root doesn't exist. +(define (cvs-root path/) + (if (not (vicinity:suffix? (string-ref path/ (+ -1 (string-length path/))))) + (slib:error 'missing 'vicinity-suffix path/)) + (let ((rootpath (string-append path/ "CVS/Root"))) + (if (file-exists? rootpath) + (call-with-input-file rootpath read-line) + (getenv "CVSROOT")))) + +;;@body Returns the (string) contents of @var{directory/}CVS/Root appended +;;with @var{directory/}CVS/Repository; or #f if @var{directory/}CVS/Repository +;;doesn't exist. +(define (cvs-repository directory/) + (let ((root (cvs-root directory/)) + (repath (in-vicinity (sub-vicinity directory/ "CVS/") "Repository"))) + (define root/idx (substring? "/" root)) + (define rootlen (string-length root)) + (and + root/idx + (file-exists? repath) + (let ((repos (call-with-input-file repath read-line))) + (define replen (and (string? repos) (string-length repos))) + (cond ((not (and replen (< 1 replen))) #f) + ((not (char=? #\/ (string-ref repos 0))) + (string-append root "/" repos)) + ((eqv? 0 (substring? (substring root root/idx rootlen) repos)) + (string-append + root + (substring repos (- rootlen root/idx) replen))) + (else (slib:error 'mismatched root repos))))))) + +;;@body +;;Writes @1 to file CVS/Root of @2 and all its subdirectories. +(define (cvs-set-root! new-root directory/) + (define root (cvs-root directory/)) + (define repos (cvs-repository directory/)) + (if (not repos) (slib:error 'not 'cvs directory/)) + (if (not (eqv? 0 (substring? root repos))) + (slib:error 'bad 'cvs root repos)) + (call-with-output-file + (in-vicinity (sub-vicinity directory/ "CVS") "Root") + (lambda (port) (write-line new-root port))) + (call-with-output-file + (in-vicinity (sub-vicinity directory/ "CVS") "Repository") + (lambda (port) + (write-line + (substring repos (+ 1 (string-length root)) (string-length repos)) + port)))) + +;;@body +;;Signals an error if CVS/Repository or CVS/Root files in @1 or any +;;subdirectory do not match. +(define (cvs-vet directory/) + (define diroot (cvs-root directory/)) + (for-each + (lambda (path/) + (define path/CVS (sub-vicinity path/ "CVS/")) + (cond ((not (cvs-repository path/)) + (slib:error 'bad (in-vicinity path/CVS "Repository"))) + ((not (equal? diroot (cvs-root path/))) + (slib:error 'mismatched 'root (in-vicinity path/CVS "Root"))))) + (or (cvs-directories directory/) (slib:error 'not 'cvs directory/)))) + +;;(define cvs-rsh (or (getenv "CVS_RSH") "rsh")) @@ -0,0 +1,32 @@ + +@defun cvs-files directory/ +Returns a list of the local pathnames (with prefix @var{directory/}) of all +CVS controlled files in @var{directory/} and in @var{directory/}'s subdirectories. +@end defun + +@defun cvs-directories directory/ +Returns a list of all of @var{directory/} and all @var{directory/}'s CVS controlled +subdirectories. +@end defun + +@defun cvs-root path/ +Returns the (string) contents of @var{path/}CVS/Root; +or @code{(getenv "CVSROOT")} if Root doesn't exist. +@end defun + +@defun cvs-repository directory/ +Returns the (string) contents of @var{directory/}CVS/Root appended +with @var{directory/}CVS/Repository; or #f if @var{directory/}CVS/Repository +doesn't exist. +@end defun + +@deffn {Procedure} cvs-set-root! new-root directory/ + +Writes @var{new-root} to file CVS/Root of @var{directory/} and all its subdirectories. +@end deffn + +@defun cvs-vet directory/ + +Signals an error if CVS/Repository or CVS/Root files in @var{directory/} or any +subdirectory do not match. +@end defun diff --git a/daylight.scm b/daylight.scm new file mode 100644 index 0000000..6c989b2 --- /dev/null +++ b/daylight.scm @@ -0,0 +1,356 @@ +;;; "daylight.scm" Model of sun and sky colors. +; Copyright 2001 Aubrey Jaffer +; +;Permission to copy this software, to modify it, to redistribute it, +;to distribute modified versions, and to use it for any purpose is +;granted, subject to the following restrictions and understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warranty or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +(require 'color-space) + +(define pi (* 4 (atan 1))) +(define pi/180 (/ pi 180)) + +;;@code{(require 'daylight)} +;;@ftindex daylight +;;@ftindex sunlight +;;@ftindex sun +;;@ftindex sky +;; +;;@noindent +;;This package calculates the colors of sky as detailed in:@* +;;@uref{http://www.cs.utah.edu/vissim/papers/sunsky/sunsky.pdf}@* +;;@cite{A Practical Analytic Model for Daylight}@* +;;A. J. Preetham, Peter Shirley, Brian Smits + +;;@body +;; +;;Returns the solar-time in hours given the integer @1 in the range 1 to +;;366, and the local time in hours. +;; +;;To be meticulous, subtract 4 minutes for each degree of longitude west +;;of the standard meridian of your time zone. +(define (solar-hour julian-day hour) + (+ hour + (* 0.170 (sin (* 4 pi (- julian-day 80) 1/373))) + (* -0.129 (sin (* 2 pi (- julian-day 8) 1/355))))) + +;;@body +(define (solar-declination julian-day) + (/ (* 0.4093 (sin (* 2 pi (- julian-day 81) 1/368))) pi/180)) + +;;@body Returns a list of @var{theta_s}, the solar angle from the +;;zenith, and @var{phi_s}, the solar azimuth. 0 <= @var{theta_s} +;;measured in degrees. @var{phi_s} is measured in degrees from due +;;south; west of south being positive. +(define (solar-polar declination latitude solar-hour) + (define l (* pi/180 latitude)) + (define d (* pi/180 declination)) + (define pi*t/12 (* pi solar-hour 1/12)) + (map (lambda (x) (/ x pi/180)) + (list (- (/ pi 2) (asin (- (* (sin l) (sin d)) + (* (cos l) (cos d) (cos pi*t/12))))) + (atan (* -1 (cos d) (sin pi*t/12)) + (- (* (cos l) (sin d)) + (* (sin l) (cos d) (cos pi*t/12))))))) + +;;@noindent +;;In the following procedures, the number 0 <= @var{theta_s} <= 90 is +;;the solar angle from the zenith in degrees. + +;;(plot (lambda (t) (+ -.5 (/ 9 (expt 1.55 t)))) 0 6) ;tweaked + +;;@cindex turbidity +;;@noindent +;;Turbidity is a measure of the fraction of scattering due to haze as +;;opposed to molecules. This is a convenient quantity because it can be +;;estimated based on visibility of distant objects. This model fails +;;for turbidity values less than 1.3. +;; +;;@example +;;@group +;; _______________________________________________________________ +;;512|-: | +;; | * pure-air | +;;256|-:** | +;; | : ** exceptionally-clear | +;;128|-: * | +;; | : ** | +;; 64|-: * | +;; | : ** very-clear | +;; 32|-: ** | +;; | : ** | +;; 16|-: *** clear | +;; | : **** | +;; 8|-: **** | +;; | : **** light-haze | +;; 4|-: **** | +;; | : ****** | +;; 2|-: ******** haze thin-| +;; | : *********** fog | +;; 1|-:----------------------------------------------------*******--| +;; |_:____.____:____.____:____.____:____.____:____.____:____.____:_| +;; 1 2 4 8 16 32 64 +;; Meterorological range (km) versus Turbidity +;;@end group +;;@end example + +(define sol-spec + '#(16559.0 + 16233.7 + 21127.5 + 25888.2 + 25829.1 + 24232.3 + 26760.5 + 29658.3 + 30545.4 + 30057.5 + 30663.7 + 28830.4 + 28712.1 + 27825.0 + 27100.6 + 27233.6 + 26361.3 + 25503.8 + 25060.2 + 25311.6 + 25355.9 + 25134.2 + 24631.5 + 24173.2 + 23685.3 + 23212.1 + 22827.7 + 22339.8 + 21970.2 + 21526.7 + 21097.9 + 20728.3 + 20240.4 + 19870.8 + 19427.2 + 19072.4 + 18628.9 + 18259.2 + 17960 ;guesses for the rest + 17730 + 17570)) + +(define k_o-spec + '#(0.003 + 0.006 + 0.009 + 0.014 + 0.021 + 0.03 + 0.04 + 0.048 + 0.063 + 0.075 + 0.085 + 0.103 + 0.12 + 0.12 + 0.115 + 0.125 + 0.12 + 0.105 + 0.09 + 0.079 + 0.067 + 0.057 + 0.048 + 0.036 + 0.028 + 0.023 + 0.018 + 0.014 + 0.011 + 0.01 + 0.009 + 0.007 + 0.004 + 0)) + +;;@body Returns a vector of 41 values, the spectrum of sunlight from +;;380.nm to 790.nm for a given @1 and @2. +(define (sunlight-spectrum turbidity theta_s) + (define (solCurve wl) (vector-ref sol-spec (quotient (- wl 380) 10))) + (define (k_oCurve wl) (if (>= wl 450) + (vector-ref k_o-spec (quotient (- wl 450) 10)) + 0)) + (define (k_gCurve wl) (case wl + ((760) 3.0) + ((770) 0.21) + (else 0))) + (define (k_waCurve wl) (case wl + ((690) 0.016) + ((700) 0.024) + ((710) 0.0125) + ((720) 1) + ((730) 0.87) + ((740) 0.061) + ((750) 0.001) + ((760) 1.e-05) + ((770) 1.e-05) + ((780) 0.0006) + (else 0))) + + (define data (make-vector (+ 1 (quotient (- 780 380) 10)) 0.0)) + ;;alpha - ratio of small to large particle sizes. (0:4,usually 1.3) + (define alpha 1.3) + ;;beta - amount of aerosols present + (define beta (- (* 0.04608365822050 turbidity) 0.04586025928522)) + ;;lOzone - amount of ozone in cm(NTP) + (define lOzone .35) + ;;w - precipitable water vapor in centimeters (standard = 2) + (define w 2.0) + ;;m - Relative Optical Mass + (define m (/ (+ (cos (* pi/180 theta_s)) + (* 0.15 (expt (- 93.885 theta_s) -1.253))))) + (and + (not (negative? (- 93.885 theta_s))) + ;; Compute specturm of sunlight + (do ((wl 780 (+ -5 wl))) + ((< wl 380) data) + (let* (;;Rayleigh Scattering + ;; paper and program disagree!! Looks like font-size typo in paper. + ;;(tauR (exp (* -0.008735 (expt (/ wl 1000) (* -4.08 m))))) ;sunsky.pdf + (tauR (exp (* -0.008735 m (expt (/ wl 1000) -4.08)))) ;RiSunConstants.C + ;;Aerosal (water + dust) attenuation + ;; paper and program disagree!! Looks like font-size typo in paper. + ;;(tauA (exp (* -1 beta (expt (/ wl 1000) (* -1 m alpha))))) + (tauA (exp (* -1 m beta (expt (/ wl 1000) (- alpha))))) + ;;Attenuation due to ozone absorption + (tauO (exp (* -1 m (k_oCurve wl) lOzone))) + ;;Attenuation due to mixed gases absorption + (tauG (exp (* -1.41 m (k_gCurve wl) + (expt (+ 1 (* 118.93 m (k_gCurve wl))) -0.45)))) + ;;Attenuation due to water vapor absorbtion + (tauWA (exp (* -0.2385 m w (k_waCurve wl) + (expt (+ 1 (* 20.07 m w (k_waCurve wl))) -0.45))))) + (vector-set! data (quotient (- wl 380) 10) + (* (solCurve wl) tauR tauA tauO tauG tauWA)))))) + +;;@body Returns (unnormalized) XYZ values for color of sunlight for a +;;given @1 and @2. +(define (sunlight-XYZ turbidity theta_s) + (define spectrum (sunlight-spectrum turbidity theta_s)) + (and spectrum (spectrum->XYZ spectrum 380.e-9 780.e-9))) + +;;@body Given @1 and @2, @0 returns the CIEXYZ triple for color of +;;sunlight scaled to be just inside the RGB709 gamut. +(define (sunlight-CIEXYZ turbidity theta_s) + (define spectrum (sunlight-spectrum turbidity theta_s)) + (and spectrum (spectrum->CIEXYZ spectrum 380.e-9 780.e-9))) + +;; Arguments and result in radians +(define (angle-between theta phi theta_s phi_s) + (define cospsi (+ (* (sin theta) (sin theta_s) (cos (- phi phi_s))) + (* (cos theta) (cos theta_s)))) + (cond ((> cospsi 1) 0) + ((< cospsi -1) pi) + (else (acos cospsi)))) + +;;@body Returns the xyY (chromaticity and luminance) at the zenith. The +;;Luminance has units kcd/m^2. +(define (zenith-xyY turbidity theta_s) + (let* ((ths (* theta_s pi/180)) + (thetas (do ((th 1 (* ths th)) + (lst '() (cons th lst)) + (cnt 3 (+ -1 cnt))) + ((negative? cnt) lst))) + (turbds (do ((tr 1 (* turbidity tr)) + (lst '() (cons tr lst)) + (cnt 2 (+ -1 cnt))) + ((negative? cnt) lst)))) + (append (map (lambda (row) (apply + (map * row turbds))) + (map color:linear-transform + '(((+0.00165 -0.00374 +0.00208 +0 ) + (-0.02902 +0.06377 -0.03202 +0.00394) + (+0.11693 -0.21196 +0.06052 +0.25885)) + ((+0.00275 -0.00610 +0.00316 +0 ) + (-0.04214 +0.08970 -0.04153 +0.00515) + (+0.15346 -0.26756 +0.06669 +0.26688))) + (list thetas thetas))) + (list (+ (* (tan (* (+ 4/9 (/ turbidity -120)) (+ pi (* -2 ths)))) + (- (* 4.0453 turbidity) 4.9710)) + (* -0.2155 turbidity) + 2.4192))))) + +;;@body @1 is a positive real number expressing the amount of light +;;scattering. The real number @2 is the solar angle from the zenith in +;;degrees. +;; +;;@0 returns a function of one angle @var{theta}, the angle from the +;;zenith of the viewing direction (in degrees); and returning the xyY +;;value for light coming from that elevation of the sky. +(define (overcast-sky-color-xyY turbidity theta_s) + (define xyY_z (zenith-xyY turbidity theta_s)) + (lambda (theta . phi) + (list (car xyY_z) (cadr xyY_z) + (* 1/3 (caddr xyY_z) (+ 1 (* 2 (cos (* pi/180 theta)))))))) + +;;@body @1 is a positive real number expressing the amount of light +;;scattering. The real number @2 is the solar angle from the zenith in +;;degrees. The real number @3 is the solar angle from south. +;; +;;@0 returns a function of two angles, @var{theta} and @var{phi} which +;;specify the angles from the zenith and south meridian of the viewing +;;direction (in degrees); returning the xyY value for light coming from +;;that direction of the sky. +;; +;;@code{sky-color-xyY} calls @code{overcast-sky-color-xyY} for +;;@1 <= 20; otherwise the @0 function. +(define (clear-sky-color-xyY turbidity theta_s phi_s) + (define xyY_z (zenith-xyY turbidity theta_s)) + (define th_s (* pi/180 theta_s)) + (define ph_s (* pi/180 phi_s)) + (define (F~ A B C D E) + (lambda (th gm) + (* (+ 1 (* A (exp (/ B (cos th))))) + (+ 1 (* C (exp (* D gm))) (* E (expt (cos gm) 2)))))) + (let* ((tb1 (list turbidity 1)) + (Fs (map (lambda (mat) (apply F~ (color:linear-transform mat tb1))) + '((( 0.17872 -1.46303) + (-0.35540 +0.42749) + (-0.02266 +5.32505) + ( 0.12064 -2.57705) + (-0.06696 +0.37027)) + ((-0.01925 -0.25922) + (-0.06651 +0.00081) + (-0.00041 +0.21247) + (-0.06409 -0.89887) + (-0.00325 +0.04517)) + ((-0.01669 -0.26078) + (-0.09495 +0.00921) + (-0.00792 +0.21023) + (-0.04405 -1.65369) + (-0.01092 +0.05291))))) + (F_0s (map (lambda (F) (F 0 th_s)) Fs))) + (lambda (theta phi) + (let* ((th (* pi/180 theta)) + (ph (* pi/180 phi)) + (gm (angle-between th_s ph_s th ph))) + ;;(print th ph '=> gm) + (map (lambda (x F F_0) (* x (/ (F th gm) F_0))) + xyY_z + Fs + F_0s))))) +(define (sky-color-xyY turbidity theta_s phi_s) + (if (> turbidity 20) + (overcast-sky-color-xyY turbidity theta_s) + (clear-sky-color-xyY turbidity theta_s phi_s))) diff --git a/daylight.txi b/daylight.txi new file mode 100644 index 0000000..fa24afc --- /dev/null +++ b/daylight.txi @@ -0,0 +1,117 @@ +@code{(require 'daylight)} +@ftindex daylight +@ftindex sunlight +@ftindex sun +@ftindex sky + +@noindent +This package calculates the colors of sky as detailed in:@* +@uref{http://www.cs.utah.edu/vissim/papers/sunsky/sunsky.pdf}@* +@cite{A Practical Analytic Model for Daylight}@* +A. J. Preetham, Peter Shirley, Brian Smits + + +@defun solar-hour julian-day hour + + +Returns the solar-time in hours given the integer @var{julian-day} in the range 1 to +366, and the local time in hours. + +To be meticulous, subtract 4 minutes for each degree of longitude west +of the standard meridian of your time zone. +@end defun + +@defun solar-declination julian-day + +@end defun + +@defun solar-polar declination latitude solar-hour +Returns a list of @var{theta_s}, the solar angle from the +zenith, and @var{phi_s}, the solar azimuth. 0 <= @var{theta_s} +measured in degrees. @var{phi_s} is measured in degrees from due +south; west of south being positive. +@end defun +@noindent +In the following procedures, the number 0 <= @var{theta_s} <= 90 is +the solar angle from the zenith in degrees. + +@cindex turbidity +@noindent +Turbidity is a measure of the fraction of scattering due to haze as +opposed to molecules. This is a convenient quantity because it can be +estimated based on visibility of distant objects. This model fails +for turbidity values less than 1.3. + +@example +@group + _______________________________________________________________ +512|-: | + | * pure-air | +256|-:** | + | : ** exceptionally-clear | +128|-: * | + | : ** | + 64|-: * | + | : ** very-clear | + 32|-: ** | + | : ** | + 16|-: *** clear | + | : **** | + 8|-: **** | + | : **** light-haze | + 4|-: **** | + | : ****** | + 2|-: ******** haze thin-| + | : *********** fog | + 1|-:----------------------------------------------------*******--| + |_:____.____:____.____:____.____:____.____:____.____:____.____:_| + 1 2 4 8 16 32 64 + Meterorological range (km) versus Turbidity +@end group +@end example + + +@defun sunlight-spectrum turbidity theta_s +Returns a vector of 41 values, the spectrum of sunlight from +380.nm to 790.nm for a given @var{turbidity} and @var{theta_s}. +@end defun + +@defun sunlight-xyz turbidity theta_s +Returns (unnormalized) XYZ values for color of sunlight for a +given @var{turbidity} and @var{theta_s}. +@end defun + +@defun sunlight-ciexyz turbidity theta_s +Given @var{turbidity} and @var{theta_s}, @code{sunlight-ciexyz} returns the CIEXYZ triple for color of +sunlight scaled to be just inside the RGB709 gamut. +@end defun + +@defun zenith-xyy turbidity theta_s +Returns the xyY (chromaticity and luminance) at the zenith. The +Luminance has units kcd/m^2. +@end defun + +@defun overcast-sky-color-xyy turbidity theta_s +@var{turbidity} is a positive real number expressing the amount of light +scattering. The real number @var{theta_s} is the solar angle from the zenith in +degrees. + +@code{overcast-sky-color-xyy} returns a function of one angle @var{theta}, the angle from the +zenith of the viewing direction (in degrees); and returning the xyY +value for light coming from that elevation of the sky. +@end defun + +@defun clear-sky-color-xyy turbidity theta_s phi_s +@defunx sky-color-xyy turbidity theta_s phi_s +@var{turbidity} is a positive real number expressing the amount of light +scattering. The real number @var{theta_s} is the solar angle from the zenith in +degrees. The real number @var{phi_s} is the solar angle from south. + +@code{clear-sky-color-xyy} returns a function of two angles, @var{theta} and @var{phi} which +specify the angles from the zenith and south meridian of the viewing +direction (in degrees); returning the xyY value for light coming from +that direction of the sky. + +@code{sky-color-xyY} calls @code{overcast-sky-color-xyY} for +@var{turbidity} <= 20; otherwise the @code{clear-sky-color-xyy} function. +@end defun diff --git a/db2html.scm b/db2html.scm index 3462966..df34389 100644 --- a/db2html.scm +++ b/db2html.scm @@ -8,7 +8,7 @@ ;1. Any copy made of this software must include this copyright notice ;in full. ; -;2. I have made no warrantee or representation that the operation of +;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; @@ -18,11 +18,20 @@ ;each case. (require 'uri) +(require 'printf) (require 'html-form) -(require 'net-clients) +(require 'directory) +(require 'databases) +(require 'string-case) (require 'string-search) +(require 'common-list-functions) +(require-if 'compiling 'pretty-print) +(require-if 'compiling 'database-commands) +(require 'hash) +(define (crc:hash-obj obj) (number->string (hash obj most-positive-fixnum) 16)) ;;@code{(require 'db->html)} +;;@ftindex db->html ;;@body (define (html:table options . rows) @@ -224,11 +233,11 @@ ;;@args table-name null-keys update ;;@args table-name null-keys ;; -;;Returns procedure (of @var{db}) which returns procedure to modify row -;;of @1. @2 is the list of @dfn{null} keys which indicate that the row -;;is to be deleted. Optional arguments @3, @4, and @5 default to the -;;@code{row:update}, @code{row:delete}, and @code{row:retrieve} of @1 in -;;@var{db}. +;;Returns procedure (of @var{db}) which returns procedure to modify +;;row of @1. @2 is the list of @dfn{null} keys indicating the row is +;;to be deleted when any matches its corresponding primary key. +;;Optional arguments @3, @4, and @5 default to the @code{row:update}, +;;@code{row:delete}, and @code{row:retrieve} of @1 in @var{db}. (define (command:modify-table table-name null-keys . args) (define argc (length args)) (lambda (rdb) @@ -251,7 +260,7 @@ (table:update new-row) ((rdb 'sync-database)) #t) (else '("Row changed by other user")))) - ((equal? null-keys new-pkeys) ;blanked keys + ((command:null-key? null-keys new-pkeys) ;blanked keys (cond ((not row) #t) ((equal? (crc:hash-obj row) *row-hash*) ;;(slib:warn (sprintf #f "Removing key: %#a => %#a" new-pkeys )) @@ -268,6 +277,26 @@ (apply table:delete pkeys)) ((rdb 'sync-database)) #t))))))))) +(define (command:null-key? null-keys new-pkeys) + (define sts #f) + (for-each (lambda (nuk nep) (if (equal? nuk nep) (set! sts #t))) + null-keys + new-pkeys) + sts) + +(define (make-defaulter arity type) + `(lambda (pl) + ',(case arity + ((optional nary) '()) + ((boolean) #f) + ((single nary1) + (case type + ((string) '("")) + ((symbol) '(nil)) + ((number) '(0)) + (else '(#f)))) + (else (slib:error 'make-defaulter 'unknown 'arity arity))))) + ;;@body Given @2 in @1, creates parameter and @code{*command*} tables ;;for editing one row of @2 at a time. @0 returns a procedure taking a ;;row argument which returns the HTML string for editing that row. @@ -286,6 +315,7 @@ ;;@end table (define (command:make-editable-table rdb table-name . args) (define table ((rdb 'open-table) table-name #t)) + (require 'database-commands) (let ((pkl (table 'primary-limit)) (columns (table 'column-names)) (domains (table 'column-domains)) @@ -313,7 +343,8 @@ (define foreign-choice-lists (map (lambda (domain-name) (define tab-name (ftn domain-name)) - (if tab-name (get-foreign-choices (rdb-open tab-name #f)) '())) + (if tab-name (get-foreign-choices + ((rdb 'open-table) tab-name #f)) '())) domains)) (define-tables rdb `(,(symbol-append table-name '- 'params) @@ -323,7 +354,7 @@ ,@field-specs)) `(,(symbol-append table-name '- 'pname) ((name string)) - ((parameter-index uint)) ;should be address-params + ((parameter-index ordinal)) ;should be address-params (("*keys*" 1) ("*row-hash*" 2) ,@(map (lambda (idx column) (list (symbol->string column) idx)) @@ -335,7 +366,10 @@ ,(symbol-append table-name '- 'pname) (command:modify-table ',table-name ',(map (lambda (fs) - (caadr (caddar (cddddr fs)))) + (define dfl + ((slib:eval (car (cddddr fs))) + '())) + (if (pair? dfl) (car dfl) dfl)) (butnthcdr pkl field-specs)) ,@args) ,(string-append "Modify " (symbol->string table-name)))))) @@ -424,16 +458,17 @@ ;;top level page with the catalog of tables (captioned @4) is written ;;to a file named @3. (define (db->html-files db dir index-filename caption) - (call-with-output-file (in-vicinity (if dir (sub-vicinity "" dir) "") - index-filename) + (set! dir (if dir (sub-vicinity "" dir) "")) + (call-with-output-file (in-vicinity dir index-filename) (lambda (port) (display (catalog->page db caption) port))) - ((((db 'open-table) '*catalog-data* #f) 'for-each-row) - (lambda (row) - (call-with-output-file - (in-vicinity (sub-vicinity "" dir) (table-name->filename (car row))) - (lambda (port) - (display (table->linked-page db (car row) index-filename) port)))))) + (let ((catdat ((db 'open-table) '*catalog-data* #f))) + ((or (catdat 'for-each-row-in-order) (catdat 'for-each-row)) + (lambda (row) + (call-with-output-file + (in-vicinity dir (table-name->filename (car row))) + (lambda (port) + (display (table->linked-page db (car row) index-filename) port))))))) ;;@args db dir index-filename ;;@args db dir @@ -457,7 +492,7 @@ ;;@args db dir index-filename ;;@args db dir ;;@0 is just like @code{db->html-directory}, but calls -;;@code{browse-url-netscape} with the uri for the top page after the +;;@code{browse-url} with the uri for the top page after the ;;pages are created. (define (db->netscape . args) - (browse-url-netscape (apply db->html-directory args))) + (browse-url (apply db->html-directory args))) diff --git a/db2html.txi b/db2html.txi index 0acdd46..3b47f31 100644 --- a/db2html.txi +++ b/db2html.txi @@ -1,4 +1,5 @@ @code{(require 'db->html)} +@ftindex db->html @defun html:table options row @dots{} @@ -104,12 +105,12 @@ database is performed. @defunx command:modify-table table-name null-keys -Returns procedure (of @var{db}) which returns procedure to modify row -of @var{table-name}. @var{null-keys} is the list of @dfn{null} keys which indicate that the row +Returns procedure (of @var{db}) which returns procedure to modify +row of @var{table-name}. @var{null-keys} is the list of @dfn{null} keys indicating the row is @cindex null -is to be deleted. Optional arguments @var{update}, @var{delete}, and @var{retrieve} default to the -@code{row:update}, @code{row:delete}, and @code{row:retrieve} of @var{table-name} in -@var{db}. +to be deleted when any matches its corresponding primary key. +Optional arguments @var{update}, @var{delete}, and @var{retrieve} default to the @code{row:update}, +@code{row:delete}, and @code{row:retrieve} of @var{table-name} in @var{db}. @end defun @defun command:make-editable-table rdb table-name arg @dots{} @@ -180,6 +181,6 @@ returned. @defunx db->netscape db dir @code{db->netscape} is just like @code{db->html-directory}, but calls -@code{browse-url-netscape} with the uri for the top page after the +@code{browse-url} with the uri for the top page after the pages are created. @end defun diff --git a/dbcom.scm b/dbcom.scm new file mode 100644 index 0000000..428e3db --- /dev/null +++ b/dbcom.scm @@ -0,0 +1,215 @@ +;;; "dbcom.scm" embed commands in relational-database +; Copyright 1994, 1995, 1997, 2000, 2001 Aubrey Jaffer +; +;Permission to copy this software, to modify it, to redistribute it, +;to distribute modified versions, and to use it for any purpose is +;granted, subject to the following restrictions and understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warranty or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +(require 'common-list-functions) ;for position +(require 'relational-database) +(require 'databases) +;@ +(define (wrap-command-interface rdb) + (let* ((rdms:commands ((rdb 'open-table) '*commands* #f)) + (command:get (and rdms:commands (rdms:commands 'get 'procedure)))) + (and command:get + (letrec ((wdb (lambda (command) + (let ((com (command:get command))) + (if com ((slib:eval com) wdb) (rdb command)))))) + (let ((init (wdb '*initialize*))) + (if (procedure? init) init wdb)))))) +;@ +(define (open-command-database! path . arg) + (define bt (apply open-database! path arg)) + (and bt (wrap-command-interface bt))) +;@ +(define (open-command-database path . arg) + (define bt (apply open-database path arg)) + (and bt (wrap-command-interface bt))) +;@ +(define (add-command-tables rdb) + (define-tables + rdb + '(type + ((name symbol)) + () + ((atom) + (symbol) + (string) + (number) + (money) + (date-time) + (boolean) + (foreign-key) + (expression) + (virtual))) + '(parameter-arity + ((name symbol)) + ((predicate? expression) + (procedure expression)) + ((single (lambda (a) (and (pair? a) (null? (cdr a)))) car) + (optional + (lambda (lambda (a) (or (null? a) (and (pair? a) (null? (cdr a)))))) + identity) + (boolean + (lambda (a) (or (null? a) + (and (pair? a) (null? (cdr a)) (boolean? (car a))))) + (lambda (a) (if (null? a) #f (car a)))) + (nary (lambda (a) #t) identity) + (nary1 (lambda (a) (not (null? a))) identity)))) + (for-each (((rdb 'open-table) '*domains-data* #t) 'row:insert) + '((parameter-list *catalog-data* #f symbol 1) + (parameter-name-translation *catalog-data* #f symbol 1) + (parameter-arity parameter-arity #f symbol 1) + (table *catalog-data* #f atom 1))) + (define-tables + rdb + '(*parameter-columns* + *columns* + *columns* + ((1 #t index #f ordinal) + (2 #f name #f symbol) + (3 #f arity #f parameter-arity) + (4 #f domain #f domain) + (5 #f defaulter #f expression) + (6 #f expander #f expression) + (7 #f documentation #f string))) + '(no-parameters + *parameter-columns* + *parameter-columns* + ()) + '(no-parameter-names + ((name string)) + ((parameter-index ordinal)) + ()) + '(add-domain-params + *parameter-columns* + *parameter-columns* + ((1 domain-name single atom #f #f "new domain name") + (2 foreign-table optional table #f #f + "if present, domain-name must be existing key into this table") + (3 domain-integrity-rule optional expression #f #f + "returns #t if single argument is good") + (4 type-id single type #f #f "base type of new domain") + (5 type-param optional expression #f #f + "which (key) field of the foreign-table") + )) + '(add-domain-pnames + ((name string)) + ((parameter-index ordinal)) ;should be add-domain-params + ( + ("n" 1) ("name" 1) + ("f" 2) ("foreign (key) table" 2) + ("r" 3) ("domain integrity rule" 3) + ("t" 4) ("type" 4) + ("p" 5) ("type param" 5) + )) + '(del-domain-params + *parameter-columns* + *parameter-columns* + ((1 domain-name single domain #f #f "domain name"))) + '(del-domain-pnames + ((name string)) + ((parameter-index ordinal)) ;should be del-domain-params + (("n" 1) ("name" 1))) + '(*commands* + ((name symbol)) + ((parameters parameter-list) + (parameter-names parameter-name-translation) + (procedure expression) + (documentation string)) + ((domain-checker + no-parameters + no-parameter-names + dbcom:check-domain + "return procedure to check given domain name") + + (add-domain + add-domain-params + add-domain-pnames + (lambda (rdb) + (((rdb 'open-table) '*domains-data* #t) 'row:update)) + "add a new domain") + + (delete-domain + del-domain-params + del-domain-pnames + (lambda (rdb) + (((rdb 'open-table) '*domains-data* #t) 'row:remove)) + "delete a domain")))) + (let* ((tab ((rdb 'open-table) '*domains-data* #t)) + (row ((tab 'row:retrieve) 'type))) + ((tab 'row:update) (cons 'type (cdr row)))) + (wrap-command-interface rdb)) +;@ +(define (define-*commands* rdb . cmd-defs) + (define defcmd (((rdb 'open-table) '*commands* #t) 'row:update)) + (for-each (lambda (def) + (define procname (caar def)) + (define args (cdar def)) + (define body (cdr def)) + (let ((comment (and (string? (car body)) (car body)))) + (define nbody (if comment (cdr body) body)) + (defcmd (list procname + 'no-parameters + 'no-parameter-names + `(lambda ,args ,@nbody) + (or comment ""))))) + cmd-defs)) + +;; Actually put into command table by add-command-tables +(define (dbcom:check-domain rdb) + (let* ((ro:domains ((rdb 'open-table) '*domains-data* #f)) + (ro:get-dir (ro:domains 'get 'domain-integrity-rule)) + (ro:for-tab (ro:domains 'get 'foreign-table))) + (lambda (domain) + (let ((fkname (ro:for-tab domain)) + (dir (slib:eval (ro:get-dir domain)))) + (if fkname (let* ((fktab ((rdb 'open-table) fkname #f)) + (p? (fktab 'get 1))) + (if dir (lambda (e) (and (dir e) (p? e))) p?)) + dir))))) +;@ +(define (make-command-server rdb command-table) + (let* ((comtab ((rdb 'open-table) command-table #f)) + (names (comtab 'column-names)) + (row-ref (lambda (row name) (list-ref row (position name names)))) + (comgetrow (comtab 'row:retrieve))) + (lambda (comname command-callback) + (cond ((not comname) (set! comname '*default*))) + (cond ((not (comgetrow comname)) + (slib:error 'command 'not 'known: comname))) + (let* ((command:row (comgetrow comname)) + (parameter-table + ((rdb 'open-table) (row-ref command:row 'parameters) #f)) + (parameter-names + ((rdb 'open-table) (row-ref command:row 'parameter-names) #f)) + (comval ((slib:eval (row-ref command:row 'procedure)) rdb)) + (options ((parameter-table 'get* 'name))) + (positions ((parameter-table 'get* 'index))) + (arities ((parameter-table 'get* 'arity))) + (defaulters (map slib:eval ((parameter-table 'get* 'defaulter)))) + (domains ((parameter-table 'get* 'domain))) + (types (map (((rdb 'open-table) '*domains-data* #f) 'get 'type-id) + domains)) + (dirs (map (or (rdb 'domain-checker) (lambda (domain) + (lambda (domain) #t))) + domains)) + (aliases + (map list ((parameter-names 'get* 'name)) + (map (parameter-table 'get 'name) + ((parameter-names 'get* 'parameter-index)))))) + (command-callback comname comval options positions + arities types defaulters dirs aliases))))) diff --git a/dbinterp.scm b/dbinterp.scm new file mode 100644 index 0000000..8ccb1df --- /dev/null +++ b/dbinterp.scm @@ -0,0 +1,34 @@ +;;; "dbinterp.scm" Interpolate function from database table. +;Copyright 2003 Aubrey Jaffer +; +;Permission to copy this software, to modify it, to redistribute it, +;to distribute modified versions, and to use it for any purpose is +;granted, subject to the following restrictions and understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warranty or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +;;@ This procedure works only for tables with a single primary key. +(define (interpolate-from-table table column) + (define get (table 'get column)) + (define prev (table 'isam-prev)) + (define next (table 'isam-next)) + (lambda (x) + (let ((nxt (next x))) + (if nxt (set! nxt (car nxt))) + (let ((prv (prev (or nxt x)))) + (if prv (set! prv (car prv))) + (cond ((not nxt) (get prv)) + ((not prv) (get nxt)) + (else (/ (+ (* (- x prv) (get nxt)) + (* (- nxt x) (get prv))) + (- nxt prv)))))))) diff --git a/dbrowse.scm b/dbrowse.scm index e186492..9401c6d 100644 --- a/dbrowse.scm +++ b/dbrowse.scm @@ -8,7 +8,7 @@ ;1. Any copy made of this software must include this copyright notice ;in full. ; -;2. I have made no warrantee or representation that the operation of +;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; @@ -17,11 +17,11 @@ ;promotional, or sales literature without prior written consent in ;each case. -(require 'database-utilities) +(require 'databases) (require 'printf) (define browse:db #f) - +;@ (define (browse . args) (define table-name #f) (cond ((null? args)) @@ -48,8 +48,8 @@ (define (browse:display-dir table-name table) (printf "%s Tables:\\n" table-name) - ((table 'for-each-row) - (lambda (row) (printf "\\t%s\\n" (car row))))) + ((or (table 'for-each-row-in-order) (table 'for-each-row)) + (lambda (row) (printf "\\t%a\\n" (car row))))) (define (browse:display-table table-name table) (let* ((width 18) @@ -73,7 +73,7 @@ (newline) (for-each (lambda (type) (case type - ((integer number uint base-id) + ((integer number ordinal base-id uint) (set! form (string-append form dw-integer))) ((boolean domain expression atom) (set! form (string-append form dwp-any))) @@ -87,6 +87,6 @@ (for-each (lambda (domain) (printf underline)) (table 'column-domains)) (newline) - ((table 'for-each-row) + ((or (table 'for-each-row-in-order) (table 'for-each-row)) (lambda (row) (apply printf form row))))) diff --git a/dbsyn.scm b/dbsyn.scm new file mode 100644 index 0000000..1bc1319 --- /dev/null +++ b/dbsyn.scm @@ -0,0 +1,54 @@ +;;;; "dbsyn.scm" -- Syntactic extensions for RDMS (within-database) +;;; Copyright (C) 2002 Ivan Shmakov <ivan@theory.dcn-asu.ru> +;; +;; Permission to copy this software, to modify it, to redistribute it, +;; to distribute modified versions, and to use it for any purpose is +;; granted, subject to the following restrictions and understandings. +;; +;; 1. Any copy made of this software must include this copyright notice +;; in full. +;; +;; 2. I have made no warranty or representation that the operation of +;; this software will be error-free, and I am under no obligation to +;; provide any services, by way of maintenance, update, or otherwise. +;; +;; 3. In conjunction with products arising from the use of this +;; material, there shall be no use of my name in any advertising, +;; promotional, or sales literature without prior written consent in +;; each case. + +;;; History: + +;; 2002-08-01: I've tired of tracking database description elements +;; (such as `(define-tables ...)'); so I decided to use `etags'. But +;; its hard (if possible) to create regexp to match against RDMS' table +;; specs. So I wrote `within-database' syntax extension and now I can +;; simply use something like: + +;; $ etags -l scheme \ +;; -r '/ *(define-\(command\|table\) (\([^; \t]+\)/\2/' \ +;; source1.scm ... + +;; ... and get TAGS table with all of my database commands and tables. + +(require 'relational-database) +(require 'database-commands) +(require 'databases) +;@ +(define-syntax within-database + (syntax-rules (define-table define-command) + + ((within-database database) + database) + + ((within-database database + (define-table (name primary columns) row ...) + rest ...) + (begin (define-tables database '(name primary columns (row ...))) + (within-database database rest ...))) + + ((within-database database + (define-command template arg-1 arg-2 ...) + rest ...) + (begin (define-*commands* database '(template arg-1 arg-2 ...)) + (within-database database rest ...))))) @@ -1,5 +1,5 @@ ;;; "dbutil.scm" relational-database-utilities -; Copyright 1994, 1995, 1997, 2000, 2001 Aubrey Jaffer +; Copyright 1994, 1995, 1997, 2000, 2001, 2002 Aubrey Jaffer ; ;Permission to copy this software, to modify it, to redistribute it, ;to distribute modified versions, and to use it for any purpose is @@ -8,7 +8,7 @@ ;1. Any copy made of this software must include this copyright notice ;in full. ; -;2. I have made no warrantee or representation that the operation of +;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; @@ -17,226 +17,418 @@ ;promotional, or sales literature without prior written consent in ;each case. +(require 'common-list-functions) ;for nthcdr and butnthcdr (require 'relational-database) -(require 'common-list-functions) - -(define (db:base-type path) - 'alist-table) ; currently the only one. - -(define (dbutil:wrap-command-interface rdb) - (and rdb - (let* ((rdms:commands ((rdb 'open-table) '*commands* #f)) - (command:get - (and rdms:commands (rdms:commands 'get 'procedure)))) - (and command:get - (letrec ((wdb (lambda (command) - (let ((com (command:get command))) - (cond (com ((slib:eval com) wdb)) - (else (rdb command))))))) - (let ((init (wdb '*initialize*))) - (if (procedure? init) init wdb))))))) - -(define (dbutil:open-database! path . arg) - (let ((type (if (null? arg) (db:base-type path) (car arg)))) - (require type) - (dbutil:wrap-command-interface - (((make-relational-system (slib:eval type)) 'open-database) - path #t)))) - -(define (dbutil:open-database path . arg) - (let ((type (if (null? arg) (db:base-type path) (car arg)))) - (require type) - (dbutil:wrap-command-interface - (((make-relational-system (slib:eval type)) 'open-database) - path #f)))) - -(define (dbutil:check-domain rdb) - (let* ((ro:domains ((rdb 'open-table) '*domains-data* #f)) - (ro:get-dir (ro:domains 'get 'domain-integrity-rule)) - (ro:for-tab (ro:domains 'get 'foreign-table))) - (lambda (domain) - (let ((fkname (ro:for-tab domain)) - (dir (slib:eval (ro:get-dir domain)))) - (if fkname (let* ((fktab ((rdb 'open-table) fkname #f)) - (p? (fktab 'get 1))) - (if dir (lambda (e) (and (dir e) (p? e))) p?)) - dir))))) - -(define (dbutil:create-database path type) +(require 'dynamic-wind) +(require 'transact) +(require-if 'compiling 'printf) ;used only by mdbm:report +(require-if 'compiling 'alist-table) + +;;@code{(require 'databases)} +;;@ftindex databases +;; +;;@noindent +;;This enhancement wraps a utility layer on @code{relational-database} +;;which provides: +;; +;;@itemize @bullet +;;@item +;;Identification of open databases by filename. +;;@item +;;Automatic sharing of open (immutable) databases. +;;@item +;;Automatic loading of base-table package when creating a database. +;;@item +;;Detection and automatic loading of the appropriate base-table package +;;when opening a database. +;;@item +;;Table and data definition from Scheme lists. +;;@end itemize + +;;;Each entry in mdbm:*databases* is a list of: + +;;; * database (procedure) +;;; * number of opens (integer) +;;; * type (symbol) +;;; * lock-certificate + +;;;Because of WRITE-DATABASE, database filenames can change, so we must +;;;have a global lock. +(define mdbm:*databases* (make-exchanger '())) +(define (mdbm:return-dbs dbs) + (if (mdbm:*databases* dbs) + (slib:error 'mdbm:*databases* 'double 'set!))) + +(define (mdbm:find-db? rdb dbs) + (and dbs + (do ((dbs dbs (cdr dbs))) + ((or (null? dbs) + (equal? ((caar dbs) 'filename) + (if (procedure? rdb) (rdb 'filename) rdb))) + (and (not (null? dbs)) + (if (and (procedure? rdb) + (not (eq? ((caar dbs) 'filename) (rdb 'filename)))) + (slib:error ((caar dbs) 'filename) 'open 'twice) + (car dbs))))))) + +(define (mdbm:remove-entry dbs entry) + (cond ((null? dbs) (slib:error 'mdbm:remove-entry 'not 'found entry)) + ((eq? entry (car dbs)) (cdr dbs)) + (else (cons (car dbs) (mdbm:remove-entry (cdr dbs) entry))))) + +;;@subsubheading Database Sharing + +;;@noindent +;;@dfn{Auto-sharing} refers to a call to the procedure +;;@code{open-database} returning an already open database (procedure), +;;rather than opening the database file a second time. +;; +;;@quotation +;;@emph{Note:} Databases returned by @code{open-database} do not include +;;wrappers applied by packages like @ref{Embedded Commands}. But +;;wrapped databases do work as arguments to these functions. +;;@end quotation +;; +;;@noindent +;;When a database is created, it is mutable by the creator and not +;;auto-sharable. A database opened mutably is also not auto-sharable. +;;But any number of readers can (open) share a non-mutable database file. + +;;@noindent +;;This next set of procedures mirror the whole-database methods in +;;@ref{Database Operations}. Except for @code{create-database}, each +;;procedure will accept either a filename or database procedure for its +;;first argument. + +(define (mdbm:try-opens filename mutable?) + (define (try base) + (let ((rdb (base 'open-database))) + (and rdb (rdb filename mutable?)))) + (define certificate (and mutable? (file-lock! filename))) + (define (loop bti) + (define rdb (try (cadar bti))) + (cond ((procedure? rdb) (list rdb 1 (caar bti) certificate)) + ((null? (cdr bti)) #f) + (else (loop (cdr bti))))) + (if (null? *base-table-implementations*) (require 'alist-table)) + (cond ((and (not (and mutable? (not certificate))) + (loop *base-table-implementations*))) + ((memq 'alist-table *base-table-implementations*) #f) + ((let () + (require 'alist-table) + (loop (list (car *base-table-implementations*))))) + (else #f))) + +(define (mdbm:open-type filename type mutable?) + (require type) + (let ((certificate (and mutable? (file-lock! filename)))) + (and (not (and mutable? (not certificate))) + (let* ((sys (cadr (assq type *base-table-implementations*))) + (open (and sys (sys 'open-database))) + (ndb (and open (open filename mutable?)))) + (and ndb (list ndb 1 type certificate)))))) + +;;@args filename base-table-type +;;@1 should be a string naming a file; or @code{#f}. @2 must be a +;;symbol naming a feature which can be passed to @code{require}. @0 +;;returns a new, open relational database (with base-table type @2) +;;associated with @1, or a new ephemeral database if @1 is @code{#f}. +;; +;;@code{create-database} is the only run-time use of require in SLIB +;;which crosses module boundaries. When @2 is @code{require}d by @0; it +;;adds an association of @2 with its @dfn{relational-system} procedure +;;to @var{mdbm:*databases*}. +;; +;;alist-table is the default base-table type: +;; +;;@example +;;(require 'databases) +;;(define my-rdb (create-database "my.db" 'alist-table)) +;;@end example +(define (create-database filename type) (require type) - (let ((rdb (((make-relational-system (slib:eval type)) 'create-database) - path))) - (dbutil:define-tables - rdb - '(type - ((name symbol)) - () - ((atom) - (symbol) - (string) - (number) - (money) - (date-time) - (boolean) - (foreign-key) - (expression) - (virtual))) - '(parameter-arity - ((name symbol)) - ((predicate? expression) - (procedure expression)) - ((single (lambda (a) (and (pair? a) (null? (cdr a)))) car) - (optional - (lambda (lambda (a) (or (null? a) (and (pair? a) (null? (cdr a)))))) - identity) - (boolean - (lambda (a) (or (null? a) - (and (pair? a) (null? (cdr a)) (boolean? (car a))))) - (lambda (a) (if (null? a) #f (car a)))) - (nary (lambda (a) #t) identity) - (nary1 (lambda (a) (not (null? a))) identity)))) - (for-each (((rdb 'open-table) '*domains-data* #t) 'row:insert) - '((parameter-list *catalog-data* #f symbol 1) - (parameter-name-translation *catalog-data* #f symbol 1) - (parameter-arity parameter-arity #f symbol 1) - (table *catalog-data* #f atom 1))) - (dbutil:define-tables - rdb - '(*parameter-columns* - *columns* - *columns* - ((1 #t index #f uint) - (2 #f name #f symbol) - (3 #f arity #f parameter-arity) - (4 #f domain #f domain) - (5 #f defaulter #f expression) - (6 #f expander #f expression) - (7 #f documentation #f string))) - '(no-parameters - *parameter-columns* - *parameter-columns* - ()) - '(no-parameter-names - ((name string)) - ((parameter-index uint)) - ()) - '(add-domain-params - *parameter-columns* - *parameter-columns* - ((1 domain-name single atom #f #f "new domain name") - (2 foreign-table optional table #f #f - "if present, domain-name must be existing key into this table") - (3 domain-integrity-rule optional expression #f #f - "returns #t if single argument is good") - (4 type-id single type #f #f "base type of new domain") - (5 type-param optional expression #f #f - "which (key) field of the foreign-table") - )) - '(add-domain-pnames - ((name string)) - ((parameter-index uint)) ;should be add-domain-params - ( - ("n" 1) ("name" 1) - ("f" 2) ("foreign (key) table" 2) - ("r" 3) ("domain integrity rule" 3) - ("t" 4) ("type" 4) - ("p" 5) ("type param" 5) - )) - '(del-domain-params - *parameter-columns* - *parameter-columns* - ((1 domain-name single domain #f #f "domain name"))) - '(del-domain-pnames - ((name string)) - ((parameter-index uint)) ;should be del-domain-params - (("n" 1) ("name" 1))) - '(*commands* - ((name symbol)) - ((parameters parameter-list) - (parameter-names parameter-name-translation) - (procedure expression) - (documentation string)) - ((domain-checker - no-parameters - no-parameter-names - dbutil:check-domain - "return procedure to check given domain name") - - (add-domain - add-domain-params - add-domain-pnames - (lambda (rdb) - (((rdb 'open-table) '*domains-data* #t) 'row:update)) - "add a new domain") - - (delete-domain - del-domain-params - del-domain-pnames - (lambda (rdb) - (((rdb 'open-table) '*domains-data* #t) 'row:remove)) - "delete a domain")))) - (let* ((tab ((rdb 'open-table) '*domains-data* #t)) - (row ((tab 'row:retrieve) 'type))) - (set-car! (cdr row) 'type) - ((tab 'row:update) row)) - (dbutil:wrap-command-interface rdb))) - -(define (make-defaulter arity type) - `(lambda (pl) - ',(case arity - ((optional nary) '()) - ((boolean) #f) - ((single nary1) - (case type - ((string) '("")) - ((symbol) '(nil)) - ((number) '(0)) - (else '(#f)))) - (else (slib:error 'make-defaulter 'unknown 'arity arity))))) - -(define (get-foreign-choices tab) - (define dlst ((tab 'get* 1))) - (do ((dlst dlst (cdr dlst)) - (vlst (if (memq 'visible-name (tab 'column-names)) - ((tab 'get* 'visible-name)) - dlst) - (cdr vlst)) - (out '() (if (member (car dlst) (cdr dlst)) - out - (cons (list (car dlst) (car vlst)) out)))) - ((null? dlst) out))) - -(define (make-command-server rdb command-table) - (let* ((comtab ((rdb 'open-table) command-table #f)) - (names (comtab 'column-names)) - (row-ref (lambda (row name) (list-ref row (position name names)))) - (comgetrow (comtab 'row:retrieve))) - (lambda (comname command-callback) - (cond ((not comname) (set! comname '*default*))) - (cond ((not (comgetrow comname)) - (slib:error 'command 'not 'known: comname))) - (let* ((command:row (comgetrow comname)) - (parameter-table - ((rdb 'open-table) (row-ref command:row 'parameters) #f)) - (parameter-names - ((rdb 'open-table) (row-ref command:row 'parameter-names) #f)) - (comval ((slib:eval (row-ref command:row 'procedure)) rdb)) - (options ((parameter-table 'get* 'name))) - (positions ((parameter-table 'get* 'index))) - (arities ((parameter-table 'get* 'arity))) - (defaulters (map slib:eval ((parameter-table 'get* 'defaulter)))) - (domains ((parameter-table 'get* 'domain))) - (types (map (((rdb 'open-table) '*domains-data* #f) 'get 'type-id) - domains)) - (dirs (map (rdb 'domain-checker) domains)) - (aliases - (map list ((parameter-names 'get* 'name)) - (map (parameter-table 'get 'name) - ((parameter-names 'get* 'parameter-index)))))) - (command-callback comname comval options positions - arities types defaulters dirs aliases))))) - -(define (dbutil:define-tables rdb . spec-list) + (let ((dbs #f) + (certificate (and filename (file-lock! filename)))) + (and + (or certificate (not filename)) + (dynamic-wind + (lambda () (set! dbs (mdbm:*databases* #f))) + (lambda () + (define entry (mdbm:find-db? filename dbs)) + (cond (entry (slib:warn 'close ((car entry) 'filename) + 'before 'create-database) #f) + (else + (let ((pair (assq type *base-table-implementations*))) + (define ndb (and pair (((cadr pair) 'create-database) + filename))) + (if (and ndb dbs) + (set! dbs (cons (list ndb 1 type certificate) dbs))) + ndb)))) + (lambda () (and dbs (mdbm:return-dbs dbs))))))) + +;;@noindent +;;Only @code{alist-table} and base-table modules which have been +;;@code{require}d will dispatch correctly from the +;;@code{open-database} procedures. Therefore, either pass two +;;arguments to @code{open-database}, or require the base-table of your +;;database file uses before calling @code{open-database} with one +;;argument. + +;;@args rdb base-table-type +;;Returns @emph{mutable} open relational database or #f. +(define (open-database! filename . type) + (set! type (and (not (null? type)) (car type))) + (let ((dbs #f)) + (dynamic-wind + (lambda () (set! dbs (mdbm:*databases* #f))) + (lambda () + (cond ((and (procedure? filename) (not (filename 'delete-table))) + (slib:warn (filename 'filename) 'not 'mutable) #f) + ((mdbm:find-db? filename dbs) + (cond ((procedure? filename) filename) + (else (slib:warn filename 'already 'open) #f))) + (else (let ((entry (if type + (mdbm:open-type filename type #t) + (mdbm:try-opens filename #t)))) + (cond (entry (and dbs (set! dbs (cons entry dbs))) + (car entry)) + (else #f)))))) + (lambda () (and dbs (mdbm:return-dbs dbs)))))) + +;;@args rdb base-table-type +;;Returns an open relational database associated with @1. The +;;database will be opened with base-table type @2). +;; +;;@args rdb +;;Returns an open relational database associated with @1. +;;@0 will attempt to deduce the correct base-table-type. +(define (open-database rdb . type) + (set! type (and (not (null? type)) (car type))) + (let ((dbs #f)) + (dynamic-wind + (lambda () (set! dbs (mdbm:*databases* #f))) + (lambda () + (define entry (mdbm:find-db? rdb dbs)) + (and entry (set! rdb (car entry))) + (cond ((and entry type (not (eqv? (caddr entry) type))) + (slib:warn (rdb 'filename) 'type type '<> (caddr entry)) #f) + ((and (procedure? rdb) (rdb 'delete-table)) + (slib:warn (rdb 'filename) 'mutable) #f) + (entry (set-car! (cdr entry) (+ 1 (cadr entry))) rdb) + (else + (set! entry + (cond ((procedure? rdb) (list rdb 1 type #f)) + (type (mdbm:open-type rdb type #f)) + (else (mdbm:try-opens rdb #f)))) + (cond (entry (and dbs (set! dbs (cons entry dbs))) + (car entry)) + (else #f))))) + (lambda () (and dbs (mdbm:return-dbs dbs)))))) + +;;@body +;;Writes the mutable relational-database @1 to @2. +(define (write-database rdb filename) + (let ((dbs #f)) + (dynamic-wind + (lambda () (set! dbs (mdbm:*databases* #f))) + (lambda () + (define entry (mdbm:find-db? rdb dbs)) + (and entry (set! rdb (car entry))) + (cond ((and (not entry) (procedure? rdb)) + (set! entry (list rdb 1 #f (file-lock! filename))) + (and dbs (set! dbs (cons entry dbs))))) + (cond ((not entry) #f) + ((and (not (equal? filename (rdb 'filename))) + (mdbm:find-db? filename dbs)) + (slib:warn filename 'already 'open) #f) + (else (let ((dbwrite (rdb 'write-database))) + (and dbwrite (dbwrite filename)))))) + (lambda () (and dbs (mdbm:return-dbs dbs)))))) + +;;@args rdb +;;Writes the mutable relational-database @1 to the filename it was +;;opened with. +(define (sync-database rdb) + (let ((dbs #f)) + (dynamic-wind + (lambda () (set! dbs (mdbm:*databases* #f))) + (lambda () + (define entry (mdbm:find-db? rdb dbs)) + (and entry (set! rdb (car entry))) + (cond ((and (not entry) (procedure? rdb)) + (set! entry (list rdb 1 #f (file-lock! (rdb 'filename)))) + (and dbs (set! dbs (cons entry dbs))))) + (cond (entry (let ((db-op (rdb 'sync-database))) + (and db-op (db-op)))) + (else #f))) + (lambda () (and dbs (mdbm:return-dbs dbs)))))) + +;;@args rdb +;;Syncs @1 and makes it immutable. +(define (solidify-database rdb) ; + (let ((dbs #f)) + (dynamic-wind + (lambda () (set! dbs (mdbm:*databases* #f))) + (lambda () + (define entry (mdbm:find-db? rdb dbs)) + (define certificate #f) + (cond (entry (set! rdb (car entry)) + (set! certificate (cadddr entry))) + ((procedure? rdb) + (set! entry (list rdb 1 #f (file-lock! (rdb 'filename)))) + (and dbs (set! dbs (cons entry dbs))) + (set! certificate (cadddr entry)))) + (cond ((or (not certificate) (not (procedure? rdb))) #f) + (else + (let* ((filename (rdb 'filename)) + (dbsolid (rdb 'solidify-database)) + (ret (and dbsolid (dbsolid)))) + (if (file-unlock! filename certificate) + (set-car! (cdddr entry) #f) + (slib:warn 'file-unlock! filename certificate 'failed)) + ret)))) + (lambda () (and dbs (mdbm:return-dbs dbs)))))) + +;;@body +;;@1 will only be closed when the count of @code{open-database} - @0 +;;calls for @1 (and its filename) is 0. @0 returns #t if successful; +;;and #f otherwise. +(define (close-database rdb) + (let ((dbs #f)) + (dynamic-wind + (lambda () (set! dbs (mdbm:*databases* #f))) + (lambda () + (define entry (mdbm:find-db? rdb dbs)) + (define certificate #f) + (and entry (set! rdb (car entry))) + (and (procedure? rdb) + (set! certificate (or (and entry (cadddr entry)) + (and (rdb 'filename) + (file-lock! (rdb 'filename)))))) + (cond ((and entry (not (eqv? 1 (cadr entry)))) + (set-car! (cdr entry) (+ -1 (cadr entry))) + #f) + ((or (not certificate) (not (procedure? rdb))) + #f) + (else + (let* ((filename (rdb 'filename)) + (dbclose (rdb 'close-database)) + (ret (and dbclose (dbclose)))) + (if (not (file-unlock! filename certificate)) + (slib:warn 'file-unlock! filename certificate 'failed)) + (cond ((not dbclose) (slib:warn 'database? rdb)) + ((not entry)) + (dbs (set! dbs (mdbm:remove-entry dbs entry)))) + ret)))) + (lambda () (and dbs (mdbm:return-dbs dbs)))))) + +;;@body +;;Prints a table of open database files. The columns are the +;;base-table type, number of opens, @samp{!} for mutable, the +;;filename, and the lock certificate (if locked). +(define (mdbm:report) + (require 'printf) + (let ((dbs #f)) + (dynamic-wind + (lambda () (set! dbs (mdbm:*databases* #f))) + (lambda () + (cond (dbs (for-each (lambda (entry) + (printf "%15s %03d %1s %s %s\\n" + (or (caddr entry) "?") + (cadr entry) + (if ((car entry) 'delete-table) '! "") + (or ((car entry) 'filename) '-) + (or (cadddr entry) ""))) + dbs)) + (else (printf "%s lock broken.\\n" 'mdbm:*databases*)))) + (lambda () (and dbs (mdbm:return-dbs dbs)))))) +;;@example +;;(mdbm:report) +;;@print{} +;; alist-table 003 /usr/local/lib/slib/clrnamdb.scm +;; alist-table 001 ! sdram.db jaffer@@aubrey.jaffer.3166:1038628199 +;;@end example + + +;;@subsubheading Opening Tables + +;;@body +;;@1 must be a relational database and @2 a symbol. +;; +;;@0 returns a "methods" procedure for an existing relational table in +;;@1 if it exists and can be opened for reading, otherwise returns +;;@code{#f}. +(define (open-table rdb table-name) + ((rdb 'open-table) table-name #f)) + +;;@body +;;@1 must be a relational database and @2 a symbol. +;; +;;@0 returns a "methods" procedure for an existing relational table in +;;@1 if it exists and can be opened in mutable mode, otherwise returns +;;@code{#f}. +(define (open-table! rdb table-name) + ((rdb 'open-table) table-name #t)) + + +;;@subsubheading Defining Tables + +;;@body +;;Adds the domain rows @2 @dots{} to the @samp{*domains-data*} table +;;in @1. The format of the row is given in @ref{Catalog +;;Representation}. +;; +;;@example +;;(define-domains rdb '(permittivity #f complex? c64 #f)) +;;@end example +(define (define-domains rdb . row5) + (define add-domain (((rdb 'open-table) '*domains-data* #t) 'row:update)) + (for-each add-domain row5)) + +;;@body +;;Use @code{define-domains} instead. +(define (add-domain rdb row5) + ((((rdb 'open-table) '*domains-data* #t) 'row:update) + row5)) + +;;@args rdb spec-0 @dots{} +;;Adds tables as specified in @var{spec-0} @dots{} to the open +;;relational-database @1. Each @var{spec} has the form: +;; +;;@lisp +;;(@r{<name>} @r{<descriptor-name>} @r{<descriptor-name>} @r{<rows>}) +;;@end lisp +;;or +;;@lisp +;;(@r{<name>} @r{<primary-key-fields>} @r{<other-fields>} @r{<rows>}) +;;@end lisp +;; +;;where @r{<name>} is the table name, @r{<descriptor-name>} is the symbol +;;name of a descriptor table, @r{<primary-key-fields>} and +;;@r{<other-fields>} describe the primary keys and other fields +;;respectively, and @r{<rows>} is a list of data rows to be added to the +;;table. +;; +;;@r{<primary-key-fields>} and @r{<other-fields>} are lists of field +;;descriptors of the form: +;; +;;@lisp +;;(@r{<column-name>} @r{<domain>}) +;;@end lisp +;;or +;;@lisp +;;(@r{<column-name>} @r{<domain>} @r{<column-integrity-rule>}) +;;@end lisp +;; +;;where @r{<column-name>} is the column name, @r{<domain>} is the domain +;;of the column, and @r{<column-integrity-rule>} is an expression whose +;;value is a procedure of one argument (which returns @code{#f} to signal +;;an error). +;; +;;If @r{<domain>} is not a defined domain name and it matches the name of +;;this table or an already defined (in one of @var{spec-0} @dots{}) single +;;key field table, a foreign-key domain will be created for it. +(define (define-tables rdb . spec-list) (define new-tables '()) (define dom:typ (((rdb 'open-table) '*domains-data* #f) 'get 4)) (define create-table (rdb 'create-table)) @@ -245,26 +437,25 @@ (define (check-domain dname) (cond ((dom:typ dname)) ((member dname new-tables) - (let* ((ftab (open-table - (string->symbol - (string-append "desc:" (symbol->string dname))) - #f))) + (let ((ftab (open-table + (string->symbol + (string-append "desc:" (symbol->string dname))) + #f))) ((((rdb 'open-table) '*domains-data* #t) 'row:insert) (list dname dname #f (dom:typ ((ftab 'get 'domain-name) 1)) 1)))))) (define (define-table name prikeys slots data) (cond ((table-exists? name) - (let* ((tab (open-table name #t)) - (row:update (tab 'row:update))) - (for-each row:update data))) + (let ((tab (open-table name #t))) + ((tab 'row:update*) data) + ((tab 'close-table)))) ((and (symbol? prikeys) (eq? prikeys slots)) (cond ((not (table-exists? slots)) (slib:error "Table doesn't exist:" slots))) (set! new-tables (cons name new-tables)) - (let* ((tab (create-table name slots)) - (row:insert (tab 'row:insert))) - (for-each row:insert data) + (let ((tab (create-table name slots))) + ((tab 'row:insert*) data) ((tab 'close-table)))) (else (let* ((descname @@ -289,12 +480,22 @@ slots) ((tab 'close-table)) (set! tab (create-table name descname)) - (set! row:insert (tab 'row:insert)) - (for-each row:insert data) + ((tab 'row:insert*) data) ((tab 'close-table)))))) (for-each (lambda (spec) (apply define-table spec)) spec-list)) -(define (dbutil:list-table-definition rdb table-name) + +;;@subsubheading Listing Tables + +;;@body +;;If symbol @2 exists in the open relational-database +;;@1, then returns a list of the table-name, its primary key names +;;and domains, its other key names and domains, and the table's records +;;(as lists). Otherwise, returns #f. +;; +;;The list returned by @0, when passed as an +;;argument to @code{define-tables}, will recreate the table. +(define (list-table-definition rdb table-name) (cond (((rdb 'table-exists?) table-name) (let* ((table ((rdb 'open-table) table-name #f)) (prilimit (table 'primary-limit)) @@ -306,9 +507,4 @@ (nthcdr prilimit coldefs) ((table 'row:retrieve*))))) (else #f))) - -(define create-database dbutil:create-database) -(define open-database! dbutil:open-database!) -(define open-database dbutil:open-database) -(define define-tables dbutil:define-tables) -(define list-table-definition dbutil:list-table-definition) +;;(trace-all "/home/jaffer/slib/dbutil.scm") (untrace define-tables) diff --git a/dbutil.txi b/dbutil.txi new file mode 100644 index 0000000..cc198f3 --- /dev/null +++ b/dbutil.txi @@ -0,0 +1,219 @@ +@code{(require 'databases)} +@ftindex databases + +@noindent +This enhancement wraps a utility layer on @code{relational-database} +which provides: + +@itemize @bullet +@item +Identification of open databases by filename. +@item +Automatic sharing of open (immutable) databases. +@item +Automatic loading of base-table package when creating a database. +@item +Detection and automatic loading of the appropriate base-table package +when opening a database. +@item +Table and data definition from Scheme lists. +@end itemize + +@subsubheading Database Sharing + +@noindent +@dfn{Auto-sharing} refers to a call to the procedure +@cindex Auto-sharing +@code{open-database} returning an already open database (procedure), +rather than opening the database file a second time. + +@quotation +@emph{Note:} Databases returned by @code{open-database} do not include +wrappers applied by packages like @ref{Embedded Commands}. But +wrapped databases do work as arguments to these functions. +@end quotation + +@noindent +When a database is created, it is mutable by the creator and not +auto-sharable. A database opened mutably is also not auto-sharable. +But any number of readers can (open) share a non-mutable database file. + +@noindent +This next set of procedures mirror the whole-database methods in +@ref{Database Operations}. Except for @code{create-database}, each +procedure will accept either a filename or database procedure for its +first argument. + + +@defun create-database filename base-table-type + +@var{filename} should be a string naming a file; or @code{#f}. @var{base-table-type} must be a +symbol naming a feature which can be passed to @code{require}. @code{create-database} +returns a new, open relational database (with base-table type @var{base-table-type}) +associated with @var{filename}, or a new ephemeral database if @var{filename} is @code{#f}. + +@code{create-database} is the only run-time use of require in SLIB +which crosses module boundaries. When @var{base-table-type} is @code{require}d by @code{create-database}; it +adds an association of @var{base-table-type} with its @dfn{relational-system} procedure +@cindex relational-system +to @var{mdbm:*databases*}. + +alist-table is the default base-table type: + +@example +(require 'databases) +(define my-rdb (create-database "my.db" 'alist-table)) +@end example +@end defun +@noindent +Only @code{alist-table} and base-table modules which have been +@code{require}d will dispatch correctly from the +@code{open-database} procedures. Therefore, either pass two +arguments to @code{open-database}, or require the base-table of your +database file uses before calling @code{open-database} with one +argument. + + +@deffn {Procedure} open-database! rdb base-table-type + +Returns @emph{mutable} open relational database or #f. +@end deffn + +@defun open-database rdb base-table-type + +Returns an open relational database associated with @var{rdb}. The +database will be opened with base-table type @var{base-table-type}). + + +@defunx open-database rdb +Returns an open relational database associated with @var{rdb}. +@code{open-database} will attempt to deduce the correct base-table-type. +@end defun + +@defun write-database rdb filename + +Writes the mutable relational-database @var{rdb} to @var{filename}. +@end defun + +@defun sync-database rdb + +Writes the mutable relational-database @var{rdb} to the filename it was +opened with. +@end defun + +@defun solidify-database rdb + +Syncs @var{rdb} and makes it immutable. +@end defun + +@defun close-database rdb + +@var{rdb} will only be closed when the count of @code{open-database} - @code{close-database} +calls for @var{rdb} (and its filename) is 0. @code{close-database} returns #t if successful; +and #f otherwise. +@end defun + +@defun mdbm:report + +Prints a table of open database files. The columns are the +base-table type, number of opens, @samp{!} for mutable, the +filename, and the lock certificate (if locked). +@end defun +@example +(mdbm:report) +@print{} + alist-table 003 /usr/local/lib/slib/clrnamdb.scm + alist-table 001 ! sdram.db jaffer@@aubrey.jaffer.3166:1038628199 +@end example + +@subsubheading Opening Tables + + +@defun open-table rdb table-name + +@var{rdb} must be a relational database and @var{table-name} a symbol. + +@code{open-table} returns a "methods" procedure for an existing relational table in +@var{rdb} if it exists and can be opened for reading, otherwise returns +@code{#f}. +@end defun + +@deffn {Procedure} open-table! rdb table-name + +@var{rdb} must be a relational database and @var{table-name} a symbol. + +@code{open-table!} returns a "methods" procedure for an existing relational table in +@var{rdb} if it exists and can be opened in mutable mode, otherwise returns +@code{#f}. +@end deffn +@subsubheading Defining Tables + + +@defun define-domains rdb row5 @dots{} + +Adds the domain rows @var{row5} @dots{} to the @samp{*domains-data*} table +in @var{rdb}. The format of the row is given in @ref{Catalog +Representation}. + +@example +(define-domains rdb '(permittivity #f complex? c64 #f)) +@end example +@end defun + +@defun add-domain rdb row5 + +Use @code{define-domains} instead. +@end defun + +@defun define-tables rdb spec-0 @dots{} + +Adds tables as specified in @var{spec-0} @dots{} to the open +relational-database @var{rdb}. Each @var{spec} has the form: + +@lisp +(@r{<name>} @r{<descriptor-name>} @r{<descriptor-name>} @r{<rows>}) +@end lisp +or +@lisp +(@r{<name>} @r{<primary-key-fields>} @r{<other-fields>} @r{<rows>}) +@end lisp + +where @r{<name>} is the table name, @r{<descriptor-name>} is the symbol +name of a descriptor table, @r{<primary-key-fields>} and +@r{<other-fields>} describe the primary keys and other fields +respectively, and @r{<rows>} is a list of data rows to be added to the +table. + +@r{<primary-key-fields>} and @r{<other-fields>} are lists of field +descriptors of the form: + +@lisp +(@r{<column-name>} @r{<domain>}) +@end lisp +or +@lisp +(@r{<column-name>} @r{<domain>} @r{<column-integrity-rule>}) +@end lisp + +where @r{<column-name>} is the column name, @r{<domain>} is the domain +of the column, and @r{<column-integrity-rule>} is an expression whose +value is a procedure of one argument (which returns @code{#f} to signal +an error). + +If @r{<domain>} is not a defined domain name and it matches the name of +this table or an already defined (in one of @var{spec-0} @dots{}) single +key field table, a foreign-key domain will be created for it. +@end defun +@subsubheading Listing Tables + + +@defun list-table-definition rdb table-name + +If symbol @var{table-name} exists in the open relational-database +@var{rdb}, then returns a list of the table-name, its primary key names +and domains, its other key names and domains, and the table's records +(as lists). Otherwise, returns #f. + +The list returned by @code{list-table-definition}, when passed as an +argument to @code{define-tables}, will recreate the table. +@end defun 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 @@ -8,7 +8,7 @@ ;1. Any copy made of this software must include this copyright notice ;in full. ; -;2. I have made no warrantee or representation that the operation of +;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; @@ -62,7 +62,7 @@ (let ((sym (get-defined-symbol (cadr form)))) (cond ((procedure? (slib:eval sym)) (proc sym))))))))) - +;@ (define (trace-all file . ...) (for-each (lambda (file) @@ -87,7 +87,7 @@ (lambda (sym) (slib:eval `(set! ,sym (trace:trace-procedure 'stack ,sym ',sym)))))) (cons file ...))) - +;@ (define (break-all file . ...) (for-each (lambda (file) diff --git a/defmacex.scm b/defmacex.scm index 5863c94..71d7b6c 100644 --- a/defmacex.scm +++ b/defmacex.scm @@ -8,7 +8,7 @@ ;1. Any copy made of this software must include this copyright notice ;in full. ; -;2. I have made no warrantee or representation that the operation of +;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; @@ -38,7 +38,7 @@ (else (map1 (lambda (e) (iqq e depth)) e))) e)))) (iqq e depth))) - +;@ (define (defmacro:expand* e) (if (pair? e) (let* ((c (macroexpand-1 e))) @@ -1,14 +1,147 @@ -;"determ.scm" Determinant +;;; "determ.scm" Matrix Algebra +;Copyright 2002 Aubrey Jaffer +; +;Permission to copy this software, to modify it, to redistribute it, +;to distribute modified versions, and to use it for any purpose is +;granted, subject to the following restrictions and understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warranty or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. -(define (determinant m) +(require 'array) + +;;@code{(require 'determinant)} +;;@ftindex determinant + +;;@noindent +;;A Matrix can be either a list of lists (rows) or an array. +;;As with linear-algebra texts, this package uses 1-based coordinates. + +;;; Internal conversion routines +(define (matrix2array matrix prototype) + (let* ((shp (list (list 1 (length matrix)) + (list 1 (length (car matrix))))) + (mat (apply create-array '#() shp))) + (do ((idx 1 (+ 1 idx)) + (rows matrix (cdr rows))) + ((> idx (cadar shp)) rows) + (do ((jdx 1 (+ 1 jdx)) + (row (car rows) (cdr row))) + ((> jdx (cadadr shp))) + (array-set! mat (car row) idx jdx))) + mat)) +(define (matrix2lists matrix) + (let ((shp (array-shape matrix))) + (do ((idx (cadar shp) (+ -1 idx)) + (rows '() + (cons (do ((jdx (cadadr shp) (+ -1 jdx)) + (row '() (cons (array-ref matrix idx jdx) row))) + ((< jdx (caadr shp)) row)) + rows))) + ((< idx (caar shp)) rows)))) +(define (coerce-like-arg matrix arg) + (cond ((array? arg) (matrix2array matrix arg)) + (else matrix))) + +;;@body +;;Returns the list-of-lists form of @1. +(define (matrix->lists matrix) + (cond ((array? matrix) + (if (not (eqv? 2 (array-rank matrix))) + (slib:error 'not 'matrix matrix)) + (matrix2lists matrix)) + ((and (pair? matrix) (list? (car matrix))) matrix) + ((vector? matrix) (list (vector->list matrix))) + (else (slib:error 'not 'matrix matrix)))) + +;;@body +;;Returns the (ones-based) array form of @1. +(define (matrix->array matrix) + (cond ((array? matrix) + (if (not (eqv? 2 (array-rank matrix))) + (slib:error 'not 'matrix matrix)) + matrix) + ((and (pair? matrix) (list? (car matrix))) + (matrix2array matrix '#())) + ((vector? matrix) matrix) + (else (slib:error 'not 'matrix matrix)))) + +(define (matrix:cofactor matrix i j) + (define mat (matrix->lists matrix)) (define (butnth n lst) - (if (zero? n) (cdr lst) (cons (car lst) (butnth (+ -1 n) (cdr lst))))) - (define (minor m i j) - (map (lambda (x) (butnth j x)) (butnth i m))) - (define (cofactor m i j) - (* (if (odd? (+ i j)) -1 1) (determinant (minor m i j)))) - (define n (length m)) - (if (eqv? 1 n) (caar m) - (do ((j (+ -1 n) (+ -1 j)) - (ans 0 (+ ans (* (list-ref (car m) j) (cofactor m 0 j))))) - ((negative? j) ans)))) + (if (<= n 1) (cdr lst) (cons (car lst) (butnth (+ -1 n) (cdr lst))))) + (define (minor matrix i j) + (map (lambda (x) (butnth j x)) (butnth i mat))) + (coerce-like-arg + (* (if (odd? (+ i j)) -1 1) (determinant (minor mat i j))) + matrix)) + +;;@body +;;@1 must be a square matrix. +;;@0 returns the determinant of @1. +;; +;;@example +;;(require 'determinant) +;;(determinant '((1 2) (3 4))) @result{} -2 +;;(determinant '((1 2 3) (4 5 6) (7 8 9))) @result{} 0 +;;@end example +(define (determinant matrix) + (define mat (matrix->lists matrix)) + (let ((n (length mat))) + (if (eqv? 1 n) (caar mat) + (do ((j n (+ -1 j)) + (ans 0 (+ ans (* (list-ref (car mat) (+ -1 j)) + (matrix:cofactor mat 1 j))))) + ((<= j 0) ans))))) + +;;@body +;;Returns a copy of @1 flipped over the diagonal containing the 1,1 +;;element. +(define (transpose matrix) + (if (number? matrix) + matrix + (let ((mat (matrix->lists matrix))) + (coerce-like-arg (apply map list mat) + matrix)))) + +;;@body +;;Returns the product of matrices @1 and @2. +(define (matrix:product m1 m2) + (define mat1 (matrix->lists m1)) + (define mat2 (matrix->lists m2)) + (define (dot-product v1 v2) (apply + (map * v1 v2))) + (coerce-like-arg + (map (lambda (arow) + (apply map + (lambda bcol (dot-product bcol arow)) + mat2)) + mat1) + m1)) + +;;@body +;;@1 must be a square matrix. +;;If @1 is singlar, then @0 returns #f; otherwise @0 returns the +;;@code{matrix:product} inverse of @1. +(define (matrix:inverse matrix) + (let* ((mat (matrix->lists matrix)) + (det (determinant mat)) + (rank (length mat))) + (and (not (zero? det)) + (do ((i rank (+ -1 i)) + (inv '() (cons + (do ((j rank (+ -1 j)) + (row '() + (cons (/ (matrix:cofactor mat j i) det) row))) + ((<= j 0) row)) + inv))) + ((<= i 0) + (coerce-like-arg inv matrix)))))) diff --git a/determ.txi b/determ.txi new file mode 100644 index 0000000..30eef3d --- /dev/null +++ b/determ.txi @@ -0,0 +1,47 @@ +@code{(require 'determinant)} +@ftindex determinant + +@noindent +A Matrix can be either a list of lists (rows) or an array. +As with linear-algebra texts, this package uses 1-based coordinates. + + +@defun matrix->lists matrix + +Returns the list-of-lists form of @var{matrix}. +@end defun + +@defun matrix->array matrix + +Returns the (ones-based) array form of @var{matrix}. +@end defun + +@defun determinant matrix + +@var{matrix} must be a square matrix. +@code{determinant} returns the determinant of @var{matrix}. + +@example +(require 'determinant) +(determinant '((1 2) (3 4))) @result{} -2 +(determinant '((1 2 3) (4 5 6) (7 8 9))) @result{} 0 +@end example +@end defun + +@defun transpose matrix + +Returns a copy of @var{matrix} flipped over the diagonal containing the 1,1 +element. +@end defun + +@defun matrix:product m1 m2 + +Returns the product of matrices @var{m1} and @var{m2}. +@end defun + +@defun matrix:inverse matrix + +@var{matrix} must be a square matrix. +If @var{matrix} is singlar, then @code{matrix:inverse} returns #f; otherwise @code{matrix:inverse} returns the +@code{matrix:product} inverse of @var{matrix}. +@end defun @@ -1,5 +1,5 @@ ;;;; "differ.scm" O(NP) Sequence Comparison Algorithm. -;;; Copyright (C) 2001 Aubrey Jaffer +;;; Copyright (C) 2001, 2002, 2003 Aubrey Jaffer ; ;Permission to copy this software, to modify it, to redistribute it, ;to distribute modified versions, and to use it for any purpose is @@ -8,7 +8,7 @@ ;1. Any copy made of this software must include this copyright notice ;in full. ; -;2. I have made no warrantee or representation that the operation of +;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; @@ -18,7 +18,7 @@ ;each case. ;;@noindent -;;This package implements the algorithm: +;;@code{diff:edit-length} implements the algorithm: ;; ;;@ifinfo ;;@example @@ -37,186 +37,403 @@ ;;@end ifset ;; ;;@noindent -;;If the items being sequenced are text lines, then the computed -;;edit-list is equivalent to the output of the @dfn{diff} utility -;;program. If the items being sequenced are words, then it is like the -;;lesser known @dfn{spiff} program. -;; -;;@noindent ;;The values returned by @code{diff:edit-length} can be used to gauge ;;the degree of match between two sequences. ;; ;;@noindent -;;I believe that this algorithm is currently the fastest for these -;;tasks, but genome sequencing applications fuel extensive research in -;;this area. +;;Surprisingly, "An O(NP) Sequence Comparison Algorithm" does not +;;derive the edit sequence; only the sequence length. Developing this +;;linear-space sub-quadratic-time algorithm for computing the edit +;;sequence required hundreds of hours of work. I have submitted a +;;paper describing the algorithm to the Journal of Computational +;;Biology. +;; +;;@noindent +;;If the items being sequenced are text lines, then the computed +;;edit-list is equivalent to the output of the @dfn{diff} utility +;;program. If the items being sequenced are words, then it is like the +;;lesser known @dfn{spiff} program. (require 'array) +(require 'sort) -(define (fp:compare fp Delta snake len2) +;;; p-lim is half the number of gratuitous edits for strings of given +;;; lengths. +;;; When passed #f CC, fp:compare returns edit-distance if successful; +;;; #f otherwise (p > p-lim). When passed CC, fp:compare returns #f. +(define (fp:compare fp CC A M B N =? p-lim) + (define Delta (- N M)) + ;;(if (negative? Delta) (slib:error 'fp:compare (fp:subarray A 0 M) '> (fp:subarray B 0 N))) + ;;(set! compares (+ 1 compares)) ;(print 'fp:compare M N p-lim) (let loop ((p 0)) (do ((k (- p) (+ 1 k))) - ((> k (+ -1 Delta))) - (array-set! fp (snake k (max (+ 1 (array-ref fp (+ -1 k))) - (array-ref fp (+ 1 k)))) - k)) + ((>= k Delta)) + (fp:run fp k A M B N =? CC p)) (do ((k (+ Delta p) (+ -1 k))) - ((< k (+ 1 Delta))) - (array-set! fp (snake k (max (+ 1 (array-ref fp (+ -1 k))) - (array-ref fp (+ 1 k)))) - k)) - (array-set! fp (snake Delta (max (+ 1 (array-ref fp (+ -1 Delta))) - (array-ref fp (+ 1 Delta)))) - Delta) - (if (= (array-ref fp Delta) len2) - (+ Delta (* 2 p)) - (loop (+ 1 p))))) - -(define (fp->edits fp Delta) - (let loop ((idx (+ -1 Delta)) - (ddx (+ 1 Delta)) - (edits '())) - (define ivl (array-ref fp idx)) - (define dvl (array-ref fp ddx)) - (if (not (= -1 dvl)) (set! dvl (- dvl ddx))) - ;;(print idx '-> ivl ddx '-> dvl) - (cond ((= ivl -1) edits) - ((= dvl -1) (loop (+ -1 idx) ddx (cons (list ivl 'insert) edits))) - ((> dvl ivl) (loop idx (+ 1 ddx) (cons (list dvl 'delete) edits))) - (else (loop (+ -1 idx) ddx (cons (list ivl 'insert) edits)))))) - -(define (fp->lcs fp Delta array1 len) - (define len1 (car (array-dimensions array1))) - (define lcs (make-array #f len)) - (define (subarray-copy! array1 start1 end1 array2 start2) - (do ((i start1 (+ i 1)) - (j start2 (+ j 1)) - (l (- end1 start1) (- l 1))) - ((<= l 0)) - (array-set! array2 (array-ref array1 i) j))) - (let loop ((ddx (+ 1 Delta)) - (pos len1) - (dpos len)) - (let* ((dvl (array-ref fp ddx)) - (sublen (- pos (- dvl ddx -1)))) - (cond ((= dvl -1) - (subarray-copy! array1 0 pos lcs 0) - lcs) + ((<= k Delta)) + (fp:run fp k A M B N =? CC p)) + (let ((fpval (fp:run fp Delta A M B N =? CC p))) + ;; At this point, the cost to (fpval-Delta, fpval) is Delta + 2*p + (cond ((and (not CC) (<= N fpval)) (+ Delta (* 2 p))) + ((and (not (negative? p-lim)) (>= p p-lim)) #f) + (else (loop (+ 1 p))))))) + +;;; Traces runs of matches until they end; then set fp[k]=y. +;;; If CC is supplied, set each CC[y] = min(CC[y], cost) for run. +;;; Returns furthest y reached. +(define (fp:run fp k A M B N =? CC p) + (define y (max (+ 1 (array-ref fp (+ -1 k))) (array-ref fp (+ 1 k)))) + (define cost (+ k p p)) + (let snloop ((x (- y k)) + (y y)) + (and CC (<= y N) + (let ((xcst (- M x))) + (cond ((negative? xcst)) + (else (array-set! CC + (min (+ xcst cost) (array-ref CC y)) + y))))) + ;;(set! tick (+ 1 tick)) + (cond ((and (< x M) (< y N) + (=? (array-ref A x) (array-ref B y))) + (snloop (+ 1 x) (+ 1 y))) + (else (array-set! fp y k) + y)))) + +;;; Check that only 1 and -1 steps between adjacent CC entries. +;;(define (fp:step-check A M B N CC) +;; (do ((cdx (+ -1 N) (+ -1 cdx))) +;; ((negative? cdx)) +;; (case (- (array-ref CC cdx) (array-ref CC (+ 1 cdx))) +;; ((1 -1) #t) +;; (else (cond ((> 30 (car (array-dimensions CC))) +;; (display "A: ") (print A) +;; (display "B: ") (print B))) +;; (slib:warn +;; "CC" (append (list (max 0 (+ -5 cdx)) ': (min (+ 1 N) (+ 5 cdx)) +;; 'of) +;; (array-dimensions CC)) +;; (fp:subarray CC (max 0 (+ -5 cdx)) (min (+ 1 N) (+ 5 cdx)))))))) + +;;; Correct cost jumps left by fp:compare [which visits only a few (x,y)]. +;;(define (smooth-costs CC N) +;; (do ((cdx (+ -1 N) (+ -1 cdx))) ; smooth from end +;; ((negative? cdx)) +;; (array-set! CC (min (array-ref CC cdx) (+ 1 (array-ref CC (+ 1 cdx)))) +;; cdx)) +;; (do ((cdx 1 (+ 1 cdx))) ; smooth toward end +;; ((> cdx N)) +;; (array-set! CC (min (array-ref CC cdx) (+ 1 (array-ref CC (+ -1 cdx)))) +;; cdx)) +;; CC) + +(define (diff:mid-split M N RR CC cost) + (define b-splt N) ;Default + (define bestrun 0) + (define thisrun 0) + ;; RR is not longer than CC. So do for each element of RR. + (let loop ((cdx (+ 1 (quotient N 2))) + (rdx (quotient N 2))) + ;;(if (negative? rdx) (slib:error 'negative? 'rdx)) + (cond ((eqv? cost (+ (array-ref CC rdx) (array-ref RR (- N rdx)))) rdx) + ((eqv? cost (+ (array-ref CC cdx) (array-ref RR (- N cdx)))) cdx) + (else (loop (+ 1 cdx) (+ -1 rdx)))))) + +;;; Return 0-based shared array. +;;; Reverse RA if END < START. +(define (fp:subarray RA start end) + (define n-len (abs (- end start))) + (if (< end start) + (make-shared-array RA (lambda (idx) (list (- start 1 idx))) n-len) + (make-shared-array RA (lambda (idx) (list (+ start idx))) n-len))) + +(define (fp:init! fp fill mindx maxdx) + (do ((idx maxdx (+ -1 idx))) + ((< idx mindx)) + (array-set! fp fill idx))) + +;;; Split A[start-a..end-a] (shorter array) into smaller and smaller chunks. +;;; EDX is index into EDITS. +;;; EPO is insert/delete polarity (+1 or -1) +(define (diff:divide-and-conquer fp CCRR A start-a end-a B start-b end-b edits edx epo =? p-lim) + (define mid-a (quotient (+ start-a end-a) 2)) + (define len-b (- end-b start-b)) + (define len-a (- end-a start-a)) + (let ((tcst (+ p-lim p-lim (- len-b len-a)))) + (define CC (fp:subarray CCRR 0 (+ len-b 1))) + (define RR (fp:subarray CCRR (+ len-b 1) (* 2 (+ len-b 1)))) + (define M2 (- end-a mid-a)) + (define M1 (- mid-a start-a)) + (fp:init! CC (+ len-a len-b) 0 len-b) + (fp:init! fp -1 (- (+ 1 p-lim)) (+ 1 p-lim (- len-b M1))) + (fp:compare fp CC + (fp:subarray A start-a mid-a) M1 + (fp:subarray B start-b end-b) len-b =? (min p-lim len-a)) + (fp:init! RR (+ len-a len-b) 0 len-b) + (fp:init! fp -1 (- (+ 1 p-lim)) (+ 1 p-lim (- len-b M2))) + (fp:compare fp RR + (fp:subarray A end-a mid-a) M2 + (fp:subarray B end-b start-b) len-b =? (min p-lim len-a)) + ;;(smooth-costs CC len-b) (smooth-costs RR len-b) + (let ((b-splt (diff:mid-split len-a len-b RR CC tcst))) + (define est-c (array-ref CC b-splt)) + (define est-r (array-ref RR (- len-b b-splt))) + ;;(set! splts (cons (/ b-splt (max .1 len-b)) splts)) + ;;(display "A: ") (array-for-each display (fp:subarray A start-a mid-a)) (display " + ") (array-for-each display (fp:subarray A mid-a end-a)) (newline) + ;;(display "B: ") (array-for-each display (fp:subarray B start-b end-b)) (newline) + ;;(print 'cc cc) (print 'rr (fp:subarray RR (+ 1 len-b) 0)) + ;;(print (make-string (+ 7 (* 2 b-splt)) #\-) '^ (list b-splt)) + (check-cost! 'CC est-c + (diff2et fp CCRR + A start-a mid-a + B start-b (+ start-b b-splt) + edits edx epo =? + (quotient (- est-c (- b-splt (- mid-a start-a))) + 2))) + (check-cost! 'RR est-r + (diff2et fp CCRR + A mid-a end-a + B (+ start-b b-splt) end-b + edits (+ est-c edx) epo =? + (quotient (- est-r (- (- len-b b-splt) + (- end-a mid-a))) + 2))) + (+ est-c est-r)))) + +;;; Trim; then diff sub-arrays; either one longer. Returns edit-length +(define (diff2et fp CCRR A start-a end-a B start-b end-b edits edx epo =? p-lim) + ;; (if (< (- end-a start-a) p-lim) (slib:warn 'diff2et 'len-a (- end-a start-a) 'len-b (- end-b start-b) 'p-lim p-lim)) + (do ((bdx (+ -1 end-b) (+ -1 bdx)) + (adx (+ -1 end-a) (+ -1 adx))) + ((not (and (<= start-b bdx) + (<= start-a adx) + (=? (array-ref A adx) (array-ref B bdx)))) + (do ((bsx start-b (+ 1 bsx)) + (asx start-a (+ 1 asx))) + ((not (and (< bsx bdx) + (< asx adx) + (=? (array-ref A asx) (array-ref B bsx)))) + ;;(print 'trim-et (- asx start-a) '+ (- end-a adx)) + (let ((delta (- (- bdx bsx) (- adx asx)))) + (if (negative? delta) + (diff2ez fp CCRR B bsx (+ 1 bdx) A asx (+ 1 adx) + edits edx (- epo) =? (+ delta p-lim)) + (diff2ez fp CCRR A asx (+ 1 adx) B bsx (+ 1 bdx) + edits edx epo =? p-lim)))) + ;;(set! tick (+ 1 tick)) + )) + ;;(set! tick (+ 1 tick)) + )) + +;;; Diff sub-arrays, A not longer than B. Returns edit-length +(define (diff2ez fp CCRR A start-a end-a B start-b end-b edits edx epo =? p-lim) + (define len-a (- end-a start-a)) + (define len-b (- end-b start-b)) + ;;(if (> len-a len-b) (slib:error 'diff2ez len-a '> len-b)) + (cond ((zero? p-lim) ; B inserts only + (if (= len-b len-a) + 0 ; A = B; no edits + (let loop ((adx start-a) + (bdx start-b) + (edx edx)) + (cond ((>= bdx end-b) (- len-b len-a)) + ((>= adx end-a) + (do ((idx bdx (+ 1 idx)) + (edx edx (+ 1 edx))) + ((>= idx end-b) (- len-b len-a)) + (array-set! edits (* epo (+ 1 idx)) edx))) + ((=? (array-ref A adx) (array-ref B bdx)) + ;;(set! tick (+ 1 tick)) + (loop (+ 1 adx) (+ 1 bdx) edx)) + (else (array-set! edits (* epo (+ 1 bdx)) edx) + ;;(set! tick (+ 1 tick)) + (loop adx (+ 1 bdx) (+ 1 edx))))))) + ((<= len-a p-lim) ; delete all A; insert all B + ;;(if (< len-a p-lim) (slib:error 'diff2ez len-a len-b 'p-lim p-lim)) + (do ((idx start-a (+ 1 idx)) + (edx edx (+ 1 edx))) + ((>= idx end-a) + (do ((jdx start-b (+ 1 jdx)) + (edx edx (+ 1 edx))) + ((>= jdx end-b)) + (array-set! edits (* epo (+ 1 jdx)) edx))) + (array-set! edits (* epo (- -1 idx)) edx)) + (+ len-a len-b)) + (else (diff:divide-and-conquer + fp CCRR A start-a end-a B start-b end-b + edits edx epo =? p-lim)))) + +;;;Return new vector of edits in correct sequence +(define (diff:order-edits edits cost sign) + (if (negative? sign) + (do ((idx (+ -1 cost) (+ -1 idx))) + ((negative? idx)) + (array-set! edits (- (array-ref edits idx)) idx))) + (if (zero? cost) + edits + (let ((sedits (sort! edits <)) + (nedits (create-array (As32) cost))) + ;; Find -/+ boundary + (define len-a (max 0 (- (array-ref sedits 0)))) + (define len-b (array-ref sedits (+ -1 cost))) + (do ((idx 0 (+ 1 idx))) + ((or (>= idx cost) (positive? (array-ref sedits idx))) + (let loop ((ddx (+ -1 idx)) + (idx idx) + (ndx 0) + (adx 0) + (bdx 0)) + (define del (if (negative? ddx) 0 (array-ref sedits ddx))) + (define ins (if (>= idx cost) 0 (array-ref sedits idx))) + (cond ((and (>= bdx len-b) (>= adx len-a)) nedits) + ((and (negative? del) (>= adx (- -1 del)) + (positive? ins) (>= bdx (+ -1 ins))) + (array-set! nedits del ndx) + (array-set! nedits ins (+ 1 ndx)) + (loop (+ -1 ddx) (+ 1 idx) (+ 2 ndx) + (+ 1 adx) (+ 1 bdx))) + ((and (negative? del) (>= adx (- -1 del))) + (array-set! nedits del ndx) + (loop (+ -1 ddx) idx (+ 1 ndx) (+ 1 adx) bdx)) + ((and (positive? ins) (>= bdx (+ -1 ins))) + (array-set! nedits ins ndx) + (loop ddx (+ 1 idx) (+ 1 ndx) adx (+ 1 bdx))) + (else + (loop ddx idx ndx (+ 1 adx) (+ 1 bdx)))))))))) + +;;; len-a < len-b +(define (edits2lcs lcs edits cost A len-a len-b) + (let loop ((edx 0) + (sdx 0) + (adx 0)) + (let ((edit (if (< edx cost) + (array-ref edits edx) + 0))) + (cond ((>= adx len-a) lcs) + ((positive? edit) + (loop (+ 1 edx) sdx adx)) + ((zero? edit) + (array-set! lcs (array-ref A adx) sdx) + (loop edx (+ 1 sdx) (+ 1 adx))) + ((>= adx (- -1 edit)) + (loop (+ 1 edx) sdx (+ 1 adx))) (else - (subarray-copy! array1 (- dvl ddx -1) pos lcs (- dpos sublen)) - (loop (+ 1 ddx) (- dvl ddx) (- dpos sublen))))))) + (array-set! lcs (array-ref A adx) sdx) + (loop edx (+ 1 sdx) (+ 1 adx))))))) + +;; A not longer than B (M <= N) +(define (diff2edits A M B N =? p-lim) + (define maxdx (if (negative? p-lim) (+ 2 N) (+ 1 p-lim (- N M)))) + (define mindx (if (negative? p-lim) (- (+ 1 M)) (- (+ 1 p-lim)))) + ;;(if (> M N) (slib:error 'diff2edits M '> N)) + (let ((fp (create-array (As32) (list mindx maxdx))) + (CCRR (create-array (As32) (* 2 (+ N 1))))) + (fp:init! fp -1 mindx maxdx) + (let ((est (fp:compare fp #f A M B N =? p-lim))) + (and est + (let ((edits (create-array (As32) est))) + (check-cost! 'diff2edits + est + (diff2et fp CCRR A 0 M B 0 N edits 0 1 =? + (quotient (- est (- N M)) 2))) + edits))))) +;; A not longer than B (M <= N) +(define (diff2editlen A M B N =? p-lim) + (define maxdx (if (negative? p-lim) (+ 1 N) (+ 1 p-lim (- N M)))) + (define mindx (if (negative? p-lim) (- (+ 1 M)) (- (+ 1 p-lim)))) + (let ((fp (create-array (As32) (list mindx maxdx)))) + (fp:init! fp -1 mindx maxdx) + (fp:compare fp #f A M B N =? p-lim))) + +(define (check-cost! name est cost) + (if (not (eqv? est cost)) + (slib:warn "%s: cost check failed %d != %d\\n" name est cost))) + +;;@args array1 array2 =? p-lim ;;@args array1 array2 =? -;;@args array1 array2 ;;@1 and @2 are one-dimensional arrays. The procedure @3 is used -;;to compare sequence tokens for equality. @3 defaults to @code{eqv?}. +;;to compare sequence tokens for equality. +;; +;;The non-negative integer @4, if provided, is maximum number of +;;deletions of the shorter sequence to allow. @0 will return @code{#f} +;;if more deletions would be necessary. +;; ;;@0 returns a one-dimensional array of length @code{(quotient (- (+ -;;len1 len2) (fp:edit-length @1 @2)) 2)} holding the longest sequence +;;len1 len2) (diff:edit-length @1 @2)) 2)} holding the longest sequence ;;common to both @var{array}s. -(define (diff:longest-common-subsequence array1 array2 . =?) - (define len1 (car (array-dimensions array1))) - (define len2 (car (array-dimensions array2))) - (define (snake k y) - (let snloop ((x (- y k)) - (y y)) - (if (and (< x len1) (< y len2) (=? (array-ref array1 x) - (array-ref array2 y))) - (snloop (+ 1 x) (+ 1 y)) - y))) - (set! =? (if (null? =?) eqv? (car =?))) - (if (> len1 len2) - (diff:longest-common-subsequence array2 array1) - (let ((Delta (- len2 len1)) - (fp (make-array -1 (list (- (+ 1 len1)) (+ 1 len2))))) - (fp->lcs fp Delta array1 - (quotient (- (+ len1 len2) (fp:compare fp Delta snake len2)) - 2))))) +(define (diff:longest-common-subsequence A B =? . p-lim) + (define len-a (car (array-dimensions a))) + (define len-b (car (array-dimensions b))) + (set! p-lim (if (null? p-lim) -1 (car p-lim))) + (let ((edits (if (< len-b len-a) + (diff2edits B len-b A len-a =? p-lim) + (diff2edits A len-a B len-b =? p-lim)))) + (and edits + (let* ((cost (car (array-dimensions edits))) + (sedit (diff:order-edits edits cost (if (< len-b len-a) -1 1))) + (lcs (create-array A (/ (- (+ len-b len-a) cost) 2)))) + (if (< len-b len-a) + (edits2lcs lcs sedit cost B len-b len-a) + (edits2lcs lcs sedit cost A len-a len-b)))))) +;;@args array1 array2 =? p-lim ;;@args array1 array2 =? -;;@args array1 array2 ;;@1 and @2 are one-dimensional arrays. The procedure @3 is used -;;to compare sequence tokens for equality. @3 defaults to @code{eqv?}. -;;@0 returns a list of length @code{(fp:edit-length @1 @2)} composed of -;;a shortest sequence of edits transformaing @1 to @2. +;;to compare sequence tokens for equality. ;; -;;Each edit is a list of an integer and a symbol: +;;The non-negative integer @4, if provided, is maximum number of +;;deletions of the shorter sequence to allow. @0 will return @code{#f} +;;if more deletions would be necessary. +;; +;;@0 returns a vector of length @code{(diff:edit-length @1 @2)} composed +;;of a shortest sequence of edits transformaing @1 to @2. +;; +;;Each edit is an integer: ;;@table @asis -;;@item (@var{j} insert) -;;Inserts @code{(array-ref @1 @var{j})} into the sequence. -;;@item (@var{k} delete) -;;Deletes @code{(array-ref @2 @var{k})} from the sequence. +;;@item @var{k} > 0 +;;Inserts @code{(array-ref @1 (+ -1 @var{j}))} into the sequence. +;;@item @var{k} < 0 +;;Deletes @code{(array-ref @2 (- -1 @var{k}))} from the sequence. ;;@end table -(define (diff:edits array1 array2 . =?) - (define len1 (car (array-dimensions array1))) - (define len2 (car (array-dimensions array2))) - (define (snake k y) - (let snloop ((x (- y k)) - (y y)) - (if (and (< x len1) (< y len2) (=? (array-ref array1 x) - (array-ref array2 y))) - (snloop (+ 1 x) (+ 1 y)) y))) - (set! =? (if (null? =?) eqv? (car =?))) - (if (> len1 len2) - (diff:reverse-edits (diff:edits array2 array1)) - (let ((Delta (- len2 len1)) - (fp (make-array -1 (list (- (+ 1 len1)) (+ 1 len2))))) - (fp:compare fp Delta snake len2) - ;;(do ((idx (- -1 len1) (+ 1 idx))) ((>= idx (+ 1 len2)) (newline)) (printf "%3d" idx)) - ;;(do ((idx (- -1 len1) (+ 1 idx))) ((>= idx (+ 1 len2)) (newline)) (printf "%3d" (array-ref fp idx))) - (fp->edits fp Delta)))) - -(define (diff:reverse-edits edits) - (map (lambda (edit) - (list (car edit) - (case (cadr edit) - ((delete) 'insert) - ((insert) 'delete)))) - edits)) +(define (diff:edits A B =? . p-lim) + (define len-a (car (array-dimensions a))) + (define len-b (car (array-dimensions b))) + (set! p-lim (if (null? p-lim) -1 (car p-lim))) + (let ((edits (if (< len-b len-a) + (diff2edits B len-b A len-a =? p-lim) + (diff2edits A len-a B len-b =? p-lim)))) + (and edits (diff:order-edits edits (car (array-dimensions edits)) + (if (< len-b len-a) -1 1))))) +;;@args array1 array2 =? p-lim ;;@args array1 array2 =? -;;@args array1 array2 ;;@1 and @2 are one-dimensional arrays. The procedure @3 is used -;;to compare sequence tokens for equality. @3 defaults to @code{eqv?}. +;;to compare sequence tokens for equality. +;; +;;The non-negative integer @4, if provided, is maximum number of +;;deletions of the shorter sequence to allow. @0 will return @code{#f} +;;if more deletions would be necessary. +;; ;;@0 returns the length of the shortest sequence of edits transformaing ;;@1 to @2. -(define (diff:edit-length array1 array2 . =?) - (define len1 (car (array-dimensions array1))) - (define len2 (car (array-dimensions array2))) - (define (snake k y) - (let snloop ((x (- y k)) - (y y)) - (if (and (< x len1) (< y len2) (=? (array-ref array1 x) - (array-ref array2 y))) - (snloop (+ 1 x) (+ 1 y)) - y))) - (set! =? (if (null? =?) eqv? (car =?))) - (if (> len1 len2) - (diff:edit-length array2 array1) - (let ((Delta (- len2 len1)) - (fp (make-array -1 (list (- (+ 1 len1)) (+ 1 len2))))) - (fp:compare fp Delta snake len2)))) +(define (diff:edit-length A B =? . p-lim) + (define M (car (array-dimensions a))) + (define N (car (array-dimensions b))) + (set! p-lim (if (null? p-lim) -1 (car p-lim))) + (if (< N M) + (diff2editlen B N A M =? p-lim) + (diff2editlen A M B N =? p-lim))) ;;@example -;;(diff:longest-common-subsequence '#(f g h i e j c k l m) -;; '#(f g e h i j k p q r l m)) -;; @result{} #(f g h i j k l m) +;;(diff:longest-common-subsequence "fghiejcklm" "fgehijkpqrlm" eqv?) +;;@result{} "fghijklm" ;; -;;(diff:edit-length '#(f g h i e j c k l m) -;; '#(f g e h i j k p q r l m)) +;;(diff:edit-length "fghiejcklm" "fgehijkpqrlm" eqv?) ;;@result{} 6 ;; -;;(pretty-print (diff:edits '#(f g h i e j c k l m) -;; '#(f g e h i j k p q r l m))) -;;@print{} -;;((3 insert) ; e -;; (4 delete) ; c -;; (6 delete) ; h -;; (7 insert) ; p -;; (8 insert) ; q -;; (9 insert)) ; r +;;(diff:edits "fghiejcklm" "fgehijkpqrlm" eqv?) +;;@result{} #As32(3 -5 -7 8 9 10) +;; ; e c h p q r ;;@end example -;; 12 - 10 = 2 -;; -11-10 -9 -8 -7 -6 -5 -4 -3 -2 -1 0 1 2 3 4 5 6 7 8 9 10 11 12 -;; -1 -1 -1 -1 -1 -1 -1 -1 -1 3 7 8 9 12 9 8 -1 -1 -1 -1 -1 -1 -1 -1 -;; edit-distance = 6 +;;(trace-all "/home/jaffer/slib/differ.scm")(set! *qp-width* 333)(untrace fp:run fp:subarray) @@ -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) @@ -1,4 +1,4 @@ -;;;"elk.init" Initialisation file for SLIB for ELK 2.1 -*- Scheme -*- +;;;"elk.init" Initialisation file for SLIB for ELK 3.0 -*- Scheme -*- ;;; Author: Aubrey Jaffer ;;; ;;; This code is in the public domain. @@ -16,39 +16,33 @@ ;;; (software-type) should be set to the generic operating system type. ;;; UNIX, VMS, MACOS, AMIGA and MS-DOS are supported. - (define (software-type) 'UNIX) ;;; (scheme-implementation-type) should return the name of the scheme ;;; implementation loading this file. - (define (scheme-implementation-type) 'Elk) ;;; (scheme-implementation-home-page) should return a (string) URI ;;; (Uniform Resource Identifier) for this scheme implementation's home ;;; page; or false if there isn't one. - (define (scheme-implementation-home-page) "http://www.informatik.uni-bremen.de/~net/elk/") ;;; (scheme-implementation-version) should return a string describing ;;; the version the scheme implementation loading this file. - (define (scheme-implementation-version) "3.0") ;;; (implementation-vicinity) should be defined to be the pathname of ;;; the directory where any auxillary files to your Scheme ;;; implementation reside. - (define (implementation-vicinity) (case (software-type) - ((UNIX) "/usr/local/lib/elk-2.1/scm/") + ((UNIX) "/usr/local/lib/elk/runtime/scm/") ((VMS) "scheme$src:") ((MS-DOS) "C:\\scheme\\"))) ;;; (library-vicinity) should be defined to be the pathname of the ;;; directory where files of Scheme library functions reside. - (require 'unix) (define getenv unix-getenv) (define system unix-system) @@ -67,14 +61,18 @@ ;;; (home-vicinity) should return the vicinity of the user's HOME ;;; directory, the directory which typically contains files which ;;; customize a computer environment for a user. - -(define home-vicinity - (let ((home-path (getenv "HOME"))) - (lambda () home-path))) +(define (home-vicinity) + (let ((home (getenv "HOME"))) + (and home + (case (software-type) + ((UNIX COHERENT MS-DOS) ;V7 unix has a / on HOME + (if (eqv? #\/ (string-ref home (+ -1 (string-length home)))) + home + (string-append home "/"))) + (else home))))) ;;; *features* should be set to a list of symbols describing features ;;; of this implementation. Suggestions for features are: - (define *features* '( source ;can load scheme source files @@ -84,7 +82,7 @@ ;; Scheme report features -; rev5-report ;conforms to +; r5rs ;conforms to ; eval ;R5RS two-argument eval ; values ;R5RS multiple values ; dynamic-wind ;R5RS dynamic-wind @@ -98,11 +96,11 @@ ;STRING-FILL!, LIST->VECTOR, ;VECTOR->LIST, and VECTOR-FILL! - rev4-report ;conforms to + r4rs ;conforms to ieee-p1178 ;conforms to -; rev3-report ;conforms to +; r3rs ;conforms to rev2-procedures ;SUBSTRING-MOVE-LEFT!, ;SUBSTRING-MOVE-RIGHT!, @@ -113,7 +111,7 @@ multiarg/and- ;/ and - can take more than 2 args. ; with-file ;has WITH-INPUT-FROM-FILE and - ;WITH-OUTPUT-FROM-FILE + ;WITH-OUTPUT-TO-FILE transcript ;TRANSCRIPT-ON and TRANSCRIPT-OFF ; ieee-floating-point ;conforms to IEEE Standard 754-1985 ;IEEE Standard for Binary @@ -152,7 +150,6 @@ ; EXACT? appears to always return #f which isn't very useful. ; Approximating it with INTEGER? at least means that some ; of the code in the library will work correctly - (define exact? integer?) ; WARNING: redefining EXACT? (define (inexact? arg) @@ -202,6 +199,37 @@ (close-input-port insp) res)) +(define (make-exchanger obj) + (lambda (rep) (let ((old obj)) (set! obj rep) old))) +(define (open-file filename modes) + (case modes + ((r rb) (open-input-file filename)) + ((w wb) (open-output-file filename)) + (else (slib:error 'open-file 'mode? modes)))) +(define (port? obj) (or (input-port? port) (output-port? port))) +(define (call-with-open-ports . ports) + (define proc (car ports)) + (cond ((procedure? proc) (set! ports (cdr ports))) + (else (set! ports (reverse ports)) + (set! proc (car ports)) + (set! ports (reverse (cdr ports))))) + (let ((ans (apply proc ports))) + (for-each close-port ports) + ans)) +(define (close-port port) + (cond ((input-port? port) + (close-input-port port) + (if (output-port? port) (close-output-port port))) + ((output-port? port) (close-output-port port)) + (else (slib:error 'close-port 'port? port)))) + +(define (browse-url url) + (define (try cmd end) (zero? (system (string-append cmd url end)))) + (or (try "netscape-remote -remote 'openURL(" ")'") + (try "netscape -remote 'openURL(" ")'") + (try "netscape '" "'&") + (try "netscape '" "'"))) + ;;; CHAR-CODE-LIMIT is one greater than the largest integer which can ;;; be returned by CHAR->INTEGER. (define char-code-limit 256) @@ -268,7 +296,7 @@ (let ((cep (current-error-port))) (if (provided? 'trace) (print-call-stack cep)) (display "Warn: " cep) - (for-each (lambda (x) (display x cep)) args)))) + (for-each (lambda (x) (display #\ cep) (write x cep)) args)))) ;;; define an error procedure for the library (define slib:error @@ -323,7 +351,6 @@ ; _(global-environment)_ if none is explicitly specified. ; If this is not done, definitions in files loaded by other files will ; not be loaded in the correct environment. - (define slib:load-source (let ((primitive-load load)) (lambda (<pathname> . rest) @@ -333,14 +360,12 @@ ;;; (SLIB:LOAD-COMPILED "foo") should load the file that was produced ;;; by compiling "foo.scm" if this implementation can compile files. ;;; See feature 'COMPILED. - (define slib:load-compiled (let ((primitive-load load)) (lambda (<pathname> . rest) (apply primitive-load (string->symbol (string-append name ".o")) rest)))) ;;; At this point SLIB:LOAD must be able to load SLIB files. - (define slib:load slib:load-source) ;WARNING: redefining LOAD (slib:load (in-vicinity (library-vicinity) "require")) @@ -8,7 +8,7 @@ ;1. Any copy made of this software must include this copyright notice ;in full. ; -;2. I have made no warrantee or representation that the operation of +;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; @@ -45,15 +45,15 @@ (apply (lambda (environment-values identifiers procedure) (eval-1 `((lambda args args) ,@identifiers))) environment))))) - +;@ (define interaction-environment (let ((env (eval:make-environment '()))) (lambda () env))) -;;; null-environment is set by first call to scheme-report-environment at +;;;@ null-environment is set by first call to scheme-report-environment at ;;; the end of this file. (define null-environment #f) - +;@ (define scheme-report-environment (let* ((r4rs-procedures (append @@ -111,7 +111,7 @@ null-environment scheme-report-environment values) r4rs-procedures)) (r4rs-environment (eval:make-environment r4rs-procedures)) - (r5rs-environment (eval:make-environment r4rs-procedures))) + (r5rs-environment (eval:make-environment r5rs-procedures))) (let ((car car)) (lambda (version) (cond ((car r5rs-environment)) @@ -125,7 +125,7 @@ ((4) r4rs-environment) ((5) r5rs-environment) (else (slib:error 'eval 'version version 'not 'available))))))) - +;@ (define eval (let ((eval-1 slib:eval) (apply apply) @@ -8,7 +8,7 @@ ;1. Any copy made of this software must include this copyright notice ;in full. ; -;2. I have made no warrantee or representation that the operation of +;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; @@ -17,7 +17,6 @@ ;promotional, or sales literature without prior written consent in ;each case. -(require 'common-list-functions) (require 'modular) (require 'random) (require 'byte) @@ -82,8 +81,10 @@ (if (positive? i) #f #t)))) ;;; prime:products are products of small primes. +;;; was (comlist:notevery (lambda (prd) (= 1 (gcd n prd))) comps)) (define (primes-gcd? n comps) - (comlist:notevery (lambda (prd) (= 1 (gcd n prd))) comps)) + (not (let mapf ((lst comps)) + (or (null? lst) (and (= 1 (gcd n (car lst))) (mapf (cdr lst))))))) (define prime:prime-sqr 121) (define prime:products '(105)) (define prime:sieve (bytes 0 0 1 1 0 1 0 1 0 0 0)) @@ -122,40 +123,37 @@ ;;There is a slight chance @code{(expt 2 (- prime:trials))} that a ;;composite will return @code{#t}. (define prime? prime:prime?) -(define probably-prime? prime:prime?) ;legacy (define (prime:prime< start) (do ((nbr (+ -1 start) (+ -1 nbr))) ((or (negative? nbr) (prime:prime? nbr)) (if (negative? nbr) #f nbr)))) -(define (prime:primes< start count) +;;@body +;;Returns a list of the first @2 prime numbers less than +;;@1. If there are fewer than @var{count} prime numbers +;;less than @var{start}, then the returned list will have fewer than +;;@var{start} elements. +(define (primes< start count) (do ((cnt (+ -2 count) (+ -1 cnt)) (lst '() (cons prime lst)) (prime (prime:prime< start) (prime:prime< prime))) ((or (not prime) (negative? cnt)) (if prime (cons prime lst) lst)))) -;;@args start count -;;Returns a list of the first @2 prime numbers less than -;;@1. If there are fewer than @var{count} prime numbers -;;less than @var{start}, then the returned list will have fewer than -;;@var{start} elements. -(define primes< prime:primes<) (define (prime:prime> start) (do ((nbr (+ 1 start) (+ 1 nbr))) ((prime:prime? nbr) nbr))) -(define (prime:primes> start count) +;;@body +;;Returns a list of the first @2 prime numbers greater than @1. +(define (primes> start count) (set! start (max 0 start)) (do ((cnt (+ -2 count) (+ -1 cnt)) (lst '() (cons prime lst)) (prime (prime:prime> start) (prime:prime> prime))) ((negative? cnt) (reverse (cons prime lst))))) -;;@args start count -;;Returns a list of the first @2 prime numbers greater than @1. -(define primes> prime:primes>) ;;;;Lankinen's recursive factoring algorithm: ;From: ld231782@longs.LANCE.ColoState.EDU (L. Detweiler) @@ -232,14 +230,13 @@ '() (prime:fo m)))) -(define (prime:factor k) +;;@body +;;Returns a list of the prime factors of @1. The order of the +;;factors is unspecified. In order to obtain a sorted list do +;;@code{(sort! (factor @var{k}) <)}. +(define (factor k) (case k ((-1 0 1) (list k)) (else (if (negative? k) (cons -1 (prime:fe (- k))) (prime:fe k))))) -;;@args k -;;Returns a list of the prime factors of @1. The order of the -;;factors is unspecified. In order to obtain a sorted list do -;;@code{(sort! (factor @var{k}) <)}. -(define factor prime:factor) @@ -1,5 +1,5 @@ ;;;"fft.scm" Fast Fourier Transform -;Copyright (C) 1999 Aubrey Jaffer +;Copyright (C) 1999, 2003 Aubrey Jaffer ; ;Permission to copy this software, to modify it, to redistribute it, ;to distribute modified versions, and to use it for any purpose is @@ -8,7 +8,7 @@ ;1. Any copy made of this software must include this copyright notice ;in full. ; -;2. I have made no warrantee or representation that the operation of +;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; @@ -28,14 +28,13 @@ ;;; differs in the direction of rotation of the complex unit vectors. (require 'array) +(require 'logical) -(define (fft:shuffled&scaled ara n scale) +;;@code{(require 'fft)} +;;@ftindex fft + +(define (fft:shuffle&scale new ara n scale) (define lgn (integer-length (+ -1 n))) - (define new (apply make-array 0 (array-dimensions ara))) - (define bit-reverse (lambda (width in) - (if (zero? width) 0 - (+ (bit-reverse (+ -1 width) (quotient in 2)) - (ash (modulo in 2) (+ -1 width)))))) (if (not (eqv? n (expt 2 lgn))) (slib:error 'fft "array length not power of 2" n)) (do ((k 0 (+ 1 k))) @@ -61,10 +60,35 @@ (array-set! ara (+ u t) k) (array-set! ara (- u t) k+m/2))))))) +;;@args array +;;@var{array} is an array of @code{(expt 2 n)} numbers. @code{fft} +;;returns an array of complex numbers comprising the +;;@dfn{Discrete Fourier Transform} of @var{array}. (define (fft ara) (define n (car (array-dimensions ara))) - (dft! (fft:shuffled&scaled ara n 1) n 1)) + (define new (apply create-array ara (array-dimensions ara))) + (dft! (fft:shuffle&scale new ara n 1) n 1)) +;;@args array +;;@code{fft-1} returns an array of complex numbers comprising the +;;inverse Discrete Fourier Transform of @var{array}. (define (fft-1 ara) (define n (car (array-dimensions ara))) - (dft! (fft:shuffled&scaled ara n (/ n)) n -1)) + (define new (apply create-array ara (array-dimensions ara))) + (dft! (fft:shuffle&scale new ara n (/ n)) n -1)) + +;;@noindent +;;@code{(fft-1 (fft @var{array}))} will return an array of values close to +;;@var{array}. +;; +;;@example +;;(fft '#(1 0+i -1 0-i 1 0+i -1 0-i)) @result{} +;; +;;#(0.0 0.0 0.0+628.0783185208527e-18i 0.0 +;; 0.0 0.0 8.0-628.0783185208527e-18i 0.0) +;; +;;(fft-1 '#(0 0 0 0 0 0 8 0)) @result{} +;; +;;#(1.0 -61.23031769111886e-18+1.0i -1.0 61.23031769111886e-18-1.0i +;; 1.0 -61.23031769111886e-18+1.0i -1.0 61.23031769111886e-18-1.0i) +;;@end example @@ -0,0 +1,32 @@ +@code{(require 'fft)} +@ftindex fft + + +@defun fft array + +@var{array} is an array of @code{(expt 2 n)} numbers. @code{fft} +returns an array of complex numbers comprising the +@dfn{Discrete Fourier Transform} of @var{array}. +@cindex Discrete Fourier Transform +@end defun + +@defun fft-1 array + +@code{fft-1} returns an array of complex numbers comprising the +inverse Discrete Fourier Transform of @var{array}. +@end defun +@noindent +@code{(fft-1 (fft @var{array}))} will return an array of values close to +@var{array}. + +@example +(fft '#(1 0+i -1 0-i 1 0+i -1 0-i)) @result{} + +#(0.0 0.0 0.0+628.0783185208527e-18i 0.0 + 0.0 0.0 8.0-628.0783185208527e-18i 0.0) + +(fft-1 '#(0 0 0 0 0 0 8 0)) @result{} + +#(1.0 -61.23031769111886e-18+1.0i -1.0 61.23031769111886e-18-1.0i + 1.0 -61.23031769111886e-18+1.0i -1.0 61.23031769111886e-18-1.0i) +@end example diff --git a/fluidlet.scm b/fluidlet.scm index 983bfdb..06d4630 100644 --- a/fluidlet.scm +++ b/fluidlet.scm @@ -1,5 +1,5 @@ ; "fluidlet.scm", FLUID-LET for Scheme -; Copyright (c) 1998, Aubrey Jaffer +; Copyright (c) 1998 Aubrey Jaffer ; ;Permission to copy this software, to modify it, to redistribute it, ;to distribute modified versions, and to use it for any purpose is @@ -8,7 +8,7 @@ ;1. Any copy made of this software must include this copyright notice ;in full. ; -;2. I have made no warrantee or representation that the operation of +;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; @@ -18,14 +18,13 @@ ;each case. (require 'dynamic-wind) -(require 'common-list-functions) ;MAKE-LIST - +;@ (defmacro fluid-let (clauses . body) (let ((ids (map car clauses)) (new-tmps (map (lambda (x) (gentemp)) clauses)) (old-tmps (map (lambda (x) (gentemp)) clauses))) `(let (,@(map list new-tmps (map cadr clauses)) - ,@(map list old-tmps (make-list (length clauses) #f))) + ,@(map list old-tmps (map (lambda (x) #f) clauses))) (dynamic-wind (lambda () ,@(map (lambda (ot id) `(set! ,ot ,id)) diff --git a/fmtdoc.txi b/fmtdoc.txi deleted file mode 100644 index 3e2adb7..0000000 --- a/fmtdoc.txi +++ /dev/null @@ -1,434 +0,0 @@ - -@menu -* Format Interface:: -* Format Specification:: -@end menu - -@node Format Interface, Format Specification, Format, Format -@subsection Format Interface - -@defun format destination format-string . arguments -An almost complete implementation of Common LISP format description -according to the CL reference book @cite{Common LISP} from Guy L. -Steele, Digital Press. Backward compatible to most of the available -Scheme format implementations. - -Returns @code{#t}, @code{#f} or a string; has side effect of printing -according to @var{format-string}. If @var{destination} is @code{#t}, -the output is to the current output port and @code{#t} is returned. If -@var{destination} is @code{#f}, a formatted string is returned as the -result of the call. NEW: If @var{destination} is a string, -@var{destination} is regarded as the format string; @var{format-string} is -then the first argument and the output is returned as a string. If -@var{destination} is a number, the output is to the current error port -if available by the implementation. Otherwise @var{destination} must be -an output port and @code{#t} is returned.@refill - -@var{format-string} must be a string. In case of a formatting error -format returns @code{#f} and prints a message on the current output or -error port. Characters are output as if the string were output by the -@code{display} function with the exception of those prefixed by a tilde -(~). For a detailed description of the @var{format-string} syntax -please consult a Common LISP format reference manual. For a test suite -to verify this format implementation load @file{formatst.scm}. Please -send bug reports to @code{lutzeb@@cs.tu-berlin.de}. - -Note: @code{format} is not reentrant, i.e. only one @code{format}-call -may be executed at a time. - -@end defun - -@node Format Specification, , Format Interface, Format -@subsection Format Specification (Format version 3.0) - -Please consult a Common LISP format reference manual for a detailed -description of the format string syntax. For a demonstration of the -implemented directives see @file{formatst.scm}.@refill - -This implementation supports directive parameters and modifiers -(@code{:} and @code{@@} characters). Multiple parameters must be -separated by a comma (@code{,}). Parameters can be numerical parameters -(positive or negative), character parameters (prefixed by a quote -character (@code{'}), variable parameters (@code{v}), number of rest -arguments parameter (@code{#}), empty and default parameters. Directive -characters are case independent. The general form of a directive -is:@refill - -@noindent -@var{directive} ::= ~@{@var{directive-parameter},@}[:][@@]@var{directive-character} - -@noindent -@var{directive-parameter} ::= [ [-|+]@{0-9@}+ | '@var{character} | v | # ] - - -@subsubsection Implemented CL Format Control Directives - -Documentation syntax: Uppercase characters represent the corresponding -control directive characters. Lowercase characters represent control -directive parameter descriptions. - -@table @asis -@item @code{~A} -Any (print as @code{display} does). -@table @asis -@item @code{~@@A} -left pad. -@item @code{~@var{mincol},@var{colinc},@var{minpad},@var{padchar}A} -full padding. -@end table -@item @code{~S} -S-expression (print as @code{write} does). -@table @asis -@item @code{~@@S} -left pad. -@item @code{~@var{mincol},@var{colinc},@var{minpad},@var{padchar}S} -full padding. -@end table -@item @code{~D} -Decimal. -@table @asis -@item @code{~@@D} -print number sign always. -@item @code{~:D} -print comma separated. -@item @code{~@var{mincol},@var{padchar},@var{commachar}D} -padding. -@end table -@item @code{~X} -Hexadecimal. -@table @asis -@item @code{~@@X} -print number sign always. -@item @code{~:X} -print comma separated. -@item @code{~@var{mincol},@var{padchar},@var{commachar}X} -padding. -@end table -@item @code{~O} -Octal. -@table @asis -@item @code{~@@O} -print number sign always. -@item @code{~:O} -print comma separated. -@item @code{~@var{mincol},@var{padchar},@var{commachar}O} -padding. -@end table -@item @code{~B} -Binary. -@table @asis -@item @code{~@@B} -print number sign always. -@item @code{~:B} -print comma separated. -@item @code{~@var{mincol},@var{padchar},@var{commachar}B} -padding. -@end table -@item @code{~@var{n}R} -Radix @var{n}. -@table @asis -@item @code{~@var{n},@var{mincol},@var{padchar},@var{commachar}R} -padding. -@end table -@item @code{~@@R} -print a number as a Roman numeral. -@item @code{~:@@R} -print a number as an ``old fashioned'' Roman numeral. -@item @code{~:R} -print a number as an ordinal English number. -@item @code{~R} -print a number as a cardinal English number. -@item @code{~P} -Plural. -@table @asis -@item @code{~@@P} -prints @code{y} and @code{ies}. -@item @code{~:P} -as @code{~P but jumps 1 argument backward.} -@item @code{~:@@P} -as @code{~@@P but jumps 1 argument backward.} -@end table -@item @code{~C} -Character. -@table @asis -@item @code{~@@C} -prints a character as the reader can understand it (i.e. @code{#\} prefixing). -@item @code{~:C} -prints a character as emacs does (eg. @code{^C} for ASCII 03). -@end table -@item @code{~F} -Fixed-format floating-point (prints a flonum like @var{mmm.nnn}). -@table @asis -@item @code{~@var{width},@var{digits},@var{scale},@var{overflowchar},@var{padchar}F} -@item @code{~@@F} -If the number is positive a plus sign is printed. -@end table -@item @code{~E} -Exponential floating-point (prints a flonum like @var{mmm.nnn}@code{E}@var{ee}). -@table @asis -@item @code{~@var{width},@var{digits},@var{exponentdigits},@var{scale},@var{overflowchar},@var{padchar},@var{exponentchar}E} -@item @code{~@@E} -If the number is positive a plus sign is printed. -@end table -@item @code{~G} -General floating-point (prints a flonum either fixed or exponential). -@table @asis -@item @code{~@var{width},@var{digits},@var{exponentdigits},@var{scale},@var{overflowchar},@var{padchar},@var{exponentchar}G} -@item @code{~@@G} -If the number is positive a plus sign is printed. -@end table -@item @code{~$} -Dollars floating-point (prints a flonum in fixed with signs separated). -@table @asis -@item @code{~@var{digits},@var{scale},@var{width},@var{padchar}$} -@item @code{~@@$} -If the number is positive a plus sign is printed. -@item @code{~:@@$} -A sign is always printed and appears before the padding. -@item @code{~:$} -The sign appears before the padding. -@end table -@item @code{~%} -Newline. -@table @asis -@item @code{~@var{n}%} -print @var{n} newlines. -@end table -@item @code{~&} -print newline if not at the beginning of the output line. -@table @asis -@item @code{~@var{n}&} -prints @code{~&} and then @var{n-1} newlines. -@end table -@item @code{~|} -Page Separator. -@table @asis -@item @code{~@var{n}|} -print @var{n} page separators. -@end table -@item @code{~~} -Tilde. -@table @asis -@item @code{~@var{n}~} -print @var{n} tildes. -@end table -@item @code{~}<newline> -Continuation Line. -@table @asis -@item @code{~:}<newline> -newline is ignored, white space left. -@item @code{~@@}<newline> -newline is left, white space ignored. -@end table -@item @code{~T} -Tabulation. -@table @asis -@item @code{~@@T} -relative tabulation. -@item @code{~@var{colnum,colinc}T} -full tabulation. -@end table -@item @code{~?} -Indirection (expects indirect arguments as a list). -@table @asis -@item @code{~@@?} -extracts indirect arguments from format arguments. -@end table -@item @code{~(@var{str}~)} -Case conversion (converts by @code{string-downcase}). -@table @asis -@item @code{~:(@var{str}~)} -converts by @code{string-capitalize}. -@item @code{~@@(@var{str}~)} -converts by @code{string-capitalize-first}. -@item @code{~:@@(@var{str}~)} -converts by @code{string-upcase}. -@end table -@item @code{~*} -Argument Jumping (jumps 1 argument forward). -@table @asis -@item @code{~@var{n}*} -jumps @var{n} arguments forward. -@item @code{~:*} -jumps 1 argument backward. -@item @code{~@var{n}:*} -jumps @var{n} arguments backward. -@item @code{~@@*} -jumps to the 0th argument. -@item @code{~@var{n}@@*} -jumps to the @var{n}th argument (beginning from 0) -@end table -@item @code{~[@var{str0}~;@var{str1}~;...~;@var{strn}~]} -Conditional Expression (numerical clause conditional). -@table @asis -@item @code{~@var{n}[} -take argument from @var{n}. -@item @code{~@@[} -true test conditional. -@item @code{~:[} -if-else-then conditional. -@item @code{~;} -clause separator. -@item @code{~:;} -default clause follows. -@end table -@item @code{~@{@var{str}~@}} -Iteration (args come from the next argument (a list)). -@table @asis -@item @code{~@var{n}@{} -at most @var{n} iterations. -@item @code{~:@{} -args from next arg (a list of lists). -@item @code{~@@@{} -args from the rest of arguments. -@item @code{~:@@@{} -args from the rest args (lists). -@end table -@item @code{~^} -Up and out. -@table @asis -@item @code{~@var{n}^} -aborts if @var{n} = 0 -@item @code{~@var{n},@var{m}^} -aborts if @var{n} = @var{m} -@item @code{~@var{n},@var{m},@var{k}^} -aborts if @var{n} <= @var{m} <= @var{k} -@end table -@end table - - -@subsubsection Not Implemented CL Format Control Directives - -@table @asis -@item @code{~:A} -print @code{#f} as an empty list (see below). -@item @code{~:S} -print @code{#f} as an empty list (see below). -@item @code{~<~>} -Justification. -@item @code{~:^} -(sorry I don't understand its semantics completely) -@end table - - -@subsubsection Extended, Replaced and Additional Control Directives - -@table @asis -@item @code{~@var{mincol},@var{padchar},@var{commachar},@var{commawidth}D} -@item @code{~@var{mincol},@var{padchar},@var{commachar},@var{commawidth}X} -@item @code{~@var{mincol},@var{padchar},@var{commachar},@var{commawidth}O} -@item @code{~@var{mincol},@var{padchar},@var{commachar},@var{commawidth}B} -@item @code{~@var{n},@var{mincol},@var{padchar},@var{commachar},@var{commawidth}R} -@var{commawidth} is the number of characters between two comma characters. -@end table - -@table @asis -@item @code{~I} -print a R4RS complex number as @code{~F~@@Fi} with passed parameters for -@code{~F}. -@item @code{~Y} -Pretty print formatting of an argument for scheme code lists. -@item @code{~K} -Same as @code{~?.} -@item @code{~!} -Flushes the output if format @var{destination} is a port. -@item @code{~_} -Print a @code{#\space} character -@table @asis -@item @code{~@var{n}_} -print @var{n} @code{#\space} characters. -@end table -@item @code{~/} -Print a @code{#\tab} character -@table @asis -@item @code{~@var{n}/} -print @var{n} @code{#\tab} characters. -@end table -@item @code{~@var{n}C} -Takes @var{n} as an integer representation for a character. No arguments -are consumed. @var{n} is converted to a character by -@code{integer->char}. @var{n} must be a positive decimal number.@refill -@item @code{~:S} -Print out readproof. Prints out internal objects represented as -@code{#<...>} as strings @code{"#<...>"} so that the format output can always -be processed by @code{read}. -@refill -@item @code{~:A} -Print out readproof. Prints out internal objects represented as -@code{#<...>} as strings @code{"#<...>"} so that the format output can always -be processed by @code{read}. -@item @code{~Q} -Prints information and a copyright notice on the format implementation. -@table @asis -@item @code{~:Q} -prints format version. -@end table -@refill -@item @code{~F, ~E, ~G, ~$} -may also print number strings, i.e. passing a number as a string and -format it accordingly. -@end table - -@subsubsection Configuration Variables - -Format has some configuration variables at the beginning of -@file{format.scm} to suit the systems and users needs. There should be -no modification necessary for the configuration that comes with SLIB. -If modification is desired the variable should be set after the format -code is loaded. Format detects automatically if the running scheme -system implements floating point numbers and complex numbers. - -@table @asis - -@item @var{format:symbol-case-conv} -Symbols are converted by @code{symbol->string} so the case type of the -printed symbols is implementation dependent. -@code{format:symbol-case-conv} is a one arg closure which is either -@code{#f} (no conversion), @code{string-upcase}, @code{string-downcase} -or @code{string-capitalize}. (default @code{#f}) - -@item @var{format:iobj-case-conv} -As @var{format:symbol-case-conv} but applies for the representation of -implementation internal objects. (default @code{#f}) - -@item @var{format:expch} -The character prefixing the exponent value in @code{~E} printing. (default -@code{#\E}) - -@end table - -@subsubsection Compatibility With Other Format Implementations - -@table @asis -@item SLIB format 2.x: -See @file{format.doc}. - -@item SLIB format 1.4: -Downward compatible except for padding support and @code{~A}, @code{~S}, -@code{~P}, @code{~X} uppercase printing. SLIB format 1.4 uses C-style -@code{printf} padding support which is completely replaced by the CL -@code{format} padding style. - -@item MIT C-Scheme 7.1: -Downward compatible except for @code{~}, which is not documented -(ignores all characters inside the format string up to a newline -character). (7.1 implements @code{~a}, @code{~s}, -~@var{newline}, @code{~~}, @code{~%}, numerical and variable -parameters and @code{:/@@} modifiers in the CL sense).@refill - -@item Elk 1.5/2.0: -Downward compatible except for @code{~A} and @code{~S} which print in -uppercase. (Elk implements @code{~a}, @code{~s}, @code{~~}, and -@code{~%} (no directive parameters or modifiers)).@refill - -@item Scheme->C 01nov91: -Downward compatible except for an optional destination parameter: S2C -accepts a format call without a destination which returns a formatted -string. This is equivalent to a #f destination in S2C. (S2C implements -@code{~a}, @code{~s}, @code{~c}, @code{~%}, and @code{~~} (no directive -parameters or modifiers)).@refill - -@end table - -This implementation of format is solely useful in the SLIB context -because it requires other components provided by SLIB.@refill @@ -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) @@ -1,5 +1,5 @@ ;;; "getopt.scm" POSIX command argument processing -;Copyright (C) 1993, 1994 Aubrey Jaffer +;Copyright (C) 1993, 1994, 2002 Aubrey Jaffer ; ;Permission to copy this software, to modify it, to redistribute it, ;to distribute modified versions, and to use it for any purpose is @@ -8,7 +8,7 @@ ;1. Any copy made of this software must include this copyright notice ;in full. ; -;2. I have made no warrantee or representation that the operation of +;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; @@ -19,19 +19,21 @@ (define getopt:scan #f) (define getopt:char #\-) +;@ (define getopt:opt #f) +(define *argv* *argv*) (define *optind* 1) (define *optarg* 0) - -(define (getopt argc argv optstring) +;@ +(define (getopt optstring) (let ((opts (string->list optstring)) (place #f) (arg #f) - (argref (lambda () ((if (vector? argv) vector-ref list-ref) - argv *optind*)))) + (argref (lambda () ((if (vector? *argv*) vector-ref list-ref) + *argv* *optind*)))) (and (cond ((and getopt:scan (not (string=? "" getopt:scan))) #t) - ((>= *optind* argc) #f) + ((>= *optind* (length *argv*)) #f) (else (set! arg (argref)) (cond ((or (<= (string-length arg) 1) @@ -42,8 +44,7 @@ (set! *optind* (+ *optind* 1)) #f) (else - (set! getopt:scan - (substring arg 1 (string-length arg))) + (set! getopt:scan (substring arg 1 (string-length arg))) #t)))) (begin (set! getopt:opt (string-ref getopt:scan 0)) @@ -59,22 +60,21 @@ (set! *optind* (+ *optind* 1)) (set! getopt:scan #f) getopt:opt) - ((< *optind* argc) + ((< *optind* (length *argv*)) (set! *optarg* (argref)) (set! *optind* (+ *optind* 1)) getopt:opt) ((and (not (null? opts)) (char=? #\: (car opts))) #\:) (else #\?)))))) - -(define (getopt-- argc argv optstring) - (let* ((opt (getopt argc argv (string-append optstring "-:"))) +;@ +(define (getopt-- optstring) + (let* ((opt (getopt (string-append optstring "-:"))) (optarg *optarg*)) (cond ((eqv? #\- opt) ;long option (do ((l (string-length *optarg*)) (i 0 (+ 1 i))) ((or (>= i l) (char=? #\= (string-ref optarg i))) - (cond - ((>= i l) (set! *optarg* #f) optarg) - (else (set! *optarg* (substring optarg (+ 1 i) l)) - (substring optarg 0 i)))))) + (cond ((>= i l) (set! *optarg* #f) optarg) + (else (set! *optarg* (substring optarg (+ 1 i) l)) + (substring optarg 0 i)))))) (else opt)))) diff --git a/getparam.scm b/getparam.scm index 3e2d7f1..1e7b7c0 100644 --- a/getparam.scm +++ b/getparam.scm @@ -8,7 +8,7 @@ ;1. Any copy made of this software must include this copyright notice ;in full. ; -;2. I have made no warrantee or representation that the operation of +;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; @@ -19,12 +19,41 @@ (require 'getopt) (require 'coerce) +(require 'parameters) +(require-if 'compiling 'printf) +(require-if 'compiling 'common-list-functions) -(define (getopt->parameter-list argc argv optnames arities types aliases - . description) +;;@code{(require 'getopt-parameters)} +;;@ftindex getopt-parameters + +;;@args optnames arities types aliases desc @dots{} +;;Returns @var{*argv*} converted to a parameter-list. @var{optnames} are +;;the parameter-names. @var{arities} and @var{types} are lists of symbols +;;corresponding to @var{optnames}. +;; +;;@var{aliases} is a list of lists of strings or integers paired with +;;elements of @var{optnames}. Each one-character string will be treated +;;as a single @samp{-} option by @code{getopt}. Longer strings will be +;;treated as long-named options (@pxref{Getopt, getopt--}). +;; +;;If the @var{aliases} association list has only strings as its +;;@code{car}s, then all the option-arguments after an option (and before +;;the next option) are adjoined to that option. +;; +;;If the @var{aliases} association list has integers, then each (string) +;;option will take at most one option-argument. Unoptioned arguments are +;;collected in a list. A @samp{-1} alias will take the last argument in +;;this list; @samp{+1} will take the first argument in the list. The +;;aliases -2 then +2; -3 then +3; @dots{} are tried so long as a positive +;;or negative consecutive alias is found and arguments remain in the list. +;;Finally a @samp{0} alias, if found, absorbs any remaining arguments. +;; +;;In all cases, if unclaimed arguments remain after processing, a warning +;;is signaled and #f is returned. +(define (getopt->parameter-list optnames arities types aliases . description) (define (can-take-arg? opt) (not (eq? 'boolean (list-ref arities (position opt optnames))))) - (let ((progname (list-ref argv (+ -1 *optind*))) + (let ((progname (list-ref *argv* (+ -1 *optind*))) (optlist '()) (long-opt-list '()) (optstring #f) @@ -63,7 +92,8 @@ (for-each (lambda (unc) (adjoin-val unc curopt)) unclaimeds) (set! unclaimeds '())))))) (cond ((not (null? unclaimeds)) - (slib:warn 'getopt->parameter-list 'arguments 'unclaimed unclaimeds) + (getopt-barf "%s: Unclaimed argument '%s'" + progname (car unclaimeds)) (apply parameter-list->getopt-usage progname optnames arities types aliases description)) (else parameter-list))) @@ -94,34 +124,34 @@ aliases) (set! optstring (list->string (cons #\: optlist))) (let loop () - (let ((opt (getopt-- argc argv optstring))) + (let ((opt (getopt-- optstring))) (case opt ((#\: #\?) - (slib:warn 'getopt->parameter-list - (case opt - ((#\:) "argument missing after") - ((#\?) "unrecognized option")) - (string #\- getopt:opt)) + (getopt-barf (case opt + ((#\:) "%s: argument missing after '-%c'") + ((#\?) "%s: unrecognized option '-%c'")) + progname + getopt:opt) (apply parameter-list->getopt-usage progname optnames arities types aliases description)) ((#f) - (cond ((and (< *optind* argc) - (string=? "-" (list-ref argv *optind*))) + (cond ((and (< *optind* (length *argv*)) + (string=? "-" (list-ref *argv* *optind*))) (set! *optind* (+ 1 *optind*)) (finish)) - ((< *optind* argc) + ((< *optind* (length *argv*)) (let ((topt (assoc curopt aliases))) (if topt (set! curopt (cadr topt))) (cond ((and positional? (not topt)) (set! unclaimeds - (cons (list-ref argv *optind*) unclaimeds)) + (cons (list-ref *argv* *optind*) unclaimeds)) (set! *optind* (+ 1 *optind*)) (loop)) ((and (member curopt optnames) - (adjoin-val (list-ref argv *optind*) curopt)) + (adjoin-val (list-ref *argv* *optind*) curopt)) (set! *optind* (+ 1 *optind*)) (loop)) (else (slib:error 'getopt->parameter-list curopt - (list-ref argv *optind*) + (list-ref *argv* *optind*) 'not 'supported))))) (else (finish)))) (else @@ -130,7 +160,7 @@ (if topt (set! topt (cadr topt))) (cond ((not topt) - (slib:warn "Option not recognized -" opt) + (getopt-barf "%s: '--%s' option not recognized" progname opt) (apply parameter-list->getopt-usage progname optnames arities types aliases description)) ((not (can-take-arg? topt)) @@ -138,9 +168,15 @@ (loop)) (*optarg* (set! curopt topt) (adjoin-val *optarg* curopt) (loop)) (else -;;; (slib:warn 'getopt->parameter-list "= missing for option--" opt) + ;;(getopt-barf "%s: '--%s' option expects '='" progname opt) + ;;(apply parameter-list->getopt-usage progname optnames arities types aliases description) (set! curopt topt) (loop)))))))))) +(define (getopt-barf . args) + (require 'printf) + (apply fprintf (current-error-port) args) + (newline (current-error-port))) + (define (parameter-list->getopt-usage comname optnames arities types aliases . description) (require 'printf) @@ -198,11 +234,17 @@ (for-each (lambda (desc) (fprintf cep " %s\\n" desc)) description)) #f) -(define (getopt->arglist argc argv optnames positions +;;@args optnames positions arities types defaulters checks aliases desc @dots{} +;;Like @code{getopt->parameter-list}, but converts @var{*argv*} to an +;;argument-list as specified by @var{optnames}, @var{positions}, +;;@var{arities}, @var{types}, @var{defaulters}, @var{checks}, and +;;@var{aliases}. If the options supplied violate the @var{arities} or +;;@var{checks} constraints, then a warning is signaled and #f is returned. +(define (getopt->arglist optnames positions arities types defaulters checks aliases . description) - (define progname (list-ref argv (+ -1 *optind*))) + (define progname (list-ref *argv* (+ -1 *optind*))) (let* ((params (apply getopt->parameter-list - argc argv optnames arities types aliases description)) + optnames arities types aliases description)) (fparams (and params (fill-empty-parameters defaulters params)))) (cond ((and (list? params) (check-parameters checks fparams) @@ -211,3 +253,49 @@ progname optnames arities types aliases description)) (else #f)))) +;;@noindent +;;These @code{getopt} functions can be used with SLIB relational +;;databases. For an example, @xref{Using Databases, make-command-server}. +;; +;;@noindent +;;If errors are encountered while processing options, directions for using +;;the options (and argument strings @var{desc} @dots{}) are printed to +;;@code{current-error-port}. +;; +;;@example +;;(begin +;; (set! *optind* 1) +;; (set! *argv* '("cmd" "-?") +;; (getopt->parameter-list +;; '(flag number symbols symbols string flag2 flag3 num2 num3) +;; '(boolean optional nary1 nary single boolean boolean nary nary) +;; '(boolean integer symbol symbol string boolean boolean integer integer) +;; '(("flag" flag) +;; ("f" flag) +;; ("Flag" flag2) +;; ("B" flag3) +;; ("optional" number) +;; ("o" number) +;; ("nary1" symbols) +;; ("N" symbols) +;; ("nary" symbols) +;; ("n" symbols) +;; ("single" string) +;; ("s" string) +;; ("a" num2) +;; ("Abs" num3)))) +;;@print{} +;;Usage: cmd [OPTION ARGUMENT ...] ... +;; +;; -f, --flag +;; -o, --optional=<number> +;; -n, --nary=<symbols> ... +;; -N, --nary1=<symbols> ... +;; -s, --single=<string> +;; --Flag +;; -B +;; -a <num2> ... +;; --Abs=<num3> ... +;; +;;ERROR: getopt->parameter-list "unrecognized option" "-?" +;;@end example diff --git a/getparam.txi b/getparam.txi new file mode 100644 index 0000000..3d2594c --- /dev/null +++ b/getparam.txi @@ -0,0 +1,85 @@ +@code{(require 'getopt-parameters)} +@ftindex getopt-parameters + + +@defun getopt->parameter-list optnames arities types aliases desc @dots{} + +Returns @var{*argv*} converted to a parameter-list. @var{optnames} are +the parameter-names. @var{arities} and @var{types} are lists of symbols +corresponding to @var{optnames}. + +@var{aliases} is a list of lists of strings or integers paired with +elements of @var{optnames}. Each one-character string will be treated +as a single @samp{-} option by @code{getopt}. Longer strings will be +treated as long-named options (@pxref{Getopt, getopt--}). + +If the @var{aliases} association list has only strings as its +@code{car}s, then all the option-arguments after an option (and before +the next option) are adjoined to that option. + +If the @var{aliases} association list has integers, then each (string) +option will take at most one option-argument. Unoptioned arguments are +collected in a list. A @samp{-1} alias will take the last argument in +this list; @samp{+1} will take the first argument in the list. The +aliases -2 then +2; -3 then +3; @dots{} are tried so long as a positive +or negative consecutive alias is found and arguments remain in the list. +Finally a @samp{0} alias, if found, absorbs any remaining arguments. + +In all cases, if unclaimed arguments remain after processing, a warning +is signaled and #f is returned. +@end defun + +@defun getopt->arglist optnames positions arities types defaulters checks aliases desc @dots{} + +Like @code{getopt->parameter-list}, but converts @var{*argv*} to an +argument-list as specified by @var{optnames}, @var{positions}, +@var{arities}, @var{types}, @var{defaulters}, @var{checks}, and +@var{aliases}. If the options supplied violate the @var{arities} or +@var{checks} constraints, then a warning is signaled and #f is returned. +@end defun +@noindent +These @code{getopt} functions can be used with SLIB relational +databases. For an example, @xref{Using Databases, make-command-server}. + +@noindent +If errors are encountered while processing options, directions for using +the options (and argument strings @var{desc} @dots{}) are printed to +@code{current-error-port}. + +@example +(begin + (set! *optind* 1) + (set! *argv* '("cmd" "-?") + (getopt->parameter-list + '(flag number symbols symbols string flag2 flag3 num2 num3) + '(boolean optional nary1 nary single boolean boolean nary nary) + '(boolean integer symbol symbol string boolean boolean integer integer) + '(("flag" flag) + ("f" flag) + ("Flag" flag2) + ("B" flag3) + ("optional" number) + ("o" number) + ("nary1" symbols) + ("N" symbols) + ("nary" symbols) + ("n" symbols) + ("single" string) + ("s" string) + ("a" num2) + ("Abs" num3)))) +@print{} +Usage: cmd [OPTION ARGUMENT ...] ... + + -f, --flag + -o, --optional=<number> + -n, --nary=<symbols> ... + -N, --nary1=<symbols> ... + -s, --single=<string> + --Flag + -B + -a <num2> ... + --Abs=<num3> ... + +ERROR: getopt->parameter-list "unrecognized option" "-?" +@end example @@ -8,7 +8,7 @@ ;1. Any copy made of this software must include this copyright notice ;in full. ; -;2. I have made no warrantee or representation that the operation of +;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; @@ -17,6 +17,10 @@ ;promotional, or sales literature without prior written consent in ;each case. +;;@code{(require 'filename)} or @code{(require 'glob)} +;;@ftindex filename +;;@ftindex glob + (define (glob:pattern->tokens pat) (cond ((string? pat) @@ -187,31 +191,87 @@ (else (loop (cdr inds) (cdr wild?) lits res))))))))) +;;@body +;;Returns a predicate which returns a non-false value if its string argument +;;matches (the string) @var{pattern}, false otherwise. Filename matching +;;is like +;;@cindex glob +;;@dfn{glob} expansion described the bash manpage, except that names +;;beginning with @samp{.} are matched and @samp{/} characters are not +;;treated specially. +;; +;;These functions interpret the following characters specially in +;;@var{pattern} strings: +;;@table @samp +;;@item * +;;Matches any string, including the null string. +;;@item ? +;;Matches any single character. +;;@item [@dots{}] +;;Matches any one of the enclosed characters. A pair of characters +;;separated by a minus sign (-) denotes a range; any character lexically +;;between those two characters, inclusive, is matched. If the first +;;character following the @samp{[} is a @samp{!} or a @samp{^} then any +;;character not enclosed is matched. A @samp{-} or @samp{]} may be +;;matched by including it as the first or last character in the set. +;;@end table +(define (filename:match?? pattern) + (glob:make-matcher pattern char=? char<=?)) +(define (filename:match-ci?? pattern) + (glob:make-matcher pattern char-ci=? char-ci<=?)) -(define (glob:match?? pat) - (glob:make-matcher pat char=? char<=?)) -(define (glob:match-ci?? pat) - (glob:make-matcher pat char-ci=? char-ci<=?)) -(define filename:match?? glob:match??) -(define filename:match-ci?? glob:match-ci??) -(define (glob:substitute?? pat templ) - (cond ((procedure? templ) - (glob:caller-with-matches pat templ char=? char<=?)) - ((string? templ) - (glob:make-substituter pat templ char=? char<=?)) +;;@args pattern template +;;Returns a function transforming a single string argument according to +;;glob patterns @var{pattern} and @var{template}. @var{pattern} and +;;@var{template} must have the same number of wildcard specifications, +;;which need not be identical. @var{pattern} and @var{template} may have +;;a different number of literal sections. If an argument to the function +;;matches @var{pattern} in the sense of @code{filename:match??} then it +;;returns a copy of @var{template} in which each wildcard specification is +;;replaced by the part of the argument matched by the corresponding +;;wildcard specification in @var{pattern}. A @code{*} wildcard matches +;;the longest leftmost string possible. If the argument does not match +;;@var{pattern} then false is returned. +;; +;;@var{template} may be a function accepting the same number of string +;;arguments as there are wildcard specifications in @var{pattern}. In +;;the case of a match the result of applying @var{template} to a list +;;of the substrings matched by wildcard specifications will be returned, +;;otherwise @var{template} will not be called and @code{#f} will be returned. +(define (filename:substitute?? pattern template) + (cond ((procedure? template) + (glob:caller-with-matches pattern template char=? char<=?)) + ((string? template) + (glob:make-substituter pattern template char=? char<=?)) (else - (slib:error 'glob:substitute "bad second argument" templ)))) -(define (glob:substitute-ci?? pat templ) - (cond ((procedure? templ) - (glob:caller-with-matches pat templ char-ci=? char-ci<=?)) - ((string? templ) - (glob:make-substituter pat templ char-ci=? char-ci<=?)) + (slib:error 'filename:substitute?? "bad second argument" template)))) +(define (filename:substitute-ci?? pattern template) + (cond ((procedure? template) + (glob:caller-with-matches pattern template char-ci=? char-ci<=?)) + ((string? template) + (glob:make-substituter pattern template char-ci=? char-ci<=?)) (else - (slib:error 'glob:substitute "bad second argument" templ)))) -(define filename:substitute?? glob:substitute??) -(define filename:substitute-ci?? glob:substitute-ci??) + (slib:error 'filename:substitute-ci?? "bad second argument" template)))) + +;;@example +;;((filename:substitute?? "scm_[0-9]*.html" "scm5c4_??.htm") +;; "scm_10.html") +;;@result{} "scm5c4_10.htm" +;;((filename:substitute?? "??" "beg?mid?end") "AZ") +;;@result{} "begAmidZend" +;;((filename:substitute?? "*na*" "?NA?") "banana") +;;@result{} "banaNA" +;;((filename:substitute?? "?*?" (lambda (s1 s2 s3) (string-append s3 s1))) +;; "ABZ") +;;@result{} "ZA" +;;@end example +;;@body +;;@var{str} can be a string or a list of strings. Returns a new string +;;(or strings) similar to @code{str} but with the suffix string @var{old} +;;removed and the suffix string @var{new} appended. If the end of +;;@var{str} does not match @var{old}, an error is signaled. (define (replace-suffix str old new) (let* ((f (glob:make-substituter (list "*" old) (list "*" new) char=? char<=?)) @@ -222,3 +282,37 @@ (if (pair? str) (map g str) (g str)))) + +;;@example +;;(replace-suffix "/usr/local/lib/slib/batch.scm" ".scm" ".c") +;;@result{} "/usr/local/lib/slib/batch.c" +;;@end example + +;;@args proc k +;;@args proc +;;Calls @1 with @2 arguments, strings returned by successive calls to +;;@code{tmpnam}. +;;If @1 returns, then any files named by the arguments to @1 are +;;deleted automatically and the value(s) yielded by the @1 is(are) +;;returned. @2 may be ommited, in which case it defaults to @code{1}. +;; +;;@args proc suffix1 ... +;;Calls @1 with strings returned by successive calls to @code{tmpnam}, +;;each with the corresponding @var{suffix} string appended. +;;If @1 returns, then any files named by the arguments to @1 are +;;deleted automatically and the value(s) yielded by the @1 is(are) +;;returned. +(define (call-with-tmpnam proc . suffi) + (define (do-call paths) + (let ((ans (apply proc paths))) + (for-each (lambda (path) (if (file-exists? path) (delete-file path))) + paths) + ans)) + (cond ((null? suffi) (do-call (list (tmpnam)))) + ((and (= 1 (length suffi)) (number? (car suffi))) + (do ((cnt (if (null? suffi) 0 (+ -1 (car suffi))) (+ -1 cnt)) + (paths '() (cons (tmpnam) paths))) + ((negative? cnt) + (do-call paths)))) + (else (do-call (map (lambda (suffix) (string-append (tmpnam) suffix)) + suffi))))) diff --git a/glob.txi b/glob.txi new file mode 100644 index 0000000..d83b66b --- /dev/null +++ b/glob.txi @@ -0,0 +1,100 @@ +@code{(require 'filename)} or @code{(require 'glob)} +@ftindex filename +@ftindex glob + + +@defun filename:match?? pattern +@defunx filename:match-ci?? pattern + +Returns a predicate which returns a non-false value if its string argument +matches (the string) @var{pattern}, false otherwise. Filename matching +is like +@cindex glob +@dfn{glob} expansion described the bash manpage, except that names +@cindex glob +beginning with @samp{.} are matched and @samp{/} characters are not +treated specially. + +These functions interpret the following characters specially in +@var{pattern} strings: +@table @samp +@item * +Matches any string, including the null string. +@item ? +Matches any single character. +@item [@dots{}] +Matches any one of the enclosed characters. A pair of characters +separated by a minus sign (-) denotes a range; any character lexically +between those two characters, inclusive, is matched. If the first +character following the @samp{[} is a @samp{!} or a @samp{^} then any +character not enclosed is matched. A @samp{-} or @samp{]} may be +matched by including it as the first or last character in the set. +@end table +@end defun + +@defun filename:substitute?? pattern template +@defunx filename:substitute-ci?? pattern template + +Returns a function transforming a single string argument according to +glob patterns @var{pattern} and @var{template}. @var{pattern} and +@var{template} must have the same number of wildcard specifications, +which need not be identical. @var{pattern} and @var{template} may have +a different number of literal sections. If an argument to the function +matches @var{pattern} in the sense of @code{filename:match??} then it +returns a copy of @var{template} in which each wildcard specification is +replaced by the part of the argument matched by the corresponding +wildcard specification in @var{pattern}. A @code{*} wildcard matches +the longest leftmost string possible. If the argument does not match +@var{pattern} then false is returned. + +@var{template} may be a function accepting the same number of string +arguments as there are wildcard specifications in @var{pattern}. In +the case of a match the result of applying @var{template} to a list +of the substrings matched by wildcard specifications will be returned, +otherwise @var{template} will not be called and @code{#f} will be returned. +@end defun +@example +((filename:substitute?? "scm_[0-9]*.html" "scm5c4_??.htm") + "scm_10.html") +@result{} "scm5c4_10.htm" +((filename:substitute?? "??" "beg?mid?end") "AZ") +@result{} "begAmidZend" +((filename:substitute?? "*na*" "?NA?") "banana") +@result{} "banaNA" +((filename:substitute?? "?*?" (lambda (s1 s2 s3) (string-append s3 s1))) + "ABZ") +@result{} "ZA" +@end example + + +@defun replace-suffix str old new + +@var{str} can be a string or a list of strings. Returns a new string +(or strings) similar to @code{str} but with the suffix string @var{old} +removed and the suffix string @var{new} appended. If the end of +@var{str} does not match @var{old}, an error is signaled. +@end defun +@example +(replace-suffix "/usr/local/lib/slib/batch.scm" ".scm" ".c") +@result{} "/usr/local/lib/slib/batch.c" +@end example + + +@defun call-with-tmpnam proc k + + +@defunx call-with-tmpnam proc +Calls @var{proc} with @var{k} arguments, strings returned by successive calls to +@code{tmpnam}. +If @var{proc} returns, then any files named by the arguments to @var{proc} are +deleted automatically and the value(s) yielded by the @var{proc} is(are) +returned. @var{k} may be ommited, in which case it defaults to @code{1}. + + +@defunx call-with-tmpnam proc suffix1 @dots{} +Calls @var{proc} with strings returned by successive calls to @code{tmpnam}, +each with the corresponding @var{suffix} string appended. +If @var{proc} returns, then any files named by the arguments to @var{proc} are +deleted automatically and the value(s) yielded by the @var{proc} is(are) +returned. +@end defun diff --git a/grapheps.ps b/grapheps.ps new file mode 100644 index 0000000..87658dd --- /dev/null +++ b/grapheps.ps @@ -0,0 +1,344 @@ +%%EndComments +/plotdict 100 dict def +plotdict begin + +% Definitions so that internal assignments are bound before setting. +/DATA 0 def +/DEN 0 def +/DIAG 0 def +/DIAG2 0 def +/DLTA 0 def +/EXPSN 0 def +/GPROCS 0 def +/GD 6 def +/GR 3 def +/IDX 0 def +/ISIZ 0 def +/MAX 0 def +/MIN 0 def +/NUM 0 def +/PLOT-bmargin 0 def +/PLOT-lmargin 0 def +/PLOT-rmargin 0 def +/PLOT-tmargin 0 def +/PROC 0 def +/ROW 0 def +/TXT 0 def +/WPAGE 0 def +/X-COORD 0 def +/XDX 0 def +/XOFF 0 def +/XPARTS 0 def +/XRNG 0 def +/XSCL 0 def +/XSTEP 0 def +/XSTEPH 0 def +/XTSCL 0 def +/XWID 0 def +/Y-COORD 0 def +/YDX 0 def +/YHIT 0 def +/YOFF 0 def +/YPARTS 0 def +/YRNG 0 def +/YSCL 0 def +/YSTEP 0 def +/YSTEPH 0 def +/YTSCL 0 def +/graphrect 0 def +/plotrect 0 def + +% Here are the procedure-arrays for passing as the third argument to +% plot-column. Plot-column moves to the first coordinate before +% calls to the first procedure. Thus both line and scatter graphs are +% supported. Many additional glyph types can be produced as +% combinations of these types. This is best accomplished by calling +% plot-column with each component. + +% GD and GR are the graphic-glyph diameter and radius. +% DIAG and DIAG2, used in /cross are diagonal and twice diagonal. +% gtrans maps x, y coordinates on the stack to 72dpi page coordinates. + +% Render line connecting points +/line [{} {lineto} {}] bind def +/mountain [{currentpoint 2 copy pop bottomedge moveto lineto} + {lineto} + {currentpoint pop bottomedge lineto closepath fill}] bind def +/cloud [{currentpoint 2 copy pop topedge moveto lineto} + {lineto} + {currentpoint pop topedge lineto closepath fill}] bind def +% Render lines from x-axis to points +/impulse [{} {moveto currentpoint pop 0 lineto} {}] bind def +/bargraph [{} {exch GR sub exch 0 exch GD exch rectstroke} {}] bind def + +% Solid round dot. +/disc [{GD setlinewidth 1 setlinecap} + {moveto 0 0 rlineto} {}] bind def +% Minimal point -- invisible if linewidth is 0. +/point [{1 setlinecap} {moveto 0 0 rlineto} {}] bind def +% Square box. +/square [{} {GR sub exch GR sub exch GD dup rectstroke} {}] bind def +% Square box at 45.o +/diamond [{} + {2 copy GR add moveto + GR neg GR neg rlineto GR GR neg rlineto + GR GR rlineto GR neg GR rlineto + closepath} + {}] bind def +% Plus Sign +/plus [{} + { GR sub moveto 0 GD rlineto + GR neg GR neg rmoveto GD 0 rlineto} + {}] bind def +% X Sign +/cross [{/DIAG GR .707 mul def /DIAG2 DIAG 2 mul def} + {exch DIAG sub exch DIAG add moveto DIAG2 dup neg rlineto + DIAG2 neg 0 rmoveto DIAG2 dup rlineto} + {}] bind def +% Triangle pointing upward +/triup [{} + {2 copy GR 1.12 mul add moveto GR neg GR -1.62 mul rlineto + GR 2 mul 0 rlineto GR neg GR 1.62 mul rlineto + closepath} + {}] bind def +% Triangle pointing downward +/tridown [{} + {2 copy GR 1.12 mul sub moveto GR neg GR 1.62 mul rlineto + GR 2 mul 0 rlineto GR neg GR -1.62 mul rlineto + closepath} + {}] bind def +/pentagon [{} + {gsave translate 0 GR moveto 4 {72 rotate 0 GR lineto} repeat + closepath stroke grestore} + {}] bind def +/circle [{stroke} {GR 0 360 arc stroke} {}] bind def + +% ( TITLE ) ( SUBTITLE ) +/title-top +{ dup stringwidth pop -2 div plotrect 0 get plotrect 2 get 2 div add add + plotrect 1 get plotrect 3 get add pointsize .4 mul add moveto show + dup stringwidth pop -2 div plotrect 0 get plotrect 2 get 2 div add add + plotrect 1 get plotrect 3 get add pointsize 1.4 mul add moveto show +} bind def + +% ( TITLE ) ( SUBTITLE ) +/title-bottom +{ dup stringwidth pop -2 div plotrect 0 get plotrect 2 get 2 div add add + plotrect 1 get pointsize -2 mul add moveto show + dup stringwidth pop -2 div plotrect 0 get plotrect 2 get 2 div add add + plotrect 1 get pointsize -1 mul add moveto show +} bind def + +% Plots column K against column J of given two-dimensional ARRAY. +% The arguments are: +% [ ARRAY J K ] J and K are column-indexes into ARRAY +% [ PREAMBLE RENDER POSTAMBLE ] Plotting procedures: +% PREAMBLE - Executed once before plotting row +% RENDER - Called with each pair of coordinates to plot +% POSTAMBLE - Called once after plotting row (often does stroke) +/plot-column +{ /GPROCS exch def aload pop /YDX exch def /XDX exch def /DATA exch def + /GD glyphsize def + /GR GD .5 mul def + gsave + /ROW DATA 0 get def ROW XDX get ROW YDX get gtrans moveto + GPROCS 0 get exec % preamble + /PROC GPROCS 1 get def DATA {dup XDX get exch YDX get gtrans PROC} forall + GPROCS 2 get exec stroke % postamble + grestore +} bind def + +/whole-page +{clippath pathbbox 2 index sub exch 3 index sub exch 4 array astore} bind def + +/partition-page +{ /YPARTS exch def /XPARTS exch def /WPAGE exch def + /XWID WPAGE 2 get XPARTS div def /YHIT WPAGE 3 get YPARTS div def + /Y-COORD WPAGE 1 get def + YPARTS + { /X-COORD WPAGE 0 get WPAGE 2 get add XWID sub def + XPARTS {[X-COORD Y-COORD XWID YHIT] + /X-COORD X-COORD XWID sub def} repeat + /Y-COORD Y-COORD YHIT add def + |