Skip to main content.

Web Based Programming Tutorials

Homepage | Forum - Join the forum to discuss anything related to programming! | Programming Resources

Perl 5 Unleashed

Chapter 29 -- Practical Scripts While Using Perl

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.

Statistical Applications

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.

Using Perl for Simple Statistical Routines

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.

Dot and Cross Products of Vectors

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.

Adding or Subtracting Vectors

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 }

Using Matrices

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:

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 }

Reading the Image

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);

Getting a Histogram

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.

The Filter

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.

An Added Touch

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.

A Parting Note

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

Summary

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.