summaryrefslogtreecommitdiffstats
path: root/colornam.scm
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:29 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:29 -0800
commit8466d8cfa486fb30d1755c4261b781135083787b (patch)
treec8c12c67246f543c3cc4f64d1c07e003cb1d45ae /colornam.scm
parent87b82b5822ca54228cfa6df29be3ad9d4bc47d16 (diff)
downloadslib-8466d8cfa486fb30d1755c4261b781135083787b.tar.gz
slib-8466d8cfa486fb30d1755c4261b781135083787b.zip
Import Upstream version 3a1upstream/3a1
Diffstat (limited to 'colornam.scm')
-rw-r--r--colornam.scm117
1 files changed, 117 insertions, 0 deletions
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))))))