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
106
107
108
109
110
111
112
113
114
115
116
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))))))
|
