"Fossies" - the Fresh Open Source Software Archive

Member "slib-3b6/mkclrnam.scm" (2 Feb 2017, 11645 Bytes) of package /linux/privat/slib-3b6.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Lisp source code syntax highlighting (style: standard) with prefixed line numbers. Alternatively you can here view or download the uninterpreted source code file. See also the latest Fossies "Diffs" side-by-side code changes report for "mkclrnam.scm": 3b5_vs_3b6.

    1 ;;; "mkclrnam.scm" create color name databases
    2 ;Copyright 2001, 2002, 2003, 2007, 2008 Aubrey Jaffer
    3 ;
    4 ;Permission to copy this software, to modify it, to redistribute it,
    5 ;to distribute modified versions, and to use it for any purpose is
    6 ;granted, subject to the following restrictions and understandings.
    7 ;
    8 ;1.  Any copy made of this software must include this copyright notice
    9 ;in full.
   10 ;
   11 ;2.  I have made no warranty or representation that the operation of
   12 ;this software will be error-free, and I am under no obligation to
   13 ;provide any services, by way of maintenance, update, or otherwise.
   14 ;
   15 ;3.  In conjunction with products arising from the use of this
   16 ;material, there shall be no use of my name in any advertising,
   17 ;promotional, or sales literature without prior written consent in
   18 ;each case.
   19 
   20 (require 'multiarg-apply)
   21 (require 'string-search)
   22 (require 'line-i/o)
   23 (require 'scanf)
   24 (require 'color)
   25 (require 'color-names)
   26 (require 'databases)
   27 (require-if 'compiling 'filename)
   28 
   29 ;;@subsubheading Dictionary Creation
   30 ;;
   31 ;;@code{(require 'color-database)}
   32 ;;@ftindex color-database
   33 
   34 ;;@args file table-name rdb base-table-type
   35 ;;@args file table-name rdb
   36 ;;
   37 ;;@3 must be an open relational database or a string naming a relational
   38 ;;database file, @2 a symbol, and the string @1 must name an existing
   39 ;;file with colornames and their corresponding xRGB (6-digit hex)
   40 ;;values.  @0 creates a table @2 in @3 and enters the associations found
   41 ;;in @1 into it.
   42 (define (file->color-dictionary file table-name . *db*)
   43   (define rdb (apply open-database! *db*))
   44   (define-tables rdb
   45     `(,table-name
   46       ((name string))
   47       ((color string)
   48        (order ordinal))
   49       ()))
   50   (let ((table ((rdb 'open-table) table-name #t)))
   51     (and table (load-rgb-txt file table))))
   52 
   53 ;;@args url table-name rdb base-table-type
   54 ;;@args url table-name rdb
   55 ;;
   56 ;;@3 must be an open relational database or a string naming a relational
   57 ;;database file and @2 a symbol.  @0 retrieves the resource named by the
   58 ;;string @1 using the @dfn{wget} program; then calls
   59 ;;@code{file->color-dictionary} to enter its associations in @2 in @1.
   60 (define (url->color-dictionary url table-name . rdb)
   61   (require 'filename)
   62   (call-with-tmpnam
   63    (lambda (file)
   64      (system (string-append "wget -c -O" file " -USLIB" *slib-version* " " url))
   65      (apply file->color-dictionary file table-name rdb))))
   66 
   67 (define (load-rgb-txt path color-table)
   68   (cond ((not (file-exists? path))
   69      (slib:error 'load-color-dictionary! 'file-exists? path)))
   70   (write 'load-rgb-txt) (display #\space) (write path) (newline)
   71   (let ((color-table:row-insert (color-table 'row:insert))
   72     (color-table:row-retrieve (color-table 'row:retrieve))
   73     (method-id #f))
   74     (define (floats->rgb . rgbi)
   75       (apply color:sRGB
   76          (map (lambda (x) (inexact->exact (round (* 255 x)))) rgbi)))
   77     (define (parse-rgb-line line)
   78       (let ((rgbx #f) (r #f) (g #f) (b #f)
   79         (ri #f) (gi #f) (bi #f) (name #f) (junk #f) (ans #f))
   80     (define (check-match line color1 . colors)
   81       (cond ((null? colors) (color->string color1))
   82         ((> (CMC:DE* color1 (car colors)) 5.0)
   83          (newline) (display line) (force-output)
   84          (slib:warn (round (CMC:DE* color1 (car colors)))
   85                 'mismatch (color->string color1)
   86                 (color->string (car colors)))
   87          (apply check-match line colors))
   88         (else (apply check-match line colors))))
   89     (for-each
   90      (lambda (method)
   91        (or ans
   92            (let ((try (method line)))
   93          (cond (try (set! ans try)
   94                 (display "**** Using method ")
   95                 (display method-id) (newline)
   96                 (set! parse-rgb-line method))))))
   97      (list
   98       (lambda (line)
   99         (define use #f)
  100         (case (sscanf line "%[^;]; red=%d, green=%d, blue=%d; hex=%6x; %[^.].%s"
  101               name r g b rgbx use junk)
  102           ((6)
  103            (set! method-id 'm6e)
  104            (list (check-match line (xrgb->color rgbx) (color:sRGB r g b))
  105              (color-name:canonicalize name)))
  106           (else #f)))
  107       (lambda (line)
  108         (define en #f) (define fr #f) (define de #f)
  109         (define es #f) (define cz #f) (define hu #f)
  110         (case (sscanf line "#%6x    %[^ ]   %[^ ]   %[^ ]   %[^ ]   %[^ ]   %[^ ]%s"
  111               rgbx en fr de es cz hu junk)
  112           ((7)
  113            (set! method-id 'm77)
  114            (cons (check-match line (xRGB->color rgbx))
  115              (map color-name:canonicalize (list en fr de es cz hu))))
  116           (else #f)))
  117       (lambda (line)
  118         (case (sscanf line " %24[a-zA-Z0-9_ ] %d %d %d %e %e %e %s"
  119               name r g b ri gi bi junk)
  120           ((7)
  121            (set! method-id 'm7)
  122            (list (check-match line (color:sRGB r g b) (floats->rgb ri gi bi))
  123              (color-name:canonicalize name)))
  124           (else #f)))
  125       (lambda (line)
  126         (case (sscanf line " %[a-zA-Z0-9_] %6x %d %d %d %e %e %e %s"
  127               name rgbx r g b ri gi bi junk)
  128           ((8)
  129            (set! method-id 'm8)
  130            (list (check-match line (xrgb->color rgbx)
  131                   (color:sRGB r g b)
  132                   (floats->rgb ri gi bi))
  133              (color-name:canonicalize name)))
  134           (else #f)))
  135       (lambda (line)
  136         (case (sscanf line " %[a-zA-Z0-9] %6x %d,%d,%d" name rgbx r g b)
  137           ((5)
  138            (set! method-id 'm5)
  139            (list (check-match line (xrgb->color rgbx) (color:sRGB r g b))
  140              (color-name:canonicalize name)))
  141           (else #f)))
  142       (lambda (line)
  143         (case (sscanf line " %[- a-zA-Z0-9_'] #%6x %d %d %d %s"
  144               name rgbx r g b junk)
  145           ((6 5)
  146            (set! method-id 'm65)
  147            (list (check-match line (xrgb->color rgbx) (color:sRGB r g b))
  148              (color-name:canonicalize name)))
  149           (else #f)))
  150       (lambda (line)
  151         (case (sscanf line " %d %d %d %[a-zA-Z0-9 ]%s" r g b name junk)
  152           ((4) (set! method-id 'm4a)
  153            (list (check-match line (color:sRGB r g b))
  154              (color-name:canonicalize name)))
  155           (else #f)))
  156       (lambda (line)
  157         (case (sscanf line "bang %d %d %d %d %[a-zA-Z0-9, ]%s"
  158               r g b ri name junk)
  159           ((5) (set! method-id 'm5b)
  160            (list (check-match line (color:sRGB r g b))
  161              (color-name:canonicalize name)))
  162           (else #f)))
  163       (lambda (line)
  164         (case (sscanf line " %[- a-zA-Z.] %d %d %d %s"
  165               name r g b junk)
  166           ((4) (set! method-id 'm4b)
  167            (list (check-match line (color:sRGB r g b))
  168              (color-name:canonicalize name)))
  169           (else #f)))
  170       (lambda (line)
  171         (case (sscanf line "\" Resene %[^\"]\" %d %d %d %s"
  172               name r g b junk)
  173           ((4) (set! method-id 'm4d)
  174            (list (check-match line (color:sRGB r g b))
  175              (color-name:canonicalize name)))
  176           (else #f)))
  177       (lambda (line)
  178         (case (sscanf line "\" %[^\"]\" %d %d %d %s"
  179               name r g b junk)
  180           ((4) (set! method-id 'm4c)
  181            (list (check-match line (color:sRGB r g b))
  182              (color-name:canonicalize name)))
  183           (else #f)))
  184       (lambda (line)
  185         (case (sscanf line " %[a-zA-Z()] %e %e %e %s"
  186               name ri gi bi junk)
  187           ((4) (set! method-id 'm4e)
  188            (list (check-match line (color:L*a*b* ri gi bi))
  189              (color-name:canonicalize
  190               (string-downcase! (StudlyCapsExpand name " ")))))
  191           (else #f)))
  192       (lambda (line)
  193         (case (sscanf line " %[a-zA-Z0-9_] #%6x%s" name rgbx junk)
  194           ((2) (set! method-id 'm2a)
  195            (list (check-match line (xrgb->color rgbx))
  196              (color-name:canonicalize name)))
  197           (else #f)))
  198       (lambda (line)
  199         (case (sscanf line "[\"%6x\", \"%[^\"]\"], %s" rgbx name junk)
  200           ((2) (set! method-id 'js)
  201            (list (check-match line (xrgb->color rgbx))
  202              (color-name:canonicalize name)))
  203           (else #f)))
  204       (lambda (line)
  205         (case (sscanf line "%[- a-zA-Z']=#%6x<br>" name rgbx)
  206           ((2) (set! method-id 'm2b)
  207            (let ((idx (substring? "rgb" name)))
  208          (and (eqv? idx (+ -3 (string-length name)))
  209               (list (check-match line (xrgb->color rgbx))
  210                 (color-name:canonicalize (substring name 0 idx))))))
  211           (else #f)))
  212       (lambda (line)
  213         (case (sscanf line "%[ a-zA-Z/'] #%6x" name rgbx)
  214           ((2) (set! method-id 'm2d)
  215            (list (check-match line (xrgb->color rgbx))
  216              (color-name:canonicalize name)))
  217           (else #f)))
  218       (lambda (line)
  219         (case (sscanf line "\" %[^\"]\" %s" name junk)
  220           ((2) (set! method-id 'm2c)
  221            (let ((clr (string->color junk)))
  222          (and clr (list (check-match line clr)
  223                 (color-name:canonicalize name)))))
  224           (else #f)))
  225       (lambda (line)
  226         (case (sscanf line "%[a-z0-9 ]\t%[A-Z]:%[./0-9] %s"
  227               name r rgbx junk)
  228           ((3) (set! method-id 'm3x)
  229            (list (check-match line (string->color
  230                     (string-append r ":" rgbx)))
  231              (color-name:canonicalize name)))
  232           (else #f)))
  233       (lambda (line)
  234         ;; FED-STD-595C - read only the first
  235         (case (sscanf line "%5[0-9] %[A-Za-z]:%f/%f/%f"
  236               name ri r g b)
  237           ((5) (set! method-id 'm5x)
  238            (cond ((string-ci=? "CIEXYZ" ri)
  239               (list (check-match line (color:CIEXYZ (/ r 100)
  240                                 (/ g 100)
  241                                 (/ b 100)))
  242                 (color-name:canonicalize name)))
  243              ((string-ci=? "CIELAB" ri)
  244               (list (check-match line (color:L*A*B* r g b))
  245                 (color-name:canonicalize name)))
  246              (else #f)))
  247           (else #f)))
  248       ))
  249     ans))
  250     (define (numbered-gray? str)
  251       (define idx #f)
  252       (and (or (eqv? 0 (substring-ci? "gray" str))
  253            (eqv? 0 (substring-ci? "grey" str)))
  254        (eqv? 1 (sscanf (substring str 4 (string-length str))
  255                "%d%s" idx str))))
  256     (call-with-input-file path
  257       (lambda (port)
  258     (define *idx* 0)
  259     (define *rcs-header* (read-line port))
  260     (do ((line (read-line port) (read-line port)))
  261         ((eof-object? line)
  262          (display "Inserted ") (display *idx*) (display " colors") (newline)
  263          *rcs-header*)
  264       (let ((colin (parse-rgb-line line)))
  265         (cond ((equal? "" line))
  266           ;;((char=? #\# (string-ref line 0)))
  267           ((not colin) (write-line line))
  268           ((numbered-gray? (cadr colin)))
  269           (else
  270            (for-each
  271             (lambda (name)
  272               (let ((oclin (color-table:row-retrieve name)))
  273             (cond
  274              ((and oclin (equal? (car colin) (cadr oclin))))
  275              ((not oclin)
  276               (set! *idx* (+ 1 *idx*))
  277               (color-table:row-insert
  278                (list name (car colin) *idx*)))
  279              (else (slib:warn 'collision colin oclin)))))
  280             (cdr colin))))))))))
  281 
  282 ;;@noindent
  283 ;;This section has detailed the procedures for creating and loading
  284 ;;color dictionaries.  So where are the dictionaries to load?
  285 ;;
  286 ;;@uref{http://people.csail.mit.edu/jaffer/Color/Dictionaries.html}
  287 ;;
  288 ;;@noindent
  289 ;;Describes and evaluates several color-name dictionaries on the web.
  290 ;;The following procedure creates a database containing two of these
  291 ;;dictionaries.
  292 
  293 ;;@body
  294 ;;Creates an @r{alist-table} relational database in @r{library-vicinity}
  295 ;;containing the @dfn{Resene} and @dfn{saturate} color-name
  296 ;;dictionaries.
  297 ;;
  298 ;;If the files @file{resenecolours.txt}, @file{nbs-iscc.txt}, and
  299 ;;@file{saturate.txt} exist in the @r{library-vicinity}, then they
  300 ;;used as the source of color-name data.  Otherwise, @0 calls
  301 ;;url->color-dictionary with the URLs of appropriate source files.
  302 (define (make-slib-color-name-db)
  303   (define cndb (create-database (in-vicinity (library-vicinity) "clrnamdb.scm")
  304                 'alist-table))
  305   (or cndb (slib:error 'cannot 'create 'database "clrnamdb.scm"))
  306   (for-each
  307    (lambda (lst)
  308      (apply
  309       (lambda (url path name)
  310     (define filename (in-vicinity (library-vicinity) path))
  311     (if (file-exists? filename)
  312         (file->color-dictionary filename name cndb)
  313         (url->color-dictionary url name cndb)))
  314       lst))
  315    '(("http://people.csail.mit.edu/jaffer/Color/saturate.txt"
  316       "saturate.txt"
  317       saturate)
  318      ("http://people.csail.mit.edu/jaffer/Color/resenecolours.txt"
  319       "resenecolours.txt"
  320       resene)
  321      ("http://people.csail.mit.edu/jaffer/Color/nbs-iscc.txt"
  322       "nbs-iscc.txt"
  323       nbs-iscc)))
  324   (close-database cndb))