1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
|
#!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
|
