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
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
|
(***********************************************************************)
(* *)
(* HEVEA *)
(* *)
(* Luc Maranget, projet PARA, INRIA Rocquencourt *)
(* *)
(* Copyright 1998 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
(***********************************************************************)
type t = Name of string | Hex of string
let default_color = Name "black"
;;
let table = (Hashtbl.create 17 : (string, t) Hashtbl.t)
;;
type saved = (string, t) Hashtbl.t
let checkpoint () =
let ctable = Hashtbl.create 17 in
Misc.copy_hashtbl table ctable ;
ctable
and hot_start ctable = Misc.copy_hashtbl ctable table
let to_hex x =
Printf.sprintf "%02X" (truncate (255.0 *. x))
;;
let cmyk_to_rgb c m y k =
1.0 -. min 1.0 (c *. (1.0 -. k) +. k),
1.0 -. min 1.0 (m *. (1.0 -. k) +. k),
1.0 -. min 1.0 (y *. (1.0 -. k) +. k)
;;
let hls_to_rgb h l s =
let rgb q1 q2 hue =
let hue =
if hue > 360.0 then hue -. 360.0
else if hue < 0.0 then hue +. 360.0
else hue in
if hue < 60.0 then
q1 +. (q2 -. q1) /. 60.0
else if hue < 180.0 then
q2
else if hue < 240.0 then
q1 +. (q2 -. q1) *. (240.0 -. hue) /. 60.0
else
q1 in
let p2 =
if l <= 0.5 then l *. (1.0 +. s)
else l +. s -. (l *. s) in
let p1 = 2.0 *. l -. p2 in
if s = 0.0 then
l,l,l
else
rgb p1 p2 (h +. 100.0),
rgb p1 p2 h,
rgb p1 p2 (h -. 120.0)
;;
let hsv_to_rgb h s v =
if s = 0.0 then v,v,v
else
let h = h /. 60.0 in
let i = truncate h in
let f = h -. float i in
let p = v *. (1.0 -. s) in
let q = v *. (1.0 -. (s *. f)) in
let t = v *. (1.0 -. (s *. (1.0 -. f))) in
match i with
| 0 -> v,t,p
| 1 -> q,v,p
| 2 -> p,v,t
| 3 -> p,q,v
| 4 -> t,p,v
| 5 -> v,p,q
| _ -> Misc.fatal ("Bad HSV color specification")
;;
exception Failed
;;
let names = Hashtbl.create 17
let _ =
List.iter
(fun (xx,name) -> Hashtbl.add names xx name)
[ "000000", "black" ;
"C0C0C0", "silver" ;
"808080", "gray" ;
"FFFFFF", "white" ;
"800000", "maroon" ;
"FF0000", "red" ;
"800080", "purple" ;
"FF00FF", "fuchsia" ;
"008000", "green" ;
"00FF00", "lime" ;
"808000", "olive" ;
"FFFF00", "yellow" ;
"000080", "navy" ;
"0000FF", "blue" ;
"008080", "teal" ;
"00FFFF", "aqua" ;
]
let do_compute mdl value =
match mdl with
| "named" ->
begin
try Hashtbl.find table ("named@"^value) with
| Not_found -> begin
Misc.warning ("Unknown name in the named color model: "^value) ;
raise Failed
end
end
| _ ->
let res = match mdl with
| "gray" ->
let x = Colscan.one (MyLexing.from_string value) in
let xx = to_hex x in
xx^xx^xx
| "rgb" ->
let r,g,b = Colscan.three(MyLexing.from_string value) in
to_hex r^to_hex g^to_hex b
| "cmyk" ->
let c,m,y,k = Colscan.four (MyLexing.from_string value) in
let r,g,b = cmyk_to_rgb c m y k in
to_hex r^to_hex g^to_hex b
| "hsv" ->
let h,s,v = Colscan.three (MyLexing.from_string value) in
let r,g,b = hsv_to_rgb h s v in
to_hex r^to_hex g^to_hex b
| "hls" ->
let h,l,s = Colscan.three (MyLexing.from_string value) in
let r,g,b = hls_to_rgb h l s in
to_hex r^to_hex g^to_hex b
| _ ->
Misc.warning ("Color.compute, unknown color model: "^mdl);
raise Failed in
try
Name (Hashtbl.find names res)
with Not_found -> Hex res
let compute mdl value =
try do_compute mdl value with Failed -> default_color
let define clr mdl value =
try
Hashtbl.add table clr (do_compute mdl value)
with Failed -> ()
;;
let retrieve clr =
try
Hashtbl.find table clr
with Not_found ->
Misc.warning ("Color.retrieve, unknown color: "^clr);
default_color
;;
let define_named name mdl value = define ("named@"^name) mdl value
;;
let remove clr = Hashtbl.remove table clr
|
