#!perl -w
use strict;
use Imager;
use Getopt::Long;
my $grey;
my $pure;
my $green;
GetOptions('grey|gray|g'=>\$grey,
'pure|p' => \$pure,
'green' => \$green);
if ($grey && $pure) {
die "Only one of --grey or --pure can be used at a time\n";
}
my $left_name = shift;
my $right_name = shift;
my $out_name = shift
or usage();
my $left = Imager->new;
$left->read(file=>$left_name)
or die "Cannot load $left_name: ", $left->errstr, "\n";
my $right = Imager->new;
$right->read(file=>$right_name)
or die "Cannot load $right_name: ", $right->errstr, "\n";
$left->getwidth == $right->getwidth
&& $left->getheight == $right->getheight
or die "Images must be the same width and height\n";
$left->getwidth == $right->getwidth
or die "Images must have the same number of channels\n";
my $out;
if ($grey) {
$out = grey_anaglyph($left, $right);
}
elsif ($pure) {
$out = pure_anaglyph($left, $right, $green);
}
else {
$out = anaglyph_images($left, $right);
}
$out->write(file=>$out_name, jpegquality => 100)
or die "Cannot write $out_name: ", $out->errstr, "\n";
sub usage {
print <<EOS;
Usage: $0 left_image right_image out_image
EOS
exit;
}
sub anaglyph_images {
my ($left, $right) = @_;
my $expr = <<'EXPR'; # get red from $left, green, blue from $right
x y getp1 red x y getp2 !pix @pix green @pix blue rgb
EXPR
my $out = Imager::transform2 ({ rpnexpr=>$expr, }, $left, $right)
or die Imager->errstr;
$out;
}
sub grey_anaglyph {
my ($left, $right) = @_;
$left = $left->convert(preset=>'grey');
$right = $right->convert(preset=>'grey');
my $expr = <<'EXPR';
x y getp1 red x y getp2 red !right @right @right rgb
EXPR
return Imager::transform2({ rpnexpr=>$expr }, $left, $right);
}
sub pure_anaglyph {
my ($left, $right, $green) = @_;
$left = $left->convert(preset=>'grey');
$right = $right->convert(preset=>'grey');
my $expr;
if ($green) {
# output is rgb(first channel of left, first channel of right, 0)
$expr = <<'EXPR'
x y getp1 red x y getp2 red 0 rgb
EXPR
}
else {
# output is rgb(first channel of left, 0, first channel of right)
$expr = <<'EXPR';
x y getp1 red 0 x y getp2 red rgb
EXPR
}
return Imager::transform2({ rpnexpr=>$expr }, $left, $right);
}
=head1 NAME
=for stopwords anaglyph anaglyph.pl
anaglyph.pl - create a anaglyph from the source images
=head1 SYNOPSIS
# color anaglyph
perl anaglyph.pl left_input right_input output
# grey anaglyph
perl anaglyph.pl -g left_input right_input output
perl anaglyph.pl --grey left_input right_input output
perl anaglyph.pl --gray left_input right_input output
# pure anaglyph (blue)
perl anaglyph.pl -p left_input right_input output
perl anaglyph.pl --pure left_input right_input output
# pure anaglyph (green)
perl anaglyph.pl -p --green left_input right_input output
perl anaglyph.pl --pure --green left_input right_input output
=head1 DESCRIPTION
See L<http://www.3dexpo.com/anaglyph.htm> for an example where this might
be useful.
Implementation based on the description at
http://www.recordedlight.com/stereo/tutorials/ps/anaglyph/pstut04.htm
though obviously the interactive component is missing.
=head1 CAVEAT
Using JPEG as the output format is not recommended.
=head1 AUTHOR
Tony Cook <tonyc@cpan.org>
=for stopwords Oppenheim
Thanks to Dan Oppenheim, who provided the impetus for this sample.
=head1 REVISION
$Revision$
=cut