anaglyph.pl

#!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)
  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

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 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 AUTHOR

Tony Cook <tony@imager.perl.org>

Thanks to Dan Oppenheim, who provided the impetus for this sample.

=head1 REVISION

$Revision$

=cut