File Coverage

blib/lib/Term/Colormap.pm
Criterion Covered Total %
statement 73 75 97.3
branch 16 16 100.0
condition 7 7 100.0
subroutine 15 16 93.7
pod 8 8 100.0
total 119 122 97.5


line stmt bran cond sub pod time code
1             package Term::Colormap;
2              
3 2     2   116437 use 5.006;
  2         16  
4 2     2   10 use strict;
  2         3  
  2         39  
5 2     2   8 use warnings FATAL => 'all';
  2         5  
  2         102  
6 2     2   13 use Exporter 'import';
  2         4  
  2         63  
7 2     2   9 use Scalar::Util qw( looks_like_number );
  2         4  
  2         2234  
8              
9             our $VERSION = '0.15';
10              
11             our @EXPORT_OK = qw(
12             colorbar
13             colormap
14             color2rgb
15             rgb2color
16             print_colored
17             print_colored_text
18             color_table
19             add_mapping
20             );
21              
22             my $color_mapping = {};
23              
24             # http://www.calmar.ws/vim/256-xterm-24bit-rgb-color-chart.html
25             $color_mapping->{rainbow} = [
26             1, # Red
27             196, 202, 208, 214, 220, 226,
28             11, # Yellow
29             190, 154, 118, 82, 46,
30             10, # Green
31             47, 48, 49, 50, 51,
32             14, # Cyan
33             45, 39, 33, 27, 21,
34             12, # Blue
35             57, 93, 129, 165, 201,
36             5, # Magenta
37             ];
38              
39             $color_mapping->{primary} = [
40             # Black, Red, Green, Yellow, Blue, Magenta, Cyan, Off-White
41             0,1,2,3,4,5,6,7
42             ];
43              
44             $color_mapping->{bright} = [
45             # Gray, Bright Red, Bright Green, Bright Yellow,
46             8,9,10,11,
47             # Bright Blue, Bright Magenta, Bright Cyan, White
48             12,13,14,15
49             ];
50              
51             $color_mapping->{ash} = [
52             # Black <--------------------------------> Gray
53             232,233,234,235,236,237,238,239,240,241,242,243,
54             ];
55              
56             $color_mapping->{snow} = [
57             # Gray <--------------------------------> White
58             244,245,246,247,248,249,250,251,252,253,254,255,
59             ];
60              
61             $color_mapping->{gray} = [ @{ $color_mapping->{ash} }, @{ $color_mapping->{snow} } ];
62              
63             $color_mapping->{'blue-cyan-green'} = [
64             # Blue <------------------ Cyan -----------------> Green
65             17,18,19,20,21,27,33,39,45,51,50,49,48,47,46,40,34,28,22
66             ];
67              
68             $color_mapping->{'red-pink-yellow'} = [
69             # Red <------------------ Pink ------------------------> Yellow
70             196,197,198,199,200,201,207,213,219,225,231,230,229,228,227,226
71             ];
72              
73             $color_mapping->{'green-orange-pink-blue'} = [
74             # Green <-------- Orange -------- Pink --------------> Blue
75             28,64,100,136,172,208,209,210,211,212,213,177,141,105,69,33
76             ];
77              
78             # 0-255
79             my $color2rgb = [
80             '000000', '800000', '008000', '808000', '000080', '800080',
81             '008080', 'c0c0c0', '808080', 'ff0000', '00ff00', 'ffff00',
82             '0000ff', 'ff00ff', '00ffff', 'ffffff', '000000', '00005f',
83             '000087', '0000af', '0000d7', '0000ff', '005f00', '005f5f',
84             '005f87', '005faf', '005fd7', '005fff', '008700', '00875f',
85             '008787', '0087af', '0087d7', '0087ff', '00af00', '00af5f',
86             '00af87', '00afaf', '00afd7', '00afff', '00d700', '00d75f',
87             '00d787', '00d7af', '00d7d7', '00d7ff', '00ff00', '00ff5f',
88             '00ff87', '00ffaf', '00ffd7', '00ffff', '5f0000', '5f005f',
89             '5f0087', '5f00af', '5f00d7', '5f00ff', '5f5f00', '5f5f5f',
90             '5f5f87', '5f5faf', '5f5fd7', '5f5fff', '5f8700', '5f875f',
91             '5f8787', '5f87af', '5f87d7', '5f87ff', '5faf00', '5faf5f',
92             '5faf87', '5fafaf', '5fafd7', '5fafff', '5fd700', '5fd75f',
93             '5fd787', '5fd7af', '5fd7d7', '5fd7ff', '5fff00', '5fff5f',
94             '5fff87', '5fffaf', '5fffd7', '5fffff', '870000', '87005f',
95             '870087', '8700af', '8700d7', '8700ff', '875f00', '875f5f',
96             '875f87', '875faf', '875fd7', '875fff', '878700', '87875f',
97             '878787', '8787af', '8787d7', '8787ff', '87af00', '87af5f',
98             '87af87', '87afaf', '87afd7', '87afff', '87d700', '87d75f',
99             '87d787', '87d7af', '87d7d7', '87d7ff', '87ff00', '87ff5f',
100             '87ff87', '87ffaf', '87ffd7', '87ffff', 'af0000', 'af005f',
101             'af0087', 'af00af', 'af00d7', 'af00ff', 'af5f00', 'af5f5f',
102             'af5f87', 'af5faf', 'af5fd7', 'af5fff', 'af8700', 'af875f',
103             'af8787', 'af87af', 'af87d7', 'af87ff', 'afaf00', 'afaf5f',
104             'afaf87', 'afafaf', 'afafd7', 'afafff', 'afd700', 'afd75f',
105             'afd787', 'afd7af', 'afd7d7', 'afd7ff', 'afff00', 'afff5f',
106             'afff87', 'afffaf', 'afffd7', 'afffff', 'd70000', 'd7005f',
107             'd70087', 'd700af', 'd700d7', 'd700ff', 'd75f00', 'd75f5f',
108             'd75f87', 'd75faf', 'd75fd7', 'd75fff', 'd78700', 'd7875f',
109             'd78787', 'd787af', 'd787d7', 'd787ff', 'd7af00', 'd7af5f',
110             'd7af87', 'd7afaf', 'd7afd7', 'd7afff', 'd7d700', 'd7d75f',
111             'd7d787', 'd7d7af', 'd7d7d7', 'd7d7ff', 'd7ff00', 'd7ff5f',
112             'd7ff87', 'd7ffaf', 'd7ffd7', 'd7ffff', 'ff0000', 'ff005f',
113             'ff0087', 'ff00af', 'ff00d7', 'ff00ff', 'ff5f00', 'ff5f5f',
114             'ff5f87', 'ff5faf', 'ff5fd7', 'ff5fff', 'ff8700', 'ff875f',
115             'ff8787', 'ff87af', 'ff87d7', 'ff87ff', 'ffaf00', 'ffaf5f',
116             'ffaf87', 'ffafaf', 'ffafd7', 'ffafff', 'ffd700', 'ffd75f',
117             'ffd787', 'ffd7af', 'ffd7d7', 'ffd7ff', 'ffff00', 'ffff5f',
118             'ffff87', 'ffffaf', 'ffffd7', 'ffffff', '080808', '121212',
119             '1c1c1c', '262626', '303030', '3a3a3a', '444444', '4e4e4e',
120             '585858', '626262', '626262', '767676', '808080', '8a8a8a',
121             '949494', '9e9e9e', 'a8a8a8', 'b2b2b2', 'bcbcbc', 'c6c6c6',
122             'd0d0d0', 'dadada', 'e4e4e4', 'eeeeee',
123             ];
124              
125             my $color = 0;
126             my $rgb2color = { map { $_ => $color++ } @$color2rgb };
127              
128             sub add_mapping {
129 0     0 1 0 my ($name, $mapping) = @_;
130 0         0 $color_mapping->{$name} = $mapping;
131             }
132              
133             sub rgb2color {
134 1247     1247 1 73304 my ($rgb) = @_;
135              
136 1247         2225 my $original_rgb = $rgb;
137 1247         2603 $rgb =~ s|^#||;
138 1247         2427 $rgb = lc($rgb);
139 1247 100       4035 if ( $rgb =~ m|[^a-f0-9]| ) {
140 1         11 die "Invalid RGB color '$original_rgb'"
141             }
142              
143 1246 100       3633 unless (defined $rgb2color->{$rgb}) {
144 1000         2155 $rgb2color->{ $rgb } = $rgb2color->{ _get_nearest_color($rgb) };
145             }
146              
147 1246         4020 return $rgb2color->{$rgb};
148             }
149              
150             sub _get_nearest_color {
151 1000     1000   1935 my ($rgb) = @_;
152 1000         1852 my $closest = 3 * (scalar @$color2rgb);
153 1000         1548 my $best_color;
154 1000         1750 for my $color ( @$color2rgb ) {
155 256000         337754 my $dist = _color_distance($rgb, $color);
156 256000 100       497975 if ($dist < $closest) {
157 5133         6242 $best_color = $color;
158 5133         7515 $closest = $dist;
159             }
160             }
161 1000         5452 return $best_color;
162             }
163              
164             sub _color_distance {
165 256000     256000   365509 my ($rgb0, $rgb1) = @_;
166 256000         351661 my $rgb = $rgb0 . $rgb1;
167             my ($r0, $g0, $b0,
168 256000         898554 $r1, $g1, $b1) = map { hex } ( $rgb =~ m/../g );
  1536000         2044285  
169 256000         559249 return abs($r1 - $r0)
170             + abs($g1 - $g0)
171             + abs($b1 - $b0);
172             }
173              
174             sub colormap {
175 14     14 1 2520 my ($name) = @_;
176              
177 14 100       48 if ( exists $color_mapping->{ lc($name) } ) {
178 13         31 return $color_mapping->{ lc($name) };
179             }
180              
181 1         26 die "Invalid colormap name : '$name'\n" .
182             "Choose one of ( " . ( join ", ", sort keys %$color_mapping ) . " )\n";
183              
184             }
185              
186             sub color2rgb {
187 321     321 1 57708 my ($color) = @_;
188              
189 321 100 100     1096 if ($color < 0 or $color >= scalar @$color2rgb) {
190 4         33 die "Invalid color value : $color";
191             }
192              
193 316         814 return $color2rgb->[$color];
194             }
195              
196              
197             sub colorbar {
198 2     2 1 4573 my ($colors, $width, $orientation ) = @_;
199              
200 2   100     11 $width ||= 2;
201 2   100     15 $orientation ||= 'h'; # Horizontal
202              
203 2         6 for my $color (@$colors) {
204 64         208 print_colored( $color, ' 'x$width );
205 64 100       231 unless ('h' eq substr(lc($orientation),0,1)) {
206 32         138 print "\n";
207             }
208             }
209 2         21 print "\n";
210             }
211              
212             sub color_table {
213 3     3 1 7219 my ($name) = @_;
214 3         8 my $mapping = colormap($name);
215              
216 3         6 my $header = "color number rgb";
217 3         8 my $indent = (length($header) - length($name) - 1) / 2; # spaces around name
218              
219 3         5 my $ii = int($indent);
220 3         83 print '-'x$ii . " $name " . '-'x$ii;
221 3 100       14 print '-' if ($ii < $indent);
222 3         13 print "\n";
223              
224 3         13 print $header . "\n";
225 3         8 for my $color (@$mapping) {
226 60         142 print_colored($color, ' 'x8 );
227 60         176 print sprintf(" %3d ", $color) . color2rgb($color) . "\n";
228             }
229 3         19 print "\n";
230             }
231              
232             sub print_colored {
233 125     125 1 1921 my ($color, $txt) = @_;
234 125         212 _print_with_color('bg',$color,$txt);
235             }
236              
237             sub print_colored_text {
238 1     1 1 1712 my ($color, $txt) = @_;
239 1         4 _print_with_color('fg',$color,$txt);
240             }
241              
242             sub _print_with_color {
243 126     126   252 my ($bg_or_fg, $color, $txt) = @_;
244              
245 126 100       257 my $code = $bg_or_fg eq 'fg' ? 38 : 48;
246 126         815 print "\x1b[${code};5;${color}m" . $txt . "\x1b[0m";
247             }
248              
249             1; # End of Term::Colormap
250              
251             __END__