← Back to branch summary

~ubuntu-branches/ubuntu/hardy/texmacs/hardy

« back to all changes in this revision

Viewing changes to TeXmacs/progs/convert/tools/tmcolor.scm

  • Committer: Bazaar Package Importer
  • Author(s): Ralf Treinen
  • Date: 2004-04-19 20:34:00 UTC
  • Revision ID: james.westby@ubuntu.com-20040419203400-g4e34ih0315wcn8v
Tags: upstream-1.0.3-R2
Import upstream version 1.0.3-R2

Show diffs side-by-side

added added

removed removed

Lines of Context:
TeXmacs/progs/convert/tools/tmcolor.scm
 
1
 
 
2
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
3
;;
 
4
;; MODULE      : tmtable.scm
 
5
;; DESCRIPTION : tools for converting colors from and to other formats
 
6
;; COPYRIGHT   : (C) 2003  David Allouche
 
7
;;
 
8
;; This software falls under the GNU general public license and comes WITHOUT
 
9
;; ANY WARRANTY WHATSOEVER. See the file $TEXMACS_PATH/LICENSE for details.
 
10
;; If you don't have this file, write to the Free Software Foundation, Inc.,
 
11
;; 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 
12
;;
 
13
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
14
 
 
15
(texmacs-module (convert tools tmcolor)
 
16
  (:export tmcolor tmcolor? rgb255->tmcolor stm->tmcolor tmcolor->stm))
 
17
 
 
18
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
19
;; Internal record utilities
 
20
 
 
21
(define tmcolor-type (make-record-type
 
22
                      "tmcolor" '(name-promise red green blue)))
 
23
(define tmcolor-record (record-constructor tmcolor-type))
 
24
(define tmcolor-name-promise (record-accessor tmcolor-type 'name-promise))
 
25
 
 
26
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
27
;; Accessors
 
28
 
 
29
(define tmcolor? (record-predicate tmcolor-type))
 
30
(define tmcolor-red (record-accessor tmcolor-type 'red))
 
31
(define tmcolor-green (record-accessor tmcolor-type 'green))
 
32
(define tmcolor-blue (record-accessor tmcolor-type 'blue))
 
33
(define (tmcolor-name c) (force (tmcolor-name-promise c)))
 
34
 
 
35
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
36
;; Constructors
 
37
 
 
38
(define (tmcolor red green blue)
 
39
  (for-each check-tmcolor-range (list red green blue))
 
40
  (tmcolor-record (delay (tmcolor-closest-name
 
41
                          (tmcolor-record #f red green blue)))
 
42
                  red green blue))
 
43
 
 
44
(define (rgb255->tmcolor rgb255)
 
45
  (apply tmcolor (map (cut / <> 255) rgb255)))
 
46
 
 
47
(define (check-tmcolor-range n)
 
48
  ;; Helper argument checking procedure
 
49
  (check-arg-range (lambda (n) (and (<= 0 n) (<= n 1)))
 
50
                   (check-arg-type number? n "tmcolor")
 
51
                   "tmcolor"))
 
52
 
 
53
(define (stm->tmcolor name)
 
54
  (let ((c (list-any (lambda (c) (== name (tmcolor-name c)))
 
55
                     texmacs-colors)))
 
56
    (if (not c) (texmacs-error "stm->tmcolor" "Bad color name: ~S" name))
 
57
    c))
 
58
 
 
59
(define tmcolor->stm tmcolor-name)
 
60
 
 
61
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
62
;; Finding name closest to an arbitrary color
 
63
 
 
64
(define (named-tmcolor name red green blue)
 
65
  (for-each check-tmcolor-range (list red green blue))
 
66
  (tmcolor-record (delay name) red green blue))
 
67
 
 
68
(define (named-rgb255->tmcolor name rgb255)
 
69
  (with (red green blue) (map (cut / <> 255) rgb255)
 
70
    (named-tmcolor name red green blue)))
 
71
 
 
72
(define pastel 223)
 
73
(define dark-pastel (- (* 2 pastel) 255))
 
74
(define texmacs-colors
 
75
  (map
 
76
   (cut apply named-rgb255->tmcolor <>)
 
77
   `(("black" (0 0 0)) ("white" (255 255 255)) ("grey" (184 184 184))
 
78
     ("red" (255 0 0)) ("blue" (0 0 255)) ("yellow" (255 255 0))
 
79
     ("green" (0 255 0)) ("magenta" (255 0 255)) ("cyan" (0 255 255))
 
80
     ("orange" (255 128 0)) ("brown" (128 32 0)) ("pink" (255 128 128))
 
81
     ("broken white" (255 255 ,pastel)) ("light grey" (208 208 208))
 
82
     ("dark grey" (112 112 112)) ("dark red" (128 0 0)) ("dark blue" (0 0 128))
 
83
     ("dark yellow" (128 128 0)) ("dark green" (0 128 0))
 
84
     ("dark magenta" (128 0 128)) ("dark cyan" (0 128 128))
 
85
     ("dark orange" (128 64 0)) ("dark brown" (64 16 0))
 
86
     ("pastel grey" (,pastel ,pastel ,pastel))
 
87
     ("pastel red" (255 ,pastel ,pastel)) ("pastel blue" (,pastel ,pastel 255))
 
88
     ("pastel yellow" (255 255 ,pastel)) ("pastel green" (,pastel 255 ,pastel))
 
89
     ("pastel magenta" (255 ,pastel 255)) ("pastel cyan" (,pastel 255 255))
 
90
     ("pastel orange" (255 ,pastel ,dark-pastel))
 
91
     ("pastel brown" (,pastel ,dark-pastel ,dark-pastel)))))
 
92
 
 
93
(define (tmcolor-closest-name c)
 
94
  ((cut <> #f)
 
95
   (list-fold (lambda (kar kdr) (kdr kar))
 
96
              (cut closest-name/step <> c (car texmacs-colors)
 
97
                   (tmcolor-distance c (car texmacs-colors)))
 
98
              (cdr texmacs-colors))))
 
99
 
 
100
(define (closest-name/step candidate goal best best-distance)
 
101
  (if candidate
 
102
      (let ((candidate-distance (tmcolor-distance goal candidate)))
 
103
        (if (< candidate-distance best-distance)
 
104
            (cut closest-name/step <> goal candidate candidate-distance)
 
105
            (cut closest-name/step <> goal best best-distance)))
 
106
      (tmcolor-name best)))
 
107
 
 
108
(define (tmcolor-distance c1 c2)
 
109
  (cartesian-distance (tmcolor->list c1) (tmcolor->list c2)))
 
110
 
 
111
(define (cartesian-distance x1s x2s)
 
112
  (sqrt (list-fold + 0 (map (lambda (x1 x2) (let ((Dx (- x1 x2))) (* Dx Dx)))
 
113
                            x1s x2s))))
 
114
(define (tmcolor->list c)
 
115
  (list (tmcolor-red c) (tmcolor-green c) (tmcolor-blue c)))