aboutsummaryrefslogtreecommitdiffstats
path: root/mkclrnam.scm
diff options
context:
space:
mode:
Diffstat (limited to 'mkclrnam.scm')
-rw-r--r--mkclrnam.scm259
1 files changed, 259 insertions, 0 deletions
diff --git a/mkclrnam.scm b/mkclrnam.scm
new file mode 100644
index 0000000..7377f37
--- /dev/null
+++ b/mkclrnam.scm
@@ -0,0 +1,259 @@
+;;; "mkclrnam.scm" create color name databases
+;Copyright 2001, 2002, 2003 Aubrey Jaffer
+;
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
+;
+;1. Any copy made of this software must include this copyright notice
+;in full.
+;
+;2. I have made no warranty or representation that the operation of
+;this software will be error-free, and I am under no obligation to
+;provide any services, by way of maintenance, update, or otherwise.
+;
+;3. In conjunction with products arising from the use of this
+;material, there shall be no use of my name in any advertising,
+;promotional, or sales literature without prior written consent in
+;each case.
+
+(require 'string-search)
+(require 'line-i/o)
+(require 'scanf)
+(require 'color)
+(require 'color-names)
+(require 'databases)
+(require-if 'compiling 'filename)
+
+;;@subsubheading Dictionary Creation
+;;
+;;@code{(require 'color-database)}
+;;@ftindex color-database
+
+;;@args file table-name rdb base-table-type
+;;@args file table-name rdb
+;;
+;;@3 must be an open relational database or a string naming a relational
+;;database file, @2 a symbol, and the string @1 must name an existing
+;;file with colornames and their corresponding xRGB (6-digit hex)
+;;values. @0 creates a table @2 in @3 and enters the associations found
+;;in @1 into it.
+(define (file->color-dictionary file table-name . *db*)
+ (define rdb (apply open-database! *db*))
+ (define-tables rdb
+ `(,table-name
+ ((name string))
+ ((color string)
+ (order ordinal))
+ ()))
+ (let ((table ((rdb 'open-table) table-name #t)))
+ (and table (load-rgb-txt file table))))
+
+;;@args url table-name rdb base-table-type
+;;@args url table-name rdb
+;;
+;;@3 must be an open relational database or a string naming a relational
+;;database file and @2 a symbol. @0 retrieves the resource named by the
+;;string @1 using the @dfn{wget} program; then calls
+;;@code{file->color-dictionary} to enter its associations in @2 in @1.
+(define (url->color-dictionary url table-name . rdb)
+ (require 'filename)
+ (call-with-tmpnam
+ (lambda (file)
+ (system (string-append "wget -c -O" file " -USLIB" *SLIB-VERSION* " " url))
+ (apply file->color-dictionary file table-name rdb))))
+
+(define (load-rgb-txt path color-table)
+ (cond ((not (file-exists? path))
+ (slib:error 'load-color-dictionary! 'file-exists? path)))
+ (write 'load-rgb-txt) (display #\ ) (write path) (newline)
+ (let ((color-table:row-insert (color-table 'row:insert))
+ (color-table:row-retrieve (color-table 'row:retrieve))
+ (method-id #f))
+ (define (floats->rgb . rgbi)
+ (apply color:sRGB
+ (map (lambda (x) (inexact->exact (round (* 255 x)))) rgbi)))
+ (define (parse-rgb-line line)
+ (let ((rgbx #f) (r #f) (g #f) (b #f)
+ (ri #f) (gi #f) (bi #f) (name #f) (junk #f) (ans #f))
+ (define (check-match line color1 . colors)
+ (cond ((null? colors) (color->string color1))
+ ((> (CMC:DE* color1 (car colors)) 5.0)
+ (newline) (display line) (force-output)
+ (slib:warn (round (CMC:DE* color1 (car colors)))
+ 'mismatch (color->string color1)
+ (color->string (car colors)))
+ (apply check-match line colors))
+ (else (apply check-match line colors))))
+ (for-each
+ (lambda (method)
+ (or ans
+ (let ((try (method line)))
+ (cond (try (set! ans try)
+ (display "**** Using method ")
+ (display method-id) (newline)
+ (set! parse-rgb-line method))))))
+ (list
+ (lambda (line)
+ (define en #f) (define fr #f) (define de #f)
+ (define es #f) (define cz #f) (define hu #f)
+ (case (sscanf line "#%6x %[^ ] %[^ ] %[^ ] %[^ ] %[^ ] %[^ ]%s"
+ rgbx en fr de es cz hu junk)
+ ((7)
+ (set! method-id 'm77)
+ (cons (check-match line (xRGB->color rgbx))
+ (map color-name:canonicalize (list en fr de es cz hu))))
+ (else #f)))
+ (lambda (line)
+ (case (sscanf line " %24[a-zA-Z0-9_ ] %d %d %d %e %e %e %s"
+ name r g b ri gi bi junk)
+ ((7)
+ (set! method-id 'm7)
+ (list (check-match line (color:sRGB r g b) (floats->rgb ri gi bi))
+ (color-name:canonicalize name)))
+ (else #f)))
+ (lambda (line)
+ (case (sscanf line " %[a-zA-Z0-9_] %6x %d %d %d %e %e %e %s"
+ name rgbx r g b ri gi bi junk)
+ ((8)
+ (set! method-id 'm8)
+ (list (check-match line (xrgb->color rgbx)
+ (color:sRGB r g b)
+ (floats->rgb ri gi bi))
+ (color-name:canonicalize name)))
+ (else #f)))
+ (lambda (line)
+ (case (sscanf line " %[a-zA-Z0-9] %6x %d,%d,%d" name rgbx r g b)
+ ((5)
+ (set! method-id 'm5)
+ (list (check-match line (xrgb->color rgbx) (color:sRGB r g b))
+ (color-name:canonicalize name)))
+ (else #f)))
+ (lambda (line)
+ (case (sscanf line " %[- a-zA-Z0-9_'] #%6x %d %d %d %s"
+ name rgbx r g b junk)
+ ((6 5)
+ (set! method-id 'm65)
+ (list (check-match line (xrgb->color rgbx) (color:sRGB r g b))
+ (color-name:canonicalize name)))
+ (else #f)))
+ (lambda (line)
+ (case (sscanf line " %d %d %d %[a-zA-Z0-9 ]%s" r g b name junk)
+ ((4) (set! method-id 'm4a)
+ (list (check-match line (color:sRGB r g b))
+ (color-name:canonicalize name)))
+ (else #f)))
+ (lambda (line)
+ (case (sscanf line " %[- a-zA-Z.] %d %d %d %s"
+ name r g b junk)
+ ((4) (set! method-id 'm4b)
+ (list (check-match line (color:sRGB r g b))
+ (color-name:canonicalize name)))
+ (else #f)))
+ (lambda (line)
+ (case (sscanf line "\" Resene %[^\"]\" %d %d %d %s"
+ name r g b junk)
+ ((4) (set! method-id 'm4b)
+ (list (check-match line (color:sRGB r g b))
+ (color-name:canonicalize name)))
+ (else #f)))
+ (lambda (line)
+ (case (sscanf line "\" %[^\"]\" %d %d %d %s"
+ name r g b junk)
+ ((4) (set! method-id 'm4c)
+ (list (check-match line (color:sRGB r g b))
+ (color-name:canonicalize name)))
+ (else #f)))
+ (lambda (line)
+ (case (sscanf line " %[a-zA-Z0-9_] #%x%6x%s" name rgbx junk)
+ ((2) (set! method-id 'm2a)
+ (list (check-match line (xrgb->color rgbx))
+ (color-name:canonicalize name)))
+ (else #f)))
+ (lambda (line)
+ (case (sscanf line "%[- a-zA-Z']=#%6x<br>" name rgbx)
+ ((2) (set! method-id 'm2b)
+ (let ((idx (substring? "rgb" name)))
+ (and (eqv? idx (+ -3 (string-length name)))
+ (list (check-match line (xrgb->color rgbx))
+ (color-name:canonicalize (substring name 0 idx))))))
+ (else #f)))
+ (lambda (line)
+ (case (sscanf line "\" %[^\"]\" %s" name junk)
+ ((2) (set! method-id 'm2c)
+ (let ((clr (string->color junk)))
+ (and clr (list (check-match line clr)
+ (color-name:canonicalize name)))))
+ (else #f)))))
+ ans))
+ (define (numbered-gray? str)
+ (define idx #f)
+ (and (or (eqv? 0 (substring-ci? "gray" str))
+ (eqv? 0 (substring-ci? "grey" str)))
+ (eqv? 1 (sscanf (substring str 4 (string-length str))
+ "%d%s" idx str))))
+ (call-with-input-file path
+ (lambda (port)
+ (define *idx* 0)
+ (define *rcs-header* (read-line port))
+ (do ((line (read-line port) (read-line port)))
+ ((eof-object? line)
+ (display "Inserted ") (display *idx*) (display "colors") (newline)
+ *rcs-header*)
+ (let ((colin (parse-rgb-line line)))
+ (cond ((equal? "" line))
+ ;;((char=? #\# (string-ref line 0)))
+ ((not colin) (write-line line))
+ ((numbered-gray? (cadr colin)))
+ (else
+ (for-each
+ (lambda (name)
+ (let ((oclin (color-table:row-retrieve name)))
+ (cond
+ ((and oclin (equal? (car colin) (cadr oclin))))
+ ((not oclin)
+ (set! *idx* (+ 1 *idx*))
+ (color-table:row-insert
+ (list name (car colin) *idx*)))
+ (else (slib:warn 'collision name oclin)))))
+ (cdr colin))))))))))
+
+;;@noindent
+;;This section has detailed the procedures for creating and loading
+;;color dictionaries. So where are the dictionaries to load?
+;;
+;;@uref{http://swissnet.ai.mit.edu/~jaffer/Color/Dictionaries.html}
+;;
+;;@noindent
+;;Describes and evaluates several color-name dictionaries on the web.
+;;The following procedure creates a database containing two of these
+;;dictionaries.
+
+;;@body
+;;Creates an @r{alist-table} relational database in @r{library-vicinity}
+;;containing the @dfn{Resene} and @dfn{saturate} color-name
+;;dictionaries.
+;;
+;;If the files @file{resenecolours.txt} and @file{saturate.txt} exist in
+;;the @r{library-vicinity}, then they used as the source of color-name
+;;data. Otherwise, @0 calls url->color-dictionary with the URLs of
+;;appropriate source files.
+(define (make-slib-color-name-db)
+ (define cndb (create-database (in-vicinity (library-vicinity) "clrnamdb.scm")
+ 'alist-table))
+ (for-each
+ (lambda (lst)
+ (apply
+ (lambda (url path name)
+ (define filename (in-vicinity (library-vicinity) path))
+ (if (file-exists? filename)
+ (file->color-dictionary filename name cndb)
+ (url->color-dictionary url name cndb)))
+ lst))
+ '(("http://swissnet.ai.mit.edu/~jaffer/Color/saturate.txt"
+ "saturate.txt"
+ saturate)
+ ("http://swissnet.ai.mit.edu/~jaffer/Color/resenecolours.txt"
+ "resenecolours.txt"
+ resene)))
+ (close-database cndb))