1package Image::Caa;
2
3use strict;
4use warnings;
5
6our $VERSION = '1.01';
7
8# dark colors
9use constant CAA_COLOR_BLACK		=> 0;
10use constant CAA_COLOR_RED		=> 1;
11use constant CAA_COLOR_GREEN		=> 2;
12use constant CAA_COLOR_YELLOW		=> 3;
13use constant CAA_COLOR_BLUE		=> 4;
14use constant CAA_COLOR_MAGENTA		=> 5;
15use constant CAA_COLOR_CYAN		=> 6;
16use constant CAA_COLOR_LIGHTGRAY	=> 7;
17
18# light colors
19use constant CAA_COLOR_DARKGRAY		=> 8;
20use constant CAA_COLOR_LIGHTRED		=> 9;
21use constant CAA_COLOR_LIGHTGREEN	=> 10;
22use constant CAA_COLOR_BROWN		=> 11;
23use constant CAA_COLOR_LIGHTBLUE	=> 12;
24use constant CAA_COLOR_LIGHTMAGENTA	=> 13;
25use constant CAA_COLOR_LIGHTCYAN	=> 14;
26use constant CAA_COLOR_WHITE		=> 15;
27
28use constant CAA_LOOKUP_VAL		=> 32;
29use constant CAA_LOOKUP_SAT		=> 32;
30use constant CAA_LOOKUP_HUE		=> 16;
31
32use constant CAA_HSV_XRATIO		=> 6;
33use constant CAA_HSV_YRATIO		=> 3;
34use constant CAA_HSV_HRATIO		=> 3;
35
36
37sub new {
38	my $class = shift;
39	my %opts = @_;
40	my $opts = \%opts;
41
42	my $self = bless {}, $class;
43
44	$self->{driver} = $self->load_submodule($opts->{driver} || 'DriverANSI', $opts);
45	$self->{dither} = $self->load_submodule($opts->{dither} || 'DitherNone', $opts);
46	$self->{solid_background} = $opts->{black_bg} ? 0 : 1;
47
48	$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	$self->init();
61
62	return $self;
63}
64
65
66sub init {
67	my ($self) = @_;
68
69	$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		my $val = 0xfff * $v / (CAA_LOOKUP_VAL - 1);
76		my $sat = 0xfff * $s / (CAA_LOOKUP_SAT - 1);
77		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		my $outbg = 3;
83		my $outfg = 3;
84		my $distbg = $self->HSV_DISTANCE(0, 0, 0, 3);
85		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			my $dist = $self->HSV_DISTANCE($hue, $sat, $val, $i);
94
95			if ($dist <= $distbg){
96
97				$outfg = $outbg;
98				$distfg = $distbg;
99				$outbg = $i;
100				$distbg = $dist;
101
102			}elsif ($dist <= $distfg){
103
104				$outfg = $i;
105				$distfg = $dist;
106			}
107		}
108
109		$self->{hsv_distances}->[$v]->[$s]->[$h] = ($outfg << 4) | $outbg;
110	}
111	}
112	}
113}
114
115sub init_instance {
116	my ($self) = @_;
117
118	$self->{lookup_colors}	= [];
119
120	# These ones are constant
121	$self->{lookup_colors}->[0] = CAA_COLOR_BLACK;
122	$self->{lookup_colors}->[1] = CAA_COLOR_DARKGRAY;
123	$self->{lookup_colors}->[2] = CAA_COLOR_LIGHTGRAY;
124	$self->{lookup_colors}->[3] = CAA_COLOR_WHITE;
125
126	# These ones will be overwritten
127	$self->{lookup_colors}->[4] = CAA_COLOR_MAGENTA;
128	$self->{lookup_colors}->[5] = CAA_COLOR_LIGHTMAGENTA;
129	$self->{lookup_colors}->[6] = CAA_COLOR_RED;
130	$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
146sub draw_bitmap{
147	my ($self, $x1, $y1, $x2, $y2, $image) = @_;
148
149	my $w = $x2-$x1;
150	my $h = $y2-$y1;
151
152	my $iw = 0;
153	my $ih = 0;
154	my $h_pad = 0;
155	my $v_pad = 0;
156
157	if (defined $image){
158
159		# resize to fit in the box
160
161		$image->Scale('100%,67%');
162		my $x = $image->Resize(geometry => ($w-2).'x'.($h-2));
163		warn "$x" if "$x";
164
165		($iw, $ih) = $image->Get('columns', 'rows');
166
167		$h_pad = 1 + int(($w - $iw) / 2);
168		$v_pad = 1 + int(($h - $ih) / 2);
169	}
170
171	$self->init_instance();
172	$self->{driver}->init();
173
174
175	# Only used when background is black
176
177	my $white_colors = [
178		CAA_COLOR_BLACK,
179		CAA_COLOR_DARKGRAY,
180		CAA_COLOR_LIGHTGRAY,
181		CAA_COLOR_WHITE,
182	];
183
184	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	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	my $density_chars =
208		"    ".
209		".   ".
210		"..  ".
211		"....".
212		"::::".
213		";=;=".
214		"tftf".
215		'%$%$'.
216		"&KSZ".
217		"WXGM".
218		'@@@@'.
219		"8888".
220		"####".
221		"????";
222
223	my @density_chars = split //, $density_chars;
224	$density_chars = \@density_chars;
225
226	my $density_chars_size = scalar(@{$density_chars}) - 1;
227
228	my $x = 0;
229	my $y = 0;
230	my $deltax = 0;
231	my $deltay = 0;
232
233
234	my $tmp;
235	if ($x1 > $x2){ $tmp = $x2; $x2 = $x1; $x1 = $tmp; }
236	if ($y1 > $y2){ $tmp = $y2; $y2 = $y1; $y1 = $tmp; }
237
238	$deltax = $x2 - $x1 + 1;
239	$deltay = $y2 - $y1 + 1;
240
241
242	for ($y = $y1 > 0 ? $y1 : 0; $y <= $y2; $y++){
243	$self->{dither}->init($y);
244	for ($x = $x1 > 0 ? $x1 : 0; $x <= $x2; $x++){
245
246		my $ch = 0;
247		my $r = 0;
248		my $g = 0;
249		my $b = 0;
250		my $a = 0;
251		my $hue = 0;
252		my $sat = 0;
253		my $val = 0;
254		my $fromx = 0;
255		my $fromy = 0;
256		my $tox = 0;
257		my $toy = 0;
258		my $myx = 0;
259		my $myy = 0;
260		my $dots = 0;
261		my $outfg = 0;
262		my $outbg = 0;
263		my $outch = chr 0;
264
265		#  First get RGB
266
267		if (defined $image){
268
269			my $px = ($x - $x1) - $h_pad;
270			my $py = ($y - $y1) - $v_pad;
271
272			my $to_l = $px < 0;
273			my $to_t = $py < 0;
274			my $to_r = $px >= $iw;
275			my $to_b = $py >= $ih;
276
277			if ($to_l || $to_t || $to_r || $to_b){
278
279				$r = 0xfff;
280				$g = 0xfff;
281				$b = 0xfff;
282
283			}else{
284
285				($r, $g, $b, $a) = split /,/, $image->Get("pixel[$px,$py]");
286
287				$r >>= 4;
288				$g >>= 4;
289				$b >>= 4;
290			}
291
292			#if (bitmap->has_alpha && a < 0x800) continue;
293
294			# Now get HSV from RGB
295			($hue, $sat, $val) = $self->rgb2hsv_default($r, $g, $b);
296
297		}else{
298
299			$hue = int(0x5fff * (($x-$x1) / ($x2-$x1)));
300			$sat = int(0xfff * (($y-$y1) / ($y2-$y1)));
301			$val = int(0xfff * (($y-$y1) / ($y2-$y1)));
302			$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		if ($self->{solid_background}){
310
311			my $point = chr 0;
312			my $distfg = 0;
313			my $distbg = 0;
314
315			$self->{lookup_colors}->[4] = $dark_colors->[1 + $hue / 0x1000];
316			$self->{lookup_colors}->[5] = $light_colors->[1 + $hue / 0x1000];
317			$self->{lookup_colors}->[6] = $dark_colors->[$hue / 0x1000];
318			$self->{lookup_colors}->[7] = $light_colors->[$hue / 0x1000];
319
320			my $idx_v = ($val + $self->{dither}->get() * (0x1000 / CAA_LOOKUP_VAL) / 0x100) * (CAA_LOOKUP_VAL - 1) / 0x1000;
321			my $idx_s = ($sat + $self->{dither}->get() * (0x1000 / CAA_LOOKUP_SAT) / 0x100) * (CAA_LOOKUP_SAT - 1) / 0x1000;
322			my $idx_h = (($hue & 0xfff) + $self->{dither}->get() * (0x1000 / CAA_LOOKUP_HUE) / 0x100) * (CAA_LOOKUP_HUE - 1) / 0x1000;
323
324			$point = $self->{hsv_distances}->[$idx_v]->[$idx_s]->[$idx_h];
325
326			$distfg = $self->HSV_DISTANCE($hue % 0xfff, $sat, $val, ($point >> 4));
327			$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			if ($distbg > $distfg){ $distbg = $distfg; }
333
334			$outfg = $self->{lookup_colors}->[($point >> 4)];
335			$outbg = $self->{lookup_colors}->[($point & 0xf)];
336
337			$ch = $distbg * 2 * ($density_chars_size - 1) / ($distbg + $distfg);
338			$ch = 4 * $ch + $self->{dither}->get() / 0x40;
339
340			if ($ch >= scalar(@{$density_chars})){
341
342				$ch = scalar(@{$density_chars}) - 1;
343			}
344
345			$outch = $density_chars->[$ch];
346
347		}else{
348
349			$outbg = CAA_COLOR_BLACK;
350
351			if ($sat < 0x200 + $self->{dither}->get() * 0x8){
352
353				$outfg = $white_colors->[1 + ($val * 2 + $self->{dither}->get() * 0x10) / 0x1000];
354
355			}elsif ($val > 0x800 + $self->{dither}->get() * 0x4){
356
357				$outfg = $light_colors->[($hue + $self->{dither}->get() * 0x10) / 0x1000];
358
359			}else{
360				$outfg = $dark_colors->[($hue + $self->{dither}->get() * 0x10) / 0x1000];
361			}
362
363			$ch = ($val + 0x2 * $self->{dither}->get()) * 10 / 0x1000;
364			$ch = 4 * $ch + $self->{dither}->get() / 0x40;
365
366			$outch = $density_chars->[$ch];
367		}
368
369		# Now output the character
370		$self->{driver}->set_color($outfg, $outbg);
371		$self->{driver}->putchar($x, $y, $outch);
372
373		$self->{dither}->increment();
374	}
375	}
376
377	$self->{driver}->fini();
378}
379
380sub rgb2hsv_default {
381	my ($self, $r, $g, $b) = @_;
382
383	my ($hue, $sat, $val) = (0, 0, 0);
384
385	my $min = $r;
386	my $max = $r;
387
388	$min = $g if $min > $g;
389	$max = $g if $max < $g;
390	$min = $b if $min > $b;
391	$max = $b if $max < $b;
392
393	my $delta = $max - $min; # 0 - 0xfff
394	$val = $max; # 0 - 0xfff
395
396	if ($delta){
397
398		$sat = 0xfff * $delta / $max; # 0 - 0xfff
399
400		# Generate *hue between 0 and 0x5fff
401
402		if ($r == $max){
403			$hue = 0x1000 + 0x1000 * ($g - $b) / $delta;
404		}elsif ($g == $max){
405			$hue = 0x3000 + 0x1000 * ($b - $r) / $delta;
406		}else{
407			$hue = 0x5000 + 0x1000 * ($r - $g) / $delta;
408		}
409	}else{
410		$sat = 0;
411		$hue = 0;
412	}
413
414	return ($hue, $sat, $val);
415}
416
417
418sub HSV_DISTANCE{
419	my ($self, $h, $s, $v, $index) = @_;
420
421	my $v1 = $v - $self->{hsv_palette}->[$index * 4 + 3];
422	my $s1 = $s - $self->{hsv_palette}->[$index * 4 + 2];
423	my $h1 = $h - $self->{hsv_palette}->[$index * 4 + 1];
424
425	my $s2 = $self->{hsv_palette}->[$index * 4 + 3] ? CAA_HSV_YRATIO * $s1 * $s1 : 0;
426	my $h2 = $self->{hsv_palette}->[$index * 4 + 2] ? CAA_HSV_HRATIO * $h1 * $h1 : 0;
427
428	return $self->{hsv_palette}->[$index * 4] * ((CAA_HSV_XRATIO * $v1 * $v1) + $s2 + $h2);
429}
430
431sub load_submodule {
432	my ($self, $module, $args) = @_;
433
434	eval "require Image::Caa::$module";
435	warn $@ if $@;
436
437	my $obj = undef;
438	eval "\$obj = new Image::Caa::$module(\$args)";
439	warn $@ if $@;
440
441	if (!$@ && defined $obj){
442
443		return $obj;
444	}
445
446	die "Image::Caa - Couldn't load 'Image::Caa::$module'";
447}
448
4491;
450
451__END__
452
453=head1 NAME
454
455Image::Caa - Colored ASCII Art
456
457=head1 SYNOPSIS
458
459  use Image::Caa;
460  use Image::Magick;
461
462
463  # load an image
464
465  my $image = Image::Magick->new;
466  $image->Read('sunset.jpg');
467
468
469  # display it as ASCII Art
470
471  my $caa = new Image::Caa();
472  $caa->draw_bitmap(0, 0, 40, 20, $image);
473
474
475  # some fancy options
476
477  my $caa = new Image::Caa(
478    driver => 'DriverANSI',
479    dither => 'DitherOrdered8',
480    black_bg => 1,
481  );
482  $caa->draw_bitmap(0, 0, 40, 20, $image);
483
484=head1 DESCRIPTION
485
486This module outputs C<Image::Magick> image objects as ASCII Art, using a variety of output
487dithering modes and output drivers (currently supported is a plain old ANSI termical
488output driver and a curses driver).
489
490=head1 METHODS
491
492=over
493
494=item C<new( opt =E<gt> 'value', ... )>
495
496Returns a new C<Image::Caa> object. The options are as follows:
497
498=over
499
500=item * C<driver>
501
502Output driver. Valid values are:
503
504=over
505
506=item * C<DriverANSI> (default)
507
508=item * C<DriverCurses>
509
510=back
511
512=item * C<dither>
513
514Dithering mode. Valid values are:
515
516=over
517
518=item * C<DitherNone> (default)
519
520=item * C<DitherOrdered2>
521
522=item * C<DitherOrdered4>
523
524=item * C<DitherOrdered8>
525
526=item * C<DitherRandom>
527
528=back
529
530=item * C<black_bg>
531
532Set to 1 to enable black background mode.
533By default, we use colored backgrounds to allow 256 colors (16 foreground x 16 background)
534
535=item * C<window>
536
537Used only by the Curses output driver. Indicates the Curses window to write output into.
538
539=back
540
541=item C<draw_bitmap($x1, $y1, $x2, $y2, $image)>
542
543Draws the image C<$image> within the box bounded by C<($x1,$y1)-($x2,$y2)>.
544Note that the default (ANSI) output driver ignores the origin position as uses
545only the absolute box size.
546
547=back
548
549=head1 EXTENDING
550
551Both the dithering and driver backends are plugable and fairly easy to create - just create
552modules in the Image::Caa::* namespace. Dither modules need to implement the C<new()>,
553C<init($line)>, C<get()> and C<increment()> methods. Driver modules need to implement the
554C<new()>, C<init()>, C<set_color($fg, $bg)>, C<putchar($x, $y, $char)> and C<fini()> methods.
555Look at the existing modules for guidance.
556
557=head1 AUTHORS
558
559Copyright (C) 2006, Cal Henderson <cal@iamcal.com>
560
561This library is based on libcaca's bitmap.c
562
563libcaca is Copyright (C) 2004 Sam Hocevar <sam@zoy.org>
564
565libcaca is licensed under the GNU Lesser General Publice License
566
567=head1 SEE ALSO
568
569L<Image::Magick>, L<http://sam.zoy.org/libcaca/>
570
571=cut
572