| О КОПИРАЙТАХ |
| Вся предоставленная на этом сервере информация собрана нами из разных источников. Если Вам кажется, что публикация каких-то документов нарушает чьи-либо авторские права, сообщите нам об этом. |
|
|
|
|
Chapter 29
Practical Scripts While Using
Perl
CONTENTS
Perl is a powerful language for prototyping applications. This
chapter introduces you to implementing some practical algorithms
using Perl as the base language. Once you have tested your algorithm
you can use another faster language, but during testing the Perl
interpreter will provide a quick turnaround for testing and debugging.
Perl programs can call the standard math library functions to
give you greater computing power. The following functions are
available to you as standard calls. All values of these functions
are sent and returned as radians:
| Atan2($y,$x);
| Returns the arc tangent in radians of the value of $y/$x. The value returned is always between PI and -PI. There is no
atan() function because of the floating-point error problem.
|
| cos($x);
| Returns cosine of $x.
|
| sin($x);
| Returns sine of $x.
|
| sqrt($x);
| Returns the square root of $x.
|
| log($x);
| Returns the natural log of $x.
|
| exp($x);
| Returns e to the power of $x.
|
| srand($x);
| Seeds the random number generator. |
| rand($x);
| Generates a random number based on the seed.
|
| time; |
Returns the number of seconds since Jan. 1, 1970.
|
| int($x);
| Returns the integer portion of $x. To get the fraction portion, use $x - int($x);.
|
For most applications, these routines will suffice. Perl is linked
with the math libraries for this function. Please check the man
pages for the details of how to use these standard library functions.
Listing 29.1 presents a simple application that uses two subroutines
to convert from polar to rectangular coordinates and then back
again.
Listing 29.1. Using the math functions in Perl.
1 #!/usr/bin/perl
2
3 #
4 # Simple statistical functions in Perl
5 #
6
7 use Getopt::Long;
8
9 #----------------------------------------------------------------
10 # Declare
any subroutines here
11 #----------------------------------------------------------------
12 sub toPolar($$); # Declare as taking two scalars
13 sub toRect($$); # Declare as taking
two scalars
14
15 *PI = \3.1415926;
16 *PIBY2 = $PI / 2;
17 *TODEG = \57.2958;
18 *TORAD = \0.01745;
19
20 GetOptions('x=i', 'y=i');
21
22 $x = $opt_x;
23 $y = $opt_y;
24
25 ($r,$theta) = &toPolar($x,$y);
26
27 printf "The polar coordinates for %6.3f,%6.3f are \n",
$x,$y;
28 printf " r = %6.3f and theta %6.3f
or %6.3f degrees\n",
29 $r,$theta,
$theta * $TODEG;
30
31 ($x1,$y1) = toRect($r,$theta);
32
33 printf "Compare x,y (%6.3f,%6.3f) with ",
$x, $y, $x1, $y1;
34 printf " x1,y1 (%6.3f,%6.3f) \n", $x, $y, $x1, $y1;
35
36
37 sub toPolar { # ($$); #
Declare as taking two scalars
38 my ($x,$y) = @_;
39 my $r;
40 my $t;
41
42 $r = sqrt( $x * $x + $y
+ $y ) ;
43 $t = atan2($y,$x);
44
45 return($r,$t);
46
47 }
48 sub toRect { #($$); # Declare
as taking two scalars
49 my ($r,$t) = @_;
50 my $x;
51 my $y;
52
53 $x = $r * cos($t);
54 $y = $r * sin($t);
55
56 return($x,$y);
57 }
58
At line 37, the subroutine toPolar
uses a prototype to specify two input parameters using the ($$)
construct. Similarly, the toRect
function also takes two parameters with the ($$)
prototype. Both functions return two items each. The constants
declared in lines 17 and 18 are not used in this program but are
included only for reference or future use should you need them.
Let's add some more functionality to what you have just developed
in the code in Listing 29.1. Let's start by adding some simple
statistical routines.
Perhaps the most common function to perform on a list of numeric
values is to calculate the average and standard deviation. Listing
29.2 presents a function that returns these values given an array
of items.
Listing 29.2. Calculating the average and standard deviation.
1 #!/usr/bin/perl
2
3
4 #
5 # Simple statistical functions in Perl
6 #
7
8 use Getopt::Long;
9
10 #----------------------------------------------------------------
11 # Declare
any subroutines here
12 #----------------------------------------------------------------
13 sub stats(\@); # Declare as taking
reference to array.
14
15
16 GetOptions('file=s');
17 open (DATA,"$opt_file") || die "Cannot open
$opt_file \n";
18
19 $i = 0;
20 while ($line = <DATA>)
21 {
22 chop $line;
23 ($date,$hi[$i],$lo[$i],$day[$i])
= split(' ',$line);
24 $i++;
25 }
26
27 ($ave,$max,$min,$std) = &stats(\@day);
28
29 printf " Average = %6.2lf \n", $ave;
30 printf " Maximum = %6.2lf \n", $max;
31 printf " Minimum = %6.2lf \n", $min;
32 printf " Std Dev = %6.2lf \n", $std;
33
34 close DATA;
35
36
37 #
38 # Compute simple stats on incoming stream.
39 #
40
41 sub stats {
42 #
43 # Allow passing of array
either by reference or
44 # by its values.
45 #
46 my $a = ref($_[0]) ? $_[0]
: \@_;
47 my $count = $#{$a} + 1;
48
49 #
50 # Bail out in case of erroneous
data.
51 #
52 return(-1,-1,-1,-1) if ($count
< 2);
53
54 print "$count items
\n";
55 my $i;
56
57 #
58 # Initialize local variables.
The assignment to 0
59 # is unnecessary for all
scalars except $max and $min
60 # since Perl will initialize
them to zero for you.
61 #
62 my $min = $$a[0];
63 my $max = $$a[0];
64 my $sum = 0;
65 my $sum2 = 0;
66 my $ave = 0;
67 my $std = 0;
68
69 #
70 # Get the required statistics
71 #
72 for $i (@$a) {
73 $sum
+= $i;
74 $sum2
+= ($i * $i);
75 $max
= $i if ($max < $i);
76 $min
= $i if ($min > $i);
77 }
78 $ave = $sum/$count;
79 $std = (($sum2 - $sum *
$ave)/($count - 1));
80 #
81 # Return the list of values
back from function.
82 #
83 return ($ave,$max,$min,$std);
84 }
Look at line 23 in Listing 29.2. The data is stripped off into
columns for you to work with. The format of the data file has
the list of data points for each item in separate columns.
Also note that we are forcing the user to type in file=something
for this program to work. If you never intend on passing any parameters
to this program via the use of options, then it's better to use
ARGV[1]. However, you will
have to take care of things like missing or malformed strings
in ARGV[1].
The stats subroutine is also
defined via a prototype in line 13. Prototypes are discussed in
Chapter 2, "A Brief Introduction to
Perl." The stats subroutine
is shown to take only one parameter, which is a pointer to an
array.
Note how the input parameter to the stats
function is derived using the ref()
function call in line 46. If the passed parameter is a reference,
then the function uses the first argument; otherwise, $a
is assigned to the entire incoming argument list:
my $a = ref($_[0]) ? $_[0] : \@_;
The math operations are performed in lines 72 to 79. The results
of these calculations are returned in line 83. Listing 29.1 and
Listing 29.2 should be enough to get you started on creating more
complicated functions. For example, let's add two routines for
performing vector calculations.
Two subroutines that perform the cross and dot products of two
vectors are shown in Listing 29.3. A cross product of a vector
of length n and a vector
of length m will return a
matrix of size m ¥
n, whereas a dot product
of two vectors of the same size (i.e., m
= n) will return a scalar
value.
Listing 29.3. Vector functions.
1 #!/usr/bin/perl
2
3 #
4 # Simple statistical functions in Perl
5 #
6
7
8 #----------------------------------------------------------------
9 # Declare
any subroutines here
10 #----------------------------------------------------------------
11 sub xProduct(\@\@\@); # Declare as taking
two pointers to arrays
12 sub dProduct(\@\@); # Declare
as taking two pointers to arrays
13
14 @one = ( 2, 4, 3);
15 @two = ( 4, -1, 7);
16 @result = ();
17
18 $r = &dProduct(\@one,\@two);
19
20 print "\n Dot Product = $r \n";
21
22 &xProduct(\@one,\@two,\@result);
23
24 print "\n Cross Product = \n";
25 for ($i=0;$i<3;$i++)
{
26 for
($j=0;$j< 3;$j++) {
27 printf "
%4d", $result[$i][$j];
28 }
29 print "\n";
30 }
31
32 exit (0);
33 # ------------------------------------------------
34 # Returns dot product of two vectors.
35 # Takes two pointers to arrays as input
36 # Returns a scalar.
37 sub dProduct { #
38 my ($x,$y) = @_;
39 my $sum;
40 my $ct1 = $#{$x} + 1;
# items in $x
41 my $ct2 = $#{$y} + 1;
# items in $y
42 return undef if ($ct1 !=
$ct2) ;
43
44 for ($i=0;$i<$ct1;$i++)
{
45 $sum += $$x[$i] * $$y[$i];
46 }
47 return $sum;
48 }
49 # ------------------------------------------------
50 # Returns a cross product of two vectors.
51 # Takes two pointers to arrays as input
52 # Returns a two-dimensional array.
53 sub xProduct {
54 my ($x,$y) = @_;
55 my $i, $j, @array;
56 my $ct1 = $#{$x} + 1; #
items in $x
57 my $ct2 = $#{$y} + 1; #
items in $y
58 my $result = \@arrau;
59 for ($i=0;$i<$ct1;$i++)
{
60 for
($j=0;$j<$ct2;$j++) {
61 $$result[$i][$j]
= $$x[$i] * $$y[$i];
62 #
print " $i, $j, $$result[$i][$j] \n";
63 }
64 }
64 return ($result); return result.
65 }
Notice how the subroutines for the two functions are declared
at lines 11 and 12. At line 18, the script calls dProduct
to return the dot product of the two vectors. The return value
from the dProduct function
can also be undef if the
vectors are not the same size.
At line 22, you get the resulting cross product matrix of multiplying
the two vectors together. The size of the matrix is M¥N,
where M is the size of the first vector and N is the size of the
second vector passed into xProduct().
To return an entire result of a calculation instead of having
to pass the @result array,
you can rewrite the cross product function as shown in Listing
29.4. Line 9 now declares only two pointers to arrays into xProduct.
The array in xProduct is
referred to by reference as well at line 53. The reference, $result,
is returned to the caller in line 64. Note the @array,
even though declared as a my
variable, is not destroyed because the reference to it in $result
is returned by the xProduct
function. As long as the returned reference to the calling program
continues to be used, the space allocated for the @array
will not be destroyed.
It's quite straightforward to include the two functions to add
and subtract two vectors. These two subroutines are defined in
Listing 29.4 at lines 65 and 87, respectively.
The number of elements in each array passed into the functions
is kept in variables $ct1
and $ct2 (see lines 105 and
106). The counts are used in loops elsewhere in the code.
Listing 29.4. Calculations returning an array.
1 #!/usr/bin/perl
2
3 #---------------------------------------------------------------
4 # Vector
Arithmetic Routines for use in Perl.
5 # Copy these freely with NO RESTRICTIONS
AND NO WARRANTY!
6 #----------------------------------------------------------------
7 # Declare
thy subroutines here
8 #----------------------------------------------------------------
9 sub xProduct(\@\@); # Declare as taking
two pointers to arrays
10 sub dProduct(\@\@); # Declare as taking two
pointers to arrays
11 sub vAdd(\@\@); #
Declare as taking two pointers to arrays
12 sub vSubtract(\@\@); # Declare as taking two pointers
to arrays
13
14 # -------------------------------------------------------------------
15 # Test
with these vectors
16 # -------------------------------------------------------------------
17 @one = ( 2, 4, 3);
18 @two = ( 4, -1, 7);
19 @result = ();
20
21 print "\n Vector 1 = ";
22 for (@one) { printf " %4d", $_; }
23
24 print "\n Vector 2 = ";
25 for (@two) { printf " %4d", $_; }
26
27
28 # -------------------------------------------------------------------
29 # Test
Dot Product
30 # -------------------------------------------------------------------
31 $r = &dProduct(@one,@two);
32 print "\n Dot Product = $r \n";
33
34 # -------------------------------------------------------------------
35 # Test
Addition
36 # -------------------------------------------------------------------
37 @result = &vAdd(\@one,\@two);
38 print "\n Added = ";
39 for (@result) { printf
" %4d", $_; }
40
41 # -------------------------------------------------------------------
42 # Test
Subtraction
43 # -------------------------------------------------------------------
44 @result = &vSubtract(\@one,\@two);
45 print "\n Subtract = ";
46 for (@result) { printf
" %4d", $_; }
47
48 # -------------------------------------------------------------------
49 # Test
Cross Product
50 # -------------------------------------------------------------------
51 @result = &xProduct(\@one,\@two);
52
53 print "\n Cross Product = \n";
54 for ($i=0;$i<3;$i++)
{
55 for
($j=0;$j< 3;$j++) {
56 printf "
%4d", $result[$i][$j];
57
}
58 print "\n";
59 }
60
61 exit (0);
62
63 # -------------------------------------------------------------------
64 # Returns a vector that is the result of subtracting
one vector from
65 # another. Both vectors have to be the same size.
66 # -------------------------------------------------------------------
67 sub vAdd { # (\@\@); Declare as taking two
pointers to arrays
68 my ($x,$y) = @_;
69 my $ct1 = $#{$x} +
1; # items in $x
70 my $ct2 = $#{$y} +
1; # items in $y
71 return undef if ($ct1
!= $ct2) ;
72 my $i;
73 my @answer;
74
75 for ($i=0;$i<$ct1;$i++)
{
76 $answer[$i]
= $$x[$i] + $$y[$i];
77 }
78 return @answer;
79 }
80
81 # -------------------------------------------------------------------
82 # Returns a vector that is the result of subtracting
one vector from
83 # another. Both vectors have to be the same size.
84 # -------------------------------------------------------------------
85 sub vSubtract { # (\@\@); Declare as taking
two pointers to arrays
86 my ($x,$y) = @_;
87 my $ct1 = $#{$x} +
1; # items in $x
88 my $ct2 = $#{$y} +
1; # items in $y
89 return undef if ($ct1
!= $ct2) ;
90 my $i;
91 my @answer;
92
93 for ($i=0;$i<$ct1;$i++)
{
94 $answer[$i]
= $$x[$i] - $$y[$i];
95 }
96 return @answer;
97 }
98
99 # -------------------------------------------------------------------
100 # Returns a scalar that is a dot product of two vectors.
101 # -------------------------------------------------------------------
102 sub dProduct { # (\@\@); Declare as taking two
pointers to arrays
103 my ($x,$y) = @_;
104 my $sum;
105 my $ct1 = $#{$x} + 1; #
items in $x
106 my $ct2 = $#{$y} + 1; #
items in $y
107 return undef if ($ct1 !=
$ct2) ;
108
109 for ($i=0;$i<$ct1;$i++)
{
110 $sum += $$x[$i] * $$y[$i];
111 }
112 return $sum;
113 }
114
115 # ------------------------------------------------------------
116 # Returns an array that is the cross product of two vectors.
117 # ------------------------------------------------------------
118 sub xProduct { # (\@\@); Declare as taking two
pointers to arrays
119 my ($x,$y) = @_;
120 my @array;
121 my $result = \@array;
122 my $i, $j;
123 my $ct1 = $#{$x} + 1; #
items in $x
124 my $ct2 = $#{$y} + 1; #
items in $y
125
126 for ($i=0;$i<$ct1;$i++)
{
127 for
($j=0;$j<$ct2;$j++) {
128 $$result[$i][$j]
= $$x[$i] * $$y[$i];
129 #
print " $i, $j, $$result[$i][$j] \n";
130 }
131 }
132 return @array;
133 }
Just like with vectors, you can use Perl references on matrices.
As an example of developing code for a prototype, this section
covers the following items:
- Reading an ASCII PBM file
- Collecting histogram information to show
work with matrices in Perl
- Applying a 3¥3
convolution smoothing filter on the image
- Writing a resulting ASCII PBM file
This section covers the image shown in Figure 29.1. The image
is a black-and-white cartoon, but the techniques you'll learn
here can be applied to color images as well. Listing 29.5 contains
the complete code for developing the images shown in Figures 29.2
and 29.3.
Figure 29.1 : The unfiltered image.
Listing 29.5. The complete listing for reading and writing
PBM files.
1 #!/usr/bin/perl
2
3 #-------------------------------------------------------
4 # Read and write ASCII PPM
files
5 #-------------------------------------------------------
6 # Author: Kamran Husain 4.4.96
7 # NO WARRANTIES WHATSOEVER APPLY HERE!! Copy freely,
use
8 # at will, with no restrictions.
9 #-------------------------------------------------------
10 use Getopt::Long;
11 GetOptions('out=s');
12
13 open (TEXT,"pirate.ppm") || die "\n Cannot
open $!\n";
14 @image = ();
15 @hist = ();
16 ($wd, $ht, @image) = &readImage;
17 close <TEXT>;
18
19 print "@image ";
20 @hist = &getHistogram($ht,$wd,@image);
21
22 $ctr = 0;
23 $hi = $#hist + 1;
24
25 # ------------------------------------------------------
26 # Display histogram of image in memory
27 # ------------------------------------------------------
28 print "Histogram of image\n";
29 for ($i = 0; $i < $hi; $i++) {
30 if ($hist[$i] != 0) {
31 printf "[%3d]
= %5d ", $i, $hist[$i] ; $ctr++;
32 if
($ctr >= 5) {
33 $ctr
= 0;
34 print
"\n"
35 }
36 }
37 }
38
39 # ------------------------------------------------------
40 # Write to disk as unfiltered.
41 # ------------------------------------------------------
42 @convolve = ( 0.1, 0.1, 0.1,
43 0.1, 0.1,
0.1,
44 0.1, 0.1,
0.1);
45 print "\n Filter 1 applied";
46 &applyFilter3($wd,$ht,\@convolve,\@image);
47 &dumpImage ('filt1.ppm', $wd, $ht);
48
49 @convolve = ( 0.1, 0.0, 0.1,
50 0.0, 0.5,
0.0,
51 0.1, 0.0,
0.1);
52 print "\n Filter 2 applied";
53 &applyFilter3($wd,$ht,\@convolve,\@image);
54
55 &dumpImage ('filt2.ppm', $wd, $ht);
56
57 exit(0);
58
59 # ------------------------------------------------------
60 # Dump PPM file to disk given
file name,
61 # ht and width of image
62 # ------------------------------------------------------
63 sub dumpImage {
64
65 my $fname = shift
@_;
66 my $wd = shift @_;
67 my $ht = shift @_;
68 my $i,$j,$k,$v;
69
70 print "\n Writing file $fname $wd by $ht";
71
72 open (OUTPUT,">$fname") || die "Cannot
open $fname $! ";
73 select OUTPUT;
74 print "P3\n";
75 print "# Test output\n";
76 print "$wd $ht\n";
77 print "255\n";
78
79 $count = 0;
80 for($i=0;$i<$ht;$i++)
{
81 for($j=0;$j<$wd;$j++)
{
82 $v
= $$image[$i][$j];
83 printf
"%3d %3d %3d ", $v,$v,$v;
84 $count++;
85 if
(($count % 5) == 0) {
86 $count
= 0;
87 print
"\n";}
88 }
89 }
90 close OUTPUT;
91 select STDOUT;
92 }
93
94
95 # ------------------------------------------------------
96 # Read PPM file from disk given
file name,
97 # Return b/w version back along
with ht and width of
98 # image.
99 # ------------------------------------------------------
100 sub readImage { # (\@) for image data;
101 my @image;
102 my $result = \@image;
103 my $format = <TEXT>;
104 my $comment = <TEXT>;
105 $a = <TEXT>;
106 chop $a;
107 local ($cols, $rows) =
split(' ',$a);
108 local $colors = <TEXT>;
109 my $row = 0;
110 my $col = 0;
111 my $a;
112
113 $rows = int($rows);
114 $cols = int($cols);
115
116 while ($a = <TEXT>)
{
117 chop $a;
118 @words = split(' ',$a);
119 $count = $#words;
120
121 while (@words) {
122 ($r,$g,$b)
= splice(@words,0,3);
123 $$image[$row][$col]
= ($r+$g+$b)/3;
124 $col++;
125 if ($col
>= $cols) { $row++; $col = 0 }
126 }
127 }
128 return ($cols,$rows,@image);
129 }
130
131
132 # ------------------------------------------------------
133 # Calculate histogram of up to 256
colors in
134 # the passed image bytes.
135 # ------------------------------------------------------
136 sub getHistogram {
137 my ($rows,$cols,$img) =
@_;
138 my @image = @$img;
139 my @refered = ();
140 my $hst = \@refered;
141
142 my $i,$j,$k;
143
144 for($i=0;$i<$rows;$i++)
{
145
for($j=0;$j<$cols;$j++) {
146 $k
= $$image[$i][$j];
147 $$hst[$k]
+= 1;
148 }
149 }
150 return (@refered);
151 }
152
153
154 # ------------------------------------------------------
155 # Apply 3x3 filter to the image
156 # Return resulting image.
157 # ------------------------------------------------------
158 sub applyFilter3 {
159 my ($rows,$cols,$convolve,$img)
= @_;
160 my @fir = @$convolve;
161 my @image = @$img;
162 my $i,$j,$k,$v;
163
164 print "\n
Filter: $rows X $cols ";
165 for ($i=0; $i<9;$i++)
{
166 print "\[
$fir[$i] \]";
167 }
168 for($i=1;$i<$rows -1;$i++)
{
169 for($j=1;$j<$cols
- 1;$j++) {
170 $k
= $$image[$i-1][$j-1] * $fir[0] +
171 $$image[$i][$j-1] *
$fir[1] +
172 $$image[$i+1][$j-1]
* $fir[2] +
173 $$image[$i-1][$j] *
$fir[3] +
174 $$image[$i][$j] *
$fir[4] +
175 $$image[$i+1][$j] *
$fir[5] +
176 $$image[$i-1][$j+1] *
$fir[6] +
177 $$image[$i][$j+1] *
$fir[7] +
178 $$image[$i+1][$j+1]
* $fir[8];
179 $$image[$i][$j]
= int($k);
180 }
181 }
182 }
The format chosen for this example is the ASCII version of the
portable bitmap (PBM) file type PPM. There are two reasons for
choosing this format. First, it's simple to work with compared
to the more complicated GIF, pcX, and JPEG formats. The idea here
is to show how to use Perl to prototype algorithms, not discuss
graphics file formats. Second, the PBM utilities have some filters
and lots of conversion utilities for converting an image to a
format other than PBM if necessary. The downside of the ASCII
depiction is the slow speed in reading ASCII and the large amount
of disk space required for the image.
Obviously, after you prototype your algorithm, you'll want to
code the reading and writing of PBM files in a compiled and optimized
language such as C.
Following is the header for the image shown in Figures 29.1, 29.2,
and 29.3:
P3
# CREATOR: XV Version 3.10 Rev: 12/16/94
99 77
255
252 252 252 252 252 252 252 252 252 252 252 252 252 252 252
252 252 252 252 252 252 252 252 252 252 252 252 252 252 252
252 252 252 252 252 252 252 252 252 252 252 252 252 252 252
252 252 252 252 252 252 252 252 252 252 252 252 252 252 252
252 252 252 252 252 252 252 252 252 252 252 252 252 252 252
252 252 252 252 252 252 252 252 252 252 252 252 252 252 252
P3 is required for this image
file. The comment line concerning CREATOR
is optional, but you will have to compensate for its existence.
99 refers to the number of
columns in the image, 77
refers to the number of rows of pixels, and 255
refers to the highest color.
What follows next is the red/green/blue (RGB) content of each
pixel in the image. All images used in this chapter have 256 gray
levels, so the RGB values are all equal. There must be 99¥77¥3
distinct RGB values.
The code for reading these pixel RGB values knows when to start
a new row by reading the number of values per row and then incrementing
the row when it reaches the columns per row. Thus, the program
reads in three values at a time and then assigns each value to
an $$image array. Here's
the fragment of code to do this:
while ($a = <TEXT>) {
chop $a;
@words = split(' ',$a);
$count = $#words;
while (@words) {
($r,$g,$b) = splice(@words,0,3);
$$image[$row][$col] = ($r+$g+$b)/3;
$col++;
if ($col >= $cols) { $row++; $col = 0 }
}
}
The RGB values in this example are all equal, but this cannot
be guaranteed because you may be working with a color image. You
take the average of the RGB intensities to determine the average
intensity of a pixel by using the following line:
$$image[$row][$col] = ($r+$g+$b)/3;
instead of assuming grayscale images only and then using only
one value. I do take the liberty of allocating room (by default)
to 97¥88 because grayscale images
are used instead of color maps to get the average intensity of
a pixel.
The processing algorithm requires the dimensions of the file and
the data. These values are returned in the following line:
return ($cols,$rows,@image);
After the image has been read from disk into memory, you can run
some programs on it. The histogram routine to run on the image
is as follows:
sub getHistogram {
my ($rows,$cols,$img) = @_;
my @image = @$img;
my @refered = ();
my $hst = \@refered;
my $i,$j,$k;
for($i=0;$i<$rows;$i++) {
for($j=0;$j<$cols;$j++) {
$k
= $$image[$i][$j];
$$hst[$k]
+= 1;
}
}
return (@refered);
}
The reference to the @hst
array in the getHistogram
subroutine is called to store the accumulated values per pixel
in the image.
A simple 3¥3 matrix convolution
filter is used in this section. Two filters are shown in Listing
29.5. The first filter is a uniform gain filter, and the second
is for using a type of Gaussian filter. You can modify this code
to use your own filter.
The filter is applied with a call to applyFilter3.
In line 159, we pick up the $convolve
filter and the pointer to the $img.
The convolve filter is passed
to an array with nine elements: The first three elements are in
the row above the pixel, followed by three more at the center
of row, and then three immediately below the current row. The
filter is shown at line 42 as this:
@convolve = ( 0.1, 0.1, 0.1,
0.1, 0.1, 0.1,
0.1, 0.1, 0.1);
The second filter is shown at line 49 as this:
@convolve = ( 0.1, 0.0, 0.1,
0.0, 0.5, 0.0,
0.1, 0.0, 0.1);
The following lines are where the filter is applied and the results
are written to disk:
print "\n Filter 2 applied";
&applyFilter3($wd,$ht,\@convolve,\@image);
dumpImage ("filt1.ppm");
The output of these filters is shown in Figures 29.2 and 29.3.
The way the convolution matrix is applied to the image is shown
in lines 168 to 179 in Listing 29.5.
Figure 29.2 : The filtered image using the first filter.
Figure 29.3 : The filtered image using the second filter.
Note that a band is left around the image so as not to overrun
the extents of the image array. When prototyping for eventual
use in a formal language, keep the restrictions of the formal
language in mind.
Finally, the image is written to disk with the dumpImage
subroutine (shown in line 63). The calls to dump the image are
shown in lines 43 and 55.
To see the histograms in three dimensions, you can use the VRML.pm
module developed earlier in this book to generate a display. By
applying different filters and then generating 3D histograms of
the resulting image, you can get a pictorial view of how each
filter affects the output. The following lines of code are for
a subroutine, show3Dhistogram,
to create VRML cubes from the histogram array. Add this subroutine
to the end of the file shown in Listing 29.5:
1 use VRML;
2 use VRML::Cube;
3 use VRML::Cylinder;
4
5 sub show3Dhistogram {
6 open (VRMLFILE,">vrml1.wrl") || die "\n
Cannot open $!\n";
7 $oldfile = select VRMLFILE;
8 my $header = VRML::new();
9 $header->VRML::startHeader;
10 $header->VRML::startSeparator;
11 $width = 0.01;
12 my @cyl;
13 $hi = $#hist + 1;
14 for ($i = 0; $i < $hi; $i++) {
15 $v = $hist[$i] / 100;
16 if ($v > 0) {
17 $x = ($i * $width) % 16 ;
18 $y = ($i * $width) / 16 ;
19 $t = $header->VRML::putCube(
20 'width' =>
$width, 'height' => $v, 'depth' => $width,
21 'translation'
=> [$x,$y,0],
22 'ambientColor'
=> [$v,$v,$v]
23 );
24 }
25 }
26 $header->VRML::stopSeparator;
27 close VRMLFILE;
28 select $oldfile;
29 }
Note that in line 7, we take care to store away the file handle
of the current output file when we set the default file handle
to VRMLFILE with the select
call. The for loop in line
14 steps through the entire hist
array and generates code to print a cube. Lines 19 through 23
are the statements for generating VRML code for a cube. Line 26
terminates the VRML output. The file handle is used to close the
VRML output file in line 27. After the VRML output file is closed,
we reset the default file handle (in line 28) to whatever it was
prior to the select call.
The number of routines in this chapter (and other chapters, for
that matter) make it hard for me to look them up by name. You
can use the following script to quickly get listings of all the
subroutine functions you want in a bunch of source code files.
See Listing 29.6.
Listing 29.6. Printing the subroutines in source files.
1 #!/usr/bin/perl
2 #
3 # Display all the subroutines in the files on the command
line
4 #
5 while (<>) {
6 chop;
7 if (/^\s*sub\s+(\w+(?:[:`]+))?(\w+)/)
{
8 $name = $2;
9 print $ARGV, ":Line
$. :", "$name\n";
10 close(ARGV) if eof(); #
reset line numbers
11 }
12 }
The key line to look at is the search pattern defined in line
7:
/^\s*sub\s+(\w+(?:[:`]+))?(\w+)/
Basically, the first part \s*sub\s*
looks for all whitespaces (tabs and spaces) before and after the
string sub. Then it looks for an (
open parenthesis, followed by a word as specified by \w.
If the word that matches the \w
is followed by :: or a single
quote `, then it's considered
a class specification and accepted as such since the second question
mark ? allows for more than
one occurrence of such words. Note that we did not look for an
open curly brace for the subroutine code on the same line as the
subroutine declaration since the open curly brace may be on the
next line following the subroutine declaration.
The program shown in Listing 29.6 is not foolproof because it
looks for a very specific pattern in defining subroutines. However,
it will catch most subroutine definitions. The output from this
script gives you a listing of all subroutines declared in a file.
It even attempts to print subroutines in *.pm
files. Actually, this script can write out a tags file by replacing
the print line with the following
line:
print "$name\t$ARGV\t\/^$_\/\n"
Hope this will help you keep your functions in order! ;-)
This chapter is designed to show you how to use the techniques
you learned in the previous chapters of this book by developing
prototyping algorithms using Perl. The built-in mathematical and
array functions of Perl can be assets when used for developing
algorithms. In this chapter we worked on a filtering algorithm
for an image, as well as reading and archiving to disk. You even
can use previously developed modules and available tools to see
how your prototypes work.
Previous chapter Chapter contents Contents Next chapter
|
