File Coverage

File:	blib/lib/Image/Caa.pm
Coverage:	74.0%

line	stmt	bran	cond	sub	time	code
1						package Image::Caa;
2
3	3 3 3			3	16 5 24	use strict;
4	3 3 3			3	22 8 16	use warnings;
5
6						our $VERSION = '1.01';
7
8						# dark colors
9	3 3 3			3	30 8 22	use constant CAA_COLOR_BLACK => 0;
10	3 3 3			3	22 6 16	use constant CAA_COLOR_RED => 1;
11	3 3 3			3	20 5 15	use constant CAA_COLOR_GREEN => 2;
12	3 3 3			3	18 6 16	use constant CAA_COLOR_YELLOW => 3;
13	3 3 3			3	19 6 14	use constant CAA_COLOR_BLUE => 4;
14	3 3 3			3	19 7 14	use constant CAA_COLOR_MAGENTA => 5;
15	3 3 3			3	19 6 17	use constant CAA_COLOR_CYAN => 6;
16	3 3 3			3	17 8 14	use constant CAA_COLOR_LIGHTGRAY => 7;
17
18						# light colors
19	3 3 3			3	18 6 15	use constant CAA_COLOR_DARKGRAY => 8;
20	3 3 3			3	19 7 25	use constant CAA_COLOR_LIGHTRED => 9;
21	3 3 3			3	17 7 24	use constant CAA_COLOR_LIGHTGREEN => 10;
22	3 3 3			3	18 11 14	use constant CAA_COLOR_BROWN => 11;
23	3 3 3			3	24 5 20	use constant CAA_COLOR_LIGHTBLUE => 12;
24	3 3 3			3	17 7 14	use constant CAA_COLOR_LIGHTMAGENTA => 13;
25	3 3 3			3	18 6 132	use constant CAA_COLOR_LIGHTCYAN => 14;
26	3 3 3			3	19 7 14	use constant CAA_COLOR_WHITE => 15;
27
28	3 3 3			3	18 7 18	use constant CAA_LOOKUP_VAL => 32;
29	3 3 3			3	20 6 15	use constant CAA_LOOKUP_SAT => 32;
30	3 3 3			3	19 7 14	use constant CAA_LOOKUP_HUE => 16;
31
32	3 3 3			3	24 42 51	use constant CAA_HSV_XRATIO => 6;
33	3 3 3			3	19 6 16	use constant CAA_HSV_YRATIO => 3;
34	3 3 3			3	18 6 15	use constant CAA_HSV_HRATIO => 3;
35
36
37						sub new {
38	15			15	189	my $class = shift;
39	15				67	my %opts = @_;
40	15				47	my $opts = \%opts;
41
42	15				65	my $self = bless {}, $class;
43
44	15		100		137	$self->{driver} = $self->load_submodule($opts->{driver} \|\| 'DriverANSI', $opts);
45	14		100		92	$self->{dither} = $self->load_submodule($opts->{dither} \|\| 'DitherNone', $opts);
46	14	100			144	$self->{solid_background} = $opts->{black_bg} ? 0 : 1;
47
48	14				190	$self->{hsv_palette} = [
49						# weight, hue, saturation, value
50						4, 0x0, 0x0, 0x0, # black
51						5, 0x0, 0x0, 0x5ff, # 30%
52						5, 0x0, 0x0, 0x9ff, # 70%
53						4, 0x0, 0x0, 0xfff, # white
54						3, 0x1000, 0xfff, 0x5ff, # dark yellow
55						2, 0x1000, 0xfff, 0xfff, # light yellow
56						3, 0x0, 0xfff, 0x5ff, # dark red
57						2, 0x0, 0xfff, 0xfff # light red
58						];
59
60	14				51	$self->init();
61
62	14				107	return $self;
63						}
64
65
66						sub init {
67	14			14	42	my ($self) = @_;
68
69	14				48	$self->{hsv_distances} = [];
70
71						for (my $v = 0; $v < CAA_LOOKUP_VAL; $v++){
72						for (my $s = 0; $s < CAA_LOOKUP_SAT; $s++){
73						for (my $h = 0; $h < CAA_LOOKUP_HUE; $h++){
74
75	229376				609410	my $val = 0xfff * $v / (CAA_LOOKUP_VAL - 1);
76	229376				587258	my $sat = 0xfff * $s / (CAA_LOOKUP_SAT - 1);
77	229376				585285	my $hue = 0xfff * $h / (CAA_LOOKUP_HUE - 1);
78
79						# Initialise distances to the distance between pure black HSV
80						# coordinates and our white colour (3)
81
82	229376				414220	my $outbg = 3;
83	229376				409642	my $outfg = 3;
84	229376				756508	my $distbg = $self->HSV_DISTANCE(0, 0, 0, 3);
85	229376				754860	my $distfg = $self->HSV_DISTANCE(0, 0, 0, 3);
86
87
88						# Calculate distances to eight major colour values and store the
89						# two nearest points in our lookup table.
90
91						for (my $i = 0; $i < 8; $i++){
92
93	1835008				5898019	my $dist = $self->HSV_DISTANCE($hue, $sat, $val, $i);
94
95	1835008	100 100			9237130	if ($dist <= $distbg){
96
97	651252				1206659	$outfg = $outbg;
98	651252				1194489	$distfg = $distbg;
99	651252				1169454	$outbg = $i;
100	651252				3034117	$distbg = $dist;
101
102						}elsif ($dist <= $distfg){
103
104	286846				530220	$outfg = $i;
105	286846				1336740	$distfg = $dist;
106						}
107	229376				434254	}
108
109	229376				1840579	$self->{hsv_distances}->[$v]->[$s]->[$h] = ($outfg << 4) \| $outbg;
110	14336				26359	}
111	448				853	}
112	14				29	}
113						}
114
115						sub init_instance {
116	5			5	13	my ($self) = @_;
117
118	5				25	$self->{lookup_colors} = [];
119
120						# These ones are constant
121	5				22	$self->{lookup_colors}->[0] = CAA_COLOR_BLACK;
122	5				16	$self->{lookup_colors}->[1] = CAA_COLOR_DARKGRAY;
123	5				16	$self->{lookup_colors}->[2] = CAA_COLOR_LIGHTGRAY;
124	5				16	$self->{lookup_colors}->[3] = CAA_COLOR_WHITE;
125
126						# These ones will be overwritten
127	5				17	$self->{lookup_colors}->[4] = CAA_COLOR_MAGENTA;
128	5				19	$self->{lookup_colors}->[5] = CAA_COLOR_LIGHTMAGENTA;
129	5				17	$self->{lookup_colors}->[6] = CAA_COLOR_RED;
130	5				21	$self->{lookup_colors}->[7] = CAA_COLOR_LIGHTRED;
131						}
132
133						#
134						# Draw a bitmap on the screen.
135						#
136						# Draw a bitmap at the given coordinates. The bitmap can be of any size and
137						# will be stretched to the text area.
138						#
139						# x1 X coordinate of the upper-left corner of the drawing area.
140						# y1 Y coordinate of the upper-left corner of the drawing area.
141						# x2 X coordinate of the lower-right corner of the drawing area.
142						# y2 Y coordinate of the lower-right corner of the drawing area.
143						# image Image Magick picture object to be drawn.
144						#
145
146						sub draw_bitmap{
147	5			5	76	my ($self, $x1, $y1, $x2, $y2, $image) = @_;
148
149	5				12	my $w = $x2-$x1;
150	5				12	my $h = $y2-$y1;
151
152	5				13	my $iw = 0;
153	5				11	my $ih = 0;
154	5				10	my $h_pad = 0;
155	5				12	my $v_pad = 0;
156
157	5	50			18	if (defined $image){
158
159						# resize to fit in the box
160
161	0				0	$image->Scale('100%,67%');
162	0				0	my $x = $image->Resize(geometry => ($w-2).'x'.($h-2));
163	0	0			0	warn "$x" if "$x";
164
165	0				0	($iw, $ih) = $image->Get('columns', 'rows');
166
167	0				0	$h_pad = 1 + int(($w - $iw) / 2);
168	0				0	$v_pad = 1 + int(($h - $ih) / 2);
169						}
170
171	5				16	$self->init_instance();
172	5				29	$self->{driver}->init();
173
174
175						# Only used when background is black
176
177	5				19	my $white_colors = [
178						CAA_COLOR_BLACK,
179						CAA_COLOR_DARKGRAY,
180						CAA_COLOR_LIGHTGRAY,
181						CAA_COLOR_WHITE,
182						];
183
184	5				24	my $light_colors = [
185						CAA_COLOR_LIGHTMAGENTA,
186						CAA_COLOR_LIGHTRED,
187						CAA_COLOR_YELLOW,
188						CAA_COLOR_LIGHTGREEN,
189						CAA_COLOR_LIGHTCYAN,
190						CAA_COLOR_LIGHTBLUE,
191						CAA_COLOR_LIGHTMAGENTA,
192						];
193
194	5				23	my $dark_colors = [
195						CAA_COLOR_MAGENTA,
196						CAA_COLOR_RED,
197						CAA_COLOR_BROWN,
198						CAA_COLOR_GREEN,
199						CAA_COLOR_CYAN,
200						CAA_COLOR_BLUE,
201						CAA_COLOR_MAGENTA,
202						];
203
204
205						# FIXME: choose better characters!
206
207	5				14	my $density_chars =
208						" ".
209						". ".
210						".. ".
211						"....".
212						"::::".
213						";=;=".
214						"tftf".
215						'%$%$'.
216						"&KSZ".
217						"WXGM".
218						'@@@@'.
219						"8888".
220						"####".
221						"????";
222
223	5				136	my @density_chars = split //, $density_chars;
224	5				27	$density_chars = \@density_chars;
225
226	5 5				9 17	my $density_chars_size = scalar(@{$density_chars}) - 1;
227
228	5				12	my $x = 0;
229	5				10	my $y = 0;
230	5				10	my $deltax = 0;
231	5				9	my $deltay = 0;
232
233
234	5				8	my $tmp;
235	5 0 0 0	50			17 0 0 0	if ($x1 > $x2){ $tmp = $x2; $x2 = $x1; $x1 = $tmp; }
236	5 0 0 0	50			19 0 0 0	if ($y1 > $y2){ $tmp = $y2; $y2 = $y1; $y1 = $tmp; }
237
238	5				12	$deltax = $x2 - $x1 + 1;
239	5				12	$deltay = $y2 - $y1 + 1;
240
241
242						for ($y = $y1 > 0 ? $y1 : 0; $y <= $y2; $y++){
243	10				49	$self->{dither}->init($y);
244						for ($x = $x1 > 0 ? $x1 : 0; $x <= $x2; $x++){
245
246	20				86	my $ch = 0;
247	20				35	my $r = 0;
248	20				33	my $g = 0;
249	20				37	my $b = 0;
250	20				37	my $a = 0;
251	20				35	my $hue = 0;
252	20				35	my $sat = 0;
253	20				35	my $val = 0;
254	20				35	my $fromx = 0;
255	20				34	my $fromy = 0;
256	20				36	my $tox = 0;
257	20				34	my $toy = 0;
258	20				33	my $myx = 0;
259	20				38	my $myy = 0;
260	20				34	my $dots = 0;
261	20				37	my $outfg = 0;
262	20				34	my $outbg = 0;
263	20				40	my $outch = chr 0;
264
265						# First get RGB
266
267	20	50			50	if (defined $image){
268
269	0				0	my $px = ($x - $x1) - $h_pad;
270	0				0	my $py = ($y - $y1) - $v_pad;
271
272	0				0	my $to_l = $px < 0;
273	0				0	my $to_t = $py < 0;
274	0				0	my $to_r = $px >= $iw;
275	0				0	my $to_b = $py >= $ih;
276
277	0	0	0		0	if ($to_l \|\| $to_t \|\| $to_r \|\| $to_b){
278
279	0				0	$r = 0xfff;
280	0				0	$g = 0xfff;
281	0				0	$b = 0xfff;
282
283						}else{
284
285	0				0	($r, $g, $b, $a) = split /,/, $image->Get("pixel[$px,$py]");
286
287	0				0	$r >>= 4;
288	0				0	$g >>= 4;
289	0				0	$b >>= 4;
290						}
291
292						#if (bitmap->has_alpha && a < 0x800) continue;
293
294						# Now get HSV from RGB
295	0				0	($hue, $sat, $val) = $self->rgb2hsv_default($r, $g, $b);
296
297						}else{
298
299	20				74	$hue = int(0x5fff * (($x-$x1) / ($x2-$x1)));
300	20				64	$sat = int(0xfff * (($y-$y1) / ($y2-$y1)));
301	20				59	$val = int(0xfff * (($y-$y1) / ($y2-$y1)));
302	20				42	$val = 0x777;
303						}
304
305
306						# The hard work: calculate foreground and background colours,
307						# as well as the most appropriate character to output.
308
309	20	50			119	if ($self->{solid_background}){
310
311	20				39	my $point = chr 0;
312	20				42	my $distfg = 0;
313	20				40	my $distbg = 0;
314
315	20				93	$self->{lookup_colors}->[4] = $dark_colors->[1 + $hue / 0x1000];
316	20				90	$self->{lookup_colors}->[5] = $light_colors->[1 + $hue / 0x1000];
317	20				133	$self->{lookup_colors}->[6] = $dark_colors->[$hue / 0x1000];
318	20				126	$self->{lookup_colors}->[7] = $light_colors->[$hue / 0x1000];
319
320	20				84	my $idx_v = ($val + $self->{dither}->get() * (0x1000 / CAA_LOOKUP_VAL) / 0x100) * (CAA_LOOKUP_VAL - 1) / 0x1000;
321	20				78	my $idx_s = ($sat + $self->{dither}->get() * (0x1000 / CAA_LOOKUP_SAT) / 0x100) * (CAA_LOOKUP_SAT - 1) / 0x1000;
322	20				80	my $idx_h = (($hue & 0xfff) + $self->{dither}->get() * (0x1000 / CAA_LOOKUP_HUE) / 0x100) * (CAA_LOOKUP_HUE - 1) / 0x1000;
323
324	20				94	$point = $self->{hsv_distances}->[$idx_v]->[$idx_s]->[$idx_h];
325
326	20				85	$distfg = $self->HSV_DISTANCE($hue % 0xfff, $sat, $val, ($point >> 4));
327	20				137	$distbg = $self->HSV_DISTANCE($hue % 0xfff, $sat, $val, ($point & 0xf));
328
329						# Sanity check due to the lack of precision in hsv_distances,
330						# and distbg can be > distfg because of dithering fuzziness.
331
332	20 0	50			65 0	if ($distbg > $distfg){ $distbg = $distfg; }
333
334	20				67	$outfg = $self->{lookup_colors}->[($point >> 4)];
335	20				72	$outbg = $self->{lookup_colors}->[($point & 0xf)];
336
337	20				70	$ch = $distbg * 2 * ($density_chars_size - 1) / ($distbg + $distfg);
338	20				84	$ch = 4 * $ch + $self->{dither}->get() / 0x40;
339
340	20 20	100			32 72	if ($ch >= scalar(@{$density_chars})){
341
342	15 15				20 42	$ch = scalar(@{$density_chars}) - 1;
343						}
344
345	20				56	$outch = $density_chars->[$ch];
346
347						}else{
348
349	0				0	$outbg = CAA_COLOR_BLACK;
350
351	0	0 0			0	if ($sat < 0x200 + $self->{dither}->get() * 0x8){
352
353	0				0	$outfg = $white_colors->[1 + ($val * 2 + $self->{dither}->get() * 0x10) / 0x1000];
354
355						}elsif ($val > 0x800 + $self->{dither}->get() * 0x4){
356
357	0				0	$outfg = $light_colors->[($hue + $self->{dither}->get() * 0x10) / 0x1000];
358
359						}else{
360	0				0	$outfg = $dark_colors->[($hue + $self->{dither}->get() * 0x10) / 0x1000];
361						}
362
363	0				0	$ch = ($val + 0x2 * $self->{dither}->get()) * 10 / 0x1000;
364	0				0	$ch = 4 * $ch + $self->{dither}->get() / 0x40;
365
366	0				0	$outch = $density_chars->[$ch];
367						}
368
369						# Now output the character
370	20				85	$self->{driver}->set_color($outfg, $outbg);
371	20				86	$self->{driver}->putchar($x, $y, $outch);
372
373	20				72	$self->{dither}->increment();
374	10	50			37	}
375	5	50			19	}
376
377	5				25	$self->{driver}->fini();
378						}
379
380						sub rgb2hsv_default {
381	0			0	0	my ($self, $r, $g, $b) = @_;
382
383	0				0	my ($hue, $sat, $val) = (0, 0, 0);
384
385	0				0	my $min = $r;
386	0				0	my $max = $r;
387
388	0	0			0	$min = $g if $min > $g;
389	0	0			0	$max = $g if $max < $g;
390	0	0			0	$min = $b if $min > $b;
391	0	0			0	$max = $b if $max < $b;
392
393	0				0	my $delta = $max - $min; # 0 - 0xfff
394	0				0	$val = $max; # 0 - 0xfff
395
396	0	0			0	if ($delta){
397
398	0				0	$sat = 0xfff * $delta / $max; # 0 - 0xfff
399
400						# Generate *hue between 0 and 0x5fff
401
402	0	0 0			0	if ($r == $max){
403	0				0	$hue = 0x1000 + 0x1000 * ($g - $b) / $delta;
404						}elsif ($g == $max){
405	0				0	$hue = 0x3000 + 0x1000 * ($b - $r) / $delta;
406						}else{
407	0				0	$hue = 0x5000 + 0x1000 * ($r - $g) / $delta;
408						}
409						}else{
410	0				0	$sat = 0;
411	0				0	$hue = 0;
412						}
413
414	0				0	return ($hue, $sat, $val);
415						}
416
417
418						sub HSV_DISTANCE{
419	2293800			2293800	7470831	my ($self, $h, $s, $v, $index) = @_;
420
421	2293800				9814290	my $v1 = $v - $self->{hsv_palette}->[$index * 4 + 3];
422	2293800				9544149	my $s1 = $s - $self->{hsv_palette}->[$index * 4 + 2];
423	2293800				9598570	my $h1 = $h - $self->{hsv_palette}->[$index * 4 + 1];
424
425	2293800	100			12275405	my $s2 = $self->{hsv_palette}->[$index * 4 + 3] ? CAA_HSV_YRATIO * $s1 * $s1 : 0;
426	2293800	100			11350096	my $h2 = $self->{hsv_palette}->[$index * 4 + 2] ? CAA_HSV_HRATIO * $h1 * $h1 : 0;
427
428	2293800				13903880	return $self->{hsv_palette}->[$index * 4] * ((CAA_HSV_XRATIO * $v1 * $v1) + $s2 + $h2);
429						}
430
431						sub load_submodule {
432	29			29	98	my ($self, $module, $args) = @_;
433
434	29				822	eval "require Image::Caa::$module";
435	29	100			191	warn $@ if $@;
436
437	29				65	my $obj = undef;
438	29				697	eval "\$obj = new Image::Caa::$module(\$args)";
439	29	100			121	warn $@ if $@;
440
441	29	100	67		299	if (!$@ && defined $obj){
442
443	28				119	return $obj;
444						}
445
446	1				2	die "Image::Caa - Couldn't load 'Image::Caa::$module'";
447						}
448
449						1;
450