diff options
Diffstat (limited to 'src/bigloo/color.scm')
| -rw-r--r-- | src/bigloo/color.scm | 702 |
1 files changed, 702 insertions, 0 deletions
diff --git a/src/bigloo/color.scm b/src/bigloo/color.scm new file mode 100644 index 0000000..e40638b --- /dev/null +++ b/src/bigloo/color.scm @@ -0,0 +1,702 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/color.scm */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Wed Apr 10 13:46:50 2002 */ +;* Last change : Wed Jan 7 11:39:58 2004 (serrano) */ +;* Copyright : 2002-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Tex color manager */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_color + (import skribe_configure) + (export (skribe-color->rgb ::obj) + (skribe-get-used-colors) + (skribe-use-color! color))) + +;*---------------------------------------------------------------------*/ +;* *skribe-rgb-string* ... */ +;*---------------------------------------------------------------------*/ +(define *skribe-rgb-string* + "255 250 250 snow +248 248 255 ghostwhite +245 245 245 whitesmoke +220 220 220 gainsboro +255 250 240 floralwhite +253 245 230 oldlace +250 240 230 linen +250 235 215 antiquewhite +255 239 213 papayawhip +255 235 205 blanchedalmond +255 228 196 bisque +255 218 185 peachpuff +255 222 173 navajowhite +255 228 181 moccasin +255 248 220 cornsilk +255 255 240 ivory +255 250 205 lemonchiffon +255 245 238 seashell +240 255 240 honeydew +245 255 250 mintcream +240 255 255 azure +240 248 255 aliceblue +230 230 250 lavender +255 240 245 lavenderblush +255 228 225 mistyrose +255 255 255 white +0 0 0 black +47 79 79 darkslategrey +105 105 105 dimgrey +112 128 144 slategrey +119 136 153 lightslategrey +190 190 190 grey +211 211 211 lightgrey +25 25 112 midnightblue +0 0 128 navy +0 0 128 navyblue +100 149 237 cornflowerblue +72 61 139 darkslateblue +106 90 205 slateblue +123 104 238 mediumslateblue +132 112 255 lightslateblue +0 0 205 mediumblue +65 105 225 royalblue +0 0 255 blue +30 144 255 dodgerblue +0 191 255 deepskyblue +135 206 235 skyblue +135 206 250 lightskyblue +70 130 180 steelblue +176 196 222 lightsteelblue +173 216 230 lightblue +176 224 230 powderblue +175 238 238 paleturquoise +0 206 209 darkturquoise +72 209 204 mediumturquoise +64 224 208 turquoise +0 255 255 cyan +224 255 255 lightcyan +95 158 160 cadetblue +102 205 170 mediumaquamarine +127 255 212 aquamarine +0 100 0 darkgreen +85 107 47 darkolivegreen +143 188 143 darkseagreen +46 139 87 seagreen +60 179 113 mediumseagreen +32 178 170 lightseagreen +152 251 152 palegreen +0 255 127 springgreen +124 252 0 lawngreen +0 255 0 green +127 255 0 chartreuse +0 250 154 mediumspringgreen +173 255 47 greenyellow +50 205 50 limegreen +154 205 50 yellowgreen +34 139 34 forestgreen +107 142 35 olivedrab +189 183 107 darkkhaki +240 230 140 khaki +238 232 170 palegoldenrod +250 250 210 lightgoldenrodyellow +255 255 224 lightyellow +255 255 0 yellow +255 215 0 gold +238 221 130 lightgoldenrod +218 165 32 goldenrod +184 134 11 darkgoldenrod +188 143 143 rosybrown +205 92 92 indianred +139 69 19 saddlebrown +160 82 45 sienna +205 133 63 peru +222 184 135 burlywood +245 245 220 beige +245 222 179 wheat +244 164 96 sandybrown +210 180 140 tan +210 105 30 chocolate +178 34 34 firebrick +165 42 42 brown +233 150 122 darksalmon +250 128 114 salmon +255 160 122 lightsalmon +255 165 0 orange +255 140 0 darkorange +255 127 80 coral +240 128 128 lightcoral +255 99 71 tomato +255 69 0 orangered +255 0 0 red +255 105 180 hotpink +255 20 147 deeppink +255 192 203 pink +255 182 193 lightpink +219 112 147 palevioletred +176 48 96 maroon +199 21 133 mediumvioletred +208 32 144 violetred +255 0 255 magenta +238 130 238 violet +221 160 221 plum +218 112 214 orchid +186 85 211 mediumorchid +153 50 204 darkorchid +148 0 211 darkviolet +138 43 226 blueviolet +160 32 240 purple +147 112 219 mediumpurple +216 191 216 thistle +255 250 250 snow1 +238 233 233 snow2 +205 201 201 snow3 +139 137 137 snow4 +255 245 238 seashell1 +238 229 222 seashell2 +205 197 191 seashell3 +139 134 130 seashell4 +255 239 219 antiquewhite1 +238 223 204 antiquewhite2 +205 192 176 antiquewhite3 +139 131 120 antiquewhite4 +255 228 196 bisque1 +238 213 183 bisque2 +205 183 158 bisque3 +139 125 107 bisque4 +255 218 185 peachpuff1 +238 203 173 peachpuff2 +205 175 149 peachpuff3 +139 119 101 peachpuff4 +255 222 173 navajowhite1 +238 207 161 navajowhite2 +205 179 139 navajowhite3 +139 121 94 navajowhite4 +255 250 205 lemonchiffon1 +238 233 191 lemonchiffon2 +205 201 165 lemonchiffon3 +139 137 112 lemonchiffon4 +255 248 220 cornsilk1 +238 232 205 cornsilk2 +205 200 177 cornsilk3 +139 136 120 cornsilk4 +255 255 240 ivory1 +238 238 224 ivory2 +205 205 193 ivory3 +139 139 131 ivory4 +240 255 240 honeydew1 +224 238 224 honeydew2 +193 205 193 honeydew3 +131 139 131 honeydew4 +255 240 245 lavenderblush1 +238 224 229 lavenderblush2 +205 193 197 lavenderblush3 +139 131 134 lavenderblush4 +255 228 225 mistyrose1 +238 213 210 mistyrose2 +205 183 181 mistyrose3 +139 125 123 mistyrose4 +240 255 255 azure1 +224 238 238 azure2 +193 205 205 azure3 +131 139 139 azure4 +131 111 255 slateblue1 +122 103 238 slateblue2 +105 89 205 slateblue3 +71 60 139 slateblue4 +72 118 255 royalblue1 +67 110 238 royalblue2 +58 95 205 royalblue3 +39 64 139 royalblue4 +0 0 255 blue1 +0 0 238 blue2 +0 0 205 blue3 +0 0 139 blue4 +30 144 255 dodgerblue1 +28 134 238 dodgerblue2 +24 116 205 dodgerblue3 +16 78 139 dodgerblue4 +99 184 255 steelblue1 +92 172 238 steelblue2 +79 148 205 steelblue3 +54 100 139 steelblue4 +0 191 255 deepskyblue1 +0 178 238 deepskyblue2 +0 154 205 deepskyblue3 +0 104 139 deepskyblue4 +135 206 255 skyblue1 +126 192 238 skyblue2 +108 166 205 skyblue3 +74 112 139 skyblue4 +176 226 255 lightskyblue1 +164 211 238 lightskyblue2 +141 182 205 lightskyblue3 +96 123 139 lightskyblue4 +202 225 255 lightsteelblue1 +188 210 238 lightsteelblue2 +162 181 205 lightsteelblue3 +110 123 139 lightsteelblue4 +191 239 255 lightblue1 +178 223 238 lightblue2 +154 192 205 lightblue3 +104 131 139 lightblue4 +224 255 255 lightcyan1 +209 238 238 lightcyan2 +180 205 205 lightcyan3 +122 139 139 lightcyan4 +187 255 255 paleturquoise1 +174 238 238 paleturquoise2 +150 205 205 paleturquoise3 +102 139 139 paleturquoise4 +152 245 255 cadetblue1 +142 229 238 cadetblue2 +122 197 205 cadetblue3 +83 134 139 cadetblue4 +0 245 255 turquoise1 +0 229 238 turquoise2 +0 197 205 turquoise3 +0 134 139 turquoise4 +0 255 255 cyan1 +0 238 238 cyan2 +0 205 205 cyan3 +0 139 139 cyan4 +127 255 212 aquamarine1 +118 238 198 aquamarine2 +102 205 170 aquamarine3 +69 139 116 aquamarine4 +193 255 193 darkseagreen1 +180 238 180 darkseagreen2 +155 205 155 darkseagreen3 +105 139 105 darkseagreen4 +84 255 159 seagreen1 +78 238 148 seagreen2 +67 205 128 seagreen3 +46 139 87 seagreen4 +154 255 154 palegreen1 +144 238 144 palegreen2 +124 205 124 palegreen3 +84 139 84 palegreen4 +0 255 127 springgreen1 +0 238 118 springgreen2 +0 205 102 springgreen3 +0 139 69 springgreen4 +0 255 0 green1 +0 238 0 green2 +0 205 0 green3 +0 139 0 green4 +127 255 0 chartreuse1 +118 238 0 chartreuse2 +102 205 0 chartreuse3 +69 139 0 chartreuse4 +192 255 62 olivedrab1 +179 238 58 olivedrab2 +154 205 50 olivedrab3 +105 139 34 olivedrab4 +202 255 112 darkolivegreen1 +188 238 104 darkolivegreen2 +162 205 90 darkolivegreen3 +110 139 61 darkolivegreen4 +255 246 143 khaki1 +238 230 133 khaki2 +205 198 115 khaki3 +139 134 78 khaki4 +255 236 139 lightgoldenrod1 +238 220 130 lightgoldenrod2 +205 190 112 lightgoldenrod3 +139 129 76 lightgoldenrod4 +255 255 224 lightyellow1 +238 238 209 lightyellow2 +205 205 180 lightyellow3 +139 139 122 lightyellow4 +255 255 0 yellow1 +238 238 0 yellow2 +205 205 0 yellow3 +139 139 0 yellow4 +255 215 0 gold1 +238 201 0 gold2 +205 173 0 gold3 +139 117 0 gold4 +255 193 37 goldenrod1 +238 180 34 goldenrod2 +205 155 29 goldenrod3 +139 105 20 goldenrod4 +255 185 15 darkgoldenrod1 +238 173 14 darkgoldenrod2 +205 149 12 darkgoldenrod3 +139 101 8 darkgoldenrod4 +255 193 193 rosybrown1 +238 180 180 rosybrown2 +205 155 155 rosybrown3 +139 105 105 rosybrown4 +255 106 106 indianred1 +238 99 99 indianred2 +205 85 85 indianred3 +139 58 58 indianred4 +255 130 71 sienna1 +238 121 66 sienna2 +205 104 57 sienna3 +139 71 38 sienna4 +255 211 155 burlywood1 +238 197 145 burlywood2 +205 170 125 burlywood3 +139 115 85 burlywood4 +255 231 186 wheat1 +238 216 174 wheat2 +205 186 150 wheat3 +139 126 102 wheat4 +255 165 79 tan1 +238 154 73 tan2 +205 133 63 tan3 +139 90 43 tan4 +255 127 36 chocolate1 +238 118 33 chocolate2 +205 102 29 chocolate3 +139 69 19 chocolate4 +255 48 48 firebrick1 +238 44 44 firebrick2 +205 38 38 firebrick3 +139 26 26 firebrick4 +255 64 64 brown1 +238 59 59 brown2 +205 51 51 brown3 +139 35 35 brown4 +255 140 105 salmon1 +238 130 98 salmon2 +205 112 84 salmon3 +139 76 57 salmon4 +255 160 122 lightsalmon1 +238 149 114 lightsalmon2 +205 129 98 lightsalmon3 +139 87 66 lightsalmon4 +255 165 0 orange1 +238 154 0 orange2 +205 133 0 orange3 +139 90 0 orange4 +255 127 0 darkorange1 +238 118 0 darkorange2 +205 102 0 darkorange3 +139 69 0 darkorange4 +255 114 86 coral1 +238 106 80 coral2 +205 91 69 coral3 +139 62 47 coral4 +255 99 71 tomato1 +238 92 66 tomato2 +205 79 57 tomato3 +139 54 38 tomato4 +255 69 0 orangered1 +238 64 0 orangered2 +205 55 0 orangered3 +139 37 0 orangered4 +255 0 0 red1 +238 0 0 red2 +205 0 0 red3 +139 0 0 red4 +255 20 147 deeppink1 +238 18 137 deeppink2 +205 16 118 deeppink3 +139 10 80 deeppink4 +255 110 180 hotpink1 +238 106 167 hotpink2 +205 96 144 hotpink3 +139 58 98 hotpink4 +255 181 197 pink1 +238 169 184 pink2 +205 145 158 pink3 +139 99 108 pink4 +255 174 185 lightpink1 +238 162 173 lightpink2 +205 140 149 lightpink3 +139 95 101 lightpink4 +255 130 171 palevioletred1 +238 121 159 palevioletred2 +205 104 137 palevioletred3 +139 71 93 palevioletred4 +255 52 179 maroon1 +238 48 167 maroon2 +205 41 144 maroon3 +139 28 98 maroon4 +255 62 150 violetred1 +238 58 140 violetred2 +205 50 120 violetred3 +139 34 82 violetred4 +255 0 255 magenta1 +238 0 238 magenta2 +205 0 205 magenta3 +139 0 139 magenta4 +255 131 250 orchid1 +238 122 233 orchid2 +205 105 201 orchid3 +139 71 137 orchid4 +255 187 255 plum1 +238 174 238 plum2 +205 150 205 plum3 +139 102 139 plum4 +224 102 255 mediumorchid1 +209 95 238 mediumorchid2 +180 82 205 mediumorchid3 +122 55 139 mediumorchid4 +191 62 255 darkorchid1 +178 58 238 darkorchid2 +154 50 205 darkorchid3 +104 34 139 darkorchid4 +155 48 255 purple1 +145 44 238 purple2 +125 38 205 purple3 +85 26 139 purple4 +171 130 255 mediumpurple1 +159 121 238 mediumpurple2 +137 104 205 mediumpurple3 +93 71 139 mediumpurple4 +255 225 255 thistle1 +238 210 238 thistle2 +205 181 205 thistle3 +139 123 139 thistle4 +0 0 0 grey0 +3 3 3 grey1 +5 5 5 grey2 +8 8 8 grey3 +10 10 10 grey4 +13 13 13 grey5 +15 15 15 grey6 +18 18 18 grey7 +20 20 20 grey8 +23 23 23 grey9 +26 26 26 grey10 +28 28 28 grey11 +31 31 31 grey12 +33 33 33 grey13 +36 36 36 grey14 +38 38 38 grey15 +41 41 41 grey16 +43 43 43 grey17 +46 46 46 grey18 +48 48 48 grey19 +51 51 51 grey20 +54 54 54 grey21 +56 56 56 grey22 +59 59 59 grey23 +61 61 61 grey24 +64 64 64 grey25 +66 66 66 grey26 +69 69 69 grey27 +71 71 71 grey28 +74 74 74 grey29 +77 77 77 grey30 +79 79 79 grey31 +82 82 82 grey32 +84 84 84 grey33 +87 87 87 grey34 +89 89 89 grey35 +92 92 92 grey36 +94 94 94 grey37 +97 97 97 grey38 +99 99 99 grey39 +102 102 102 grey40 +105 105 105 grey41 +107 107 107 grey42 +110 110 110 grey43 +112 112 112 grey44 +115 115 115 grey45 +117 117 117 grey46 +120 120 120 grey47 +122 122 122 grey48 +125 125 125 grey49 +127 127 127 grey50 +130 130 130 grey51 +133 133 133 grey52 +135 135 135 grey53 +138 138 138 grey54 +140 140 140 grey55 +143 143 143 grey56 +145 145 145 grey57 +148 148 148 grey58 +150 150 150 grey59 +153 153 153 grey60 +156 156 156 grey61 +158 158 158 grey62 +161 161 161 grey63 +163 163 163 grey64 +166 166 166 grey65 +168 168 168 grey66 +171 171 171 grey67 +173 173 173 grey68 +176 176 176 grey69 +179 179 179 grey70 +181 181 181 grey71 +184 184 184 grey72 +186 186 186 grey73 +189 189 189 grey74 +191 191 191 grey75 +194 194 194 grey76 +196 196 196 grey77 +199 199 199 grey78 +201 201 201 grey79 +204 204 204 grey80 +207 207 207 grey81 +209 209 209 grey82 +212 212 212 grey83 +214 214 214 grey84 +217 217 217 grey85 +219 219 219 grey86 +222 222 222 grey87 +224 224 224 grey88 +227 227 227 grey89 +229 229 229 grey90 +232 232 232 grey91 +235 235 235 grey92 +237 237 237 grey93 +240 240 240 grey94 +242 242 242 grey95 +245 245 245 grey96 +247 247 247 grey97 +250 250 250 grey98 +252 252 252 grey99 +255 255 255 grey100 +169 169 169 darkgrey +0 0 139 darkblue +0 139 139 darkcyan +139 0 139 darkmagenta +139 0 0 darkred +144 238 144 lightgreen") + +;*---------------------------------------------------------------------*/ +;* *rgb-port* ... */ +;*---------------------------------------------------------------------*/ +(define *rgb-port* #unspecified) + +;*---------------------------------------------------------------------*/ +;* same-color? ... */ +;*---------------------------------------------------------------------*/ +(define (same-color? s1 s2) + (define (skip-rgb s) + (let ((l (string-length s))) + (let loop ((i 0)) + (if (=fx i l) + l + (let ((c (string-ref s i))) + (if (or (char-numeric? c) (char-whitespace? c)) + (loop (+fx i 1)) + i)))))) + (let ((l1 (string-length s1)) + (l2 (string-length s2))) + (if (>fx l1 l2) + (let ((lc (skip-rgb s1))) + (and (=fx (-fx l1 lc) l2) + (let loop ((i1 (-fx l1 l2)) + (i2 0)) + (cond + ((=fx i1 l1) + #t) + ((char-ci=? (string-ref s1 i1) (string-ref s2 i2)) + (loop (+fx i1 1) (+fx i2 1))) + (else + #f)))))))) + +;*---------------------------------------------------------------------*/ +;* rgb-grep ... */ +;*---------------------------------------------------------------------*/ +(define (rgb-grep symbol) + (let ((parser (regular-grammar () + ((bol (: #\! (* all))) + (ignore)) + ((+ #\Newline) + (ignore)) + ((: (* (in #\space #\tab)) + (+ digit) + (+ (in #\space #\tab)) + (+ digit) + (+ (in #\space #\tab)) + (+ digit) + (+ (in #\space #\tab)) + (+ all)) + (let ((s (the-string))) + (if (same-color? s symbol) + (let ((m (pregexp-match "[ \t]*([0-9]+)[ \t]+([0-9]+)[ \t]+([0-9]+)[ \t]+.+" s))) + (values (string->number (cadr m)) + (string->number (caddr m)) + (string->number (cadddr m)))) + (ignore)))) + (else + (values 0 0 0))))) + ;; initialization the port reading rgb.txt file + (with-input-from-string *skribe-rgb-string* + (lambda () + (read/rp parser (current-input-port)))))) + +;*---------------------------------------------------------------------*/ +;* *color-parser* ... */ +;*---------------------------------------------------------------------*/ +(define *color-parser* + (regular-grammar ((blank* (* blank)) + (blank+ (+ blank))) + + ;; rgb color + ((: #\# (+ xdigit)) + (let ((val (the-substring 1 (the-length)))) + (cond + ((=fx (string-length val) 6) + (values (string->integer (substring val 0 2) 16) + (string->integer (substring val 2 4) 16) + (string->integer (substring val 4 6) 16))) + ((=fx (string-length val) 12) + (values (string->integer (substring val 0 2) 16) + (string->integer (substring val 4 6) 16) + (string->integer (substring val 8 10) 16))) + (else + (values 0 0 0))))) + + ;; symbolic names + ((+ (out #\Newline)) + (let ((name (the-string))) + (cond + ((string-ci=? name "none") + (values 0 0 0)) + ((string-ci=? name "black") + (values #xff #xff #xff)) + ((string-ci=? name "white") + (values 0 0 0)) + (else + (rgb-grep name))))) + + ;; error + (else + (values 0 0 0)))) + +;*---------------------------------------------------------------------*/ +;* skribe-color->rgb ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-color->rgb spec) + (cond + ((string? spec) + (with-input-from-string spec + (lambda () + (read/rp *color-parser* (current-input-port))))) + ((fixnum? spec) + (values (bit-and #xff (bit-rsh spec 16)) + (bit-and #xff (bit-rsh spec 8)) + (bit-and #xff spec))) + (else + (values 0 0 0)))) + +;*---------------------------------------------------------------------*/ +;* *used-colors* ... */ +;*---------------------------------------------------------------------*/ +(define *used-colors* '()) + +;*---------------------------------------------------------------------*/ +;* skribe-get-used-colors ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-get-used-colors) + *used-colors*) + +;*---------------------------------------------------------------------*/ +;* skribe-use-color! ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-use-color! color) + (set! *used-colors* (cons color *used-colors*)) + color) |