File Coverage

blib/lib/PDLA/ImageRGB.pm
Criterion Covered Total %
statement 60 75 80.0
branch 15 34 44.1
condition 3 21 14.2
subroutine 13 14 92.8
pod 0 4 0.0
total 91 148 61.4


line stmt bran cond sub pod time code
1              
2             #
3             # GENERATED WITH PDLA::PP! Don't modify!
4             #
5             package PDLA::ImageRGB;
6              
7             @EXPORT_OK = qw( interlrgb rgbtogr bytescl cquant PDLA::PP cquant_c );
8             %EXPORT_TAGS = (Func=>[@EXPORT_OK]);
9              
10 14     14   555 use PDLA::Core;
  14         28  
  14         84  
11 14     14   106 use PDLA::Exporter;
  14         26  
  14         87  
12 14     14   75 use DynaLoader;
  14         34  
  14         1078  
13              
14              
15              
16            
17             @ISA = ( 'PDLA::Exporter','DynaLoader' );
18             push @PDLA::Core::PP, __PACKAGE__;
19             bootstrap PDLA::ImageRGB ;
20              
21              
22              
23              
24              
25             =head1 NAME
26              
27             PDLA::ImageRGB -- some utility functions for RGB image data handling
28              
29             =head1 DESCRIPTION
30              
31             Collection of a few commonly used routines involved in handling of RGB, palette
32             and grayscale images. Not much more than a start. Should be a good place to
33             exercise some of the thread/map/clump PP stuff.
34              
35             Other stuff that should/could go here:
36              
37             =over 3
38              
39             =item *
40             color space conversion
41              
42             =item *
43             common image filters
44              
45             =item *
46             image rebinning
47              
48             =back
49              
50             =head1 SYNOPSIS
51              
52             use PDLA::ImageRGB;
53              
54             =cut
55              
56              
57 14     14   97 use vars qw( $typecheck $EPS );
  14         30  
  14         826  
58              
59 14     14   114 use PDLA::Core;
  14         41  
  14         80  
60 14     14   104 use PDLA::Basic;
  14         36  
  14         138  
61 14     14   107 use PDLA::Primitive;
  14         33  
  14         104  
62 14     14   101 use PDLA::Types;
  14         31  
  14         1872  
63              
64 14     14   104 use Carp;
  14         36  
  14         829  
65 14     14   112 use strict 'vars';
  14         30  
  14         10533  
66              
67              
68             $PDLA::ImageRGB::EPS = 1e-7; # there is probably a more portable way
69              
70             =head1 FUNCTIONS
71              
72             =head2 cquant
73              
74             =for ref
75              
76             quantize and reduce colours in 8-bit images
77              
78             =for usage
79              
80             ($out, $lut) = cquant($image [,$ncols]);
81              
82             This function does color reduction for <=8bit displays and accepts 8bit RGB
83             and 8bit palette images. It does this through an interface to the ppm_quant
84             routine from the pbmplus package that implements the median cut routine which
85             intellegently selects the 'best' colors to represent your image on a <= 8bit
86             display (based on the median cut algorithm). Optional args: $ncols sets the
87             maximum nunmber of colours used for the output image (defaults to 256).
88             There are images where a different color
89             reduction scheme gives better results (it seems this is true for images
90             containing large areas with very smoothly changing colours).
91              
92             Returns a list containing the new palette image (type PDLA_Byte) and the RGB
93             colormap.
94              
95             =cut
96              
97             # full threading support intended
98             *cquant = \&PDLA::cquant;
99             sub PDLA::cquant {
100 0 0 0 0 0 0 barf 'Usage: ($out,$olut) = cquant($image[,$ncols])'
101             if $#_<0 || $#_>1;
102 0         0 my $image = shift;
103 0         0 my $ncols;
104 0 0       0 if ($#_ >= 0 ) { $ncols=shift; } else { $ncols = 256; };
  0         0  
  0         0  
105 0         0 my @Dims = $image->dims;
106 0         0 my ($out, $olut) = (null,null);
107              
108 0 0 0     0 barf "input must be byte (3,x,x)" if (@Dims < 2) || ($Dims[0] != 3)
      0        
109             || ($image->get_datatype != $PDLA_B);
110 0         0 cquant_c($image,$out,$olut,$ncols);
111 0         0 return ($out,$olut);
112             }
113              
114              
115             =head2 interlrgb
116              
117             =for ref
118              
119             Make an RGB image from a palette image and its lookup table.
120              
121             =for usage
122              
123             $rgb = $palette_im->interlrgb($lut)
124              
125             Input should be of an integer type and the lookup table (3,x,...). Will perform
126             the lookup for any N-dimensional input pdl (i.e. 0D, 1D, 2D, ...). Uses the
127             index command but will not dataflow by default. If you want it to dataflow the
128             dataflow_forward flag must be set in the $lut piddle (you can do that by saying
129             $lut->set_dataflow_f(1)).
130              
131             =cut
132              
133             # interlace a palette image, input as 8bit-image, RGB-lut (3,x,..) to
134             # (R,G,B) format for each pixel in the image
135             # should already support threading
136             *interlrgb=\&PDLA::interlrgb;
137             sub PDLA::interlrgb {
138 1     1 0 8 my ($pdl,$lut) = @_;
139 1         2 my $res;
140             # for our purposes $lut should be (3,z) where z is the number
141             # of colours in the lut
142 1 50       3 barf "expecting (3,x) input" if ($lut->dims)[0] != 3;
143             # do the conversion as an implicitly threaded index lookup
144 1 50       6 if ($lut->fflows) {
145 0         0 $res = $lut->xchg(0,1)->index($pdl->dummy(0));
146             } else {
147 1         27 $res = $lut->xchg(0,1)->index($pdl->dummy(0))->sever;
148             }
149 1         13 return $res;
150             }
151              
152              
153             =head2 rgbtogr
154              
155             =for ref
156              
157             Converts an RGB image to a grey scale using standard transform
158              
159             =for usage
160              
161             $gr = $rgb->rgbtogr
162              
163             Performs a conversion of an RGB input image (3,x,....) to a
164             greyscale image (x,.....) using standard formula:
165              
166             Grey = 0.301 R + 0.586 G + 0.113 B
167              
168             =cut
169              
170             # convert interlaced rgb image to grayscale
171             # will convert any (3,...) dim pdl, i.e. also single lines,
172             # stacks of RGB images, etc since implicit threading takes care of this
173             # should already support threading
174             *rgbtogr = \&PDLA::rgbtogr;
175             sub PDLA::rgbtogr {
176 1 50   1 0 9 barf "Usage: \$im->rgbtogr" if $#_ < 0;
177 1         3 my $im = shift;
178 1 50       14 barf "rgbtogr: expecting RGB (3,...) input"
179             if (($im->dims)[0] != 3);
180              
181 1         3 my $type = $im->get_datatype;
182 1         4 my $rgb = float([77,150,29])/256; # vector for rgb conversion
183 1         11 my $oim = null; # flag PP we want it to allocate
184 1         58 inner($im,$rgb,$oim); # do the conversion as a threaded inner prod
185              
186 1         9 return $oim->convert($type); # convert back to original type
187             }
188              
189             =head2 bytescl
190              
191             =for ref
192              
193             Scales a pdl into a specified data range (default 0-255)
194              
195             =for usage
196              
197             $scale = $im->bytescl([$top])
198              
199             By default $top=255, otherwise you have to give the desired top value as an
200             argument to C. Normally C doesn't rescale data that fits
201             already in the bounds 0..$top (it only does the type conversion if required).
202             If you want to force it to rescale so that the max of the output is at $top and
203             the min at 0 you give a negative $top value to indicate this.
204              
205             =cut
206              
207             # scale any pdl linearly so that its data fits into the range
208             # 0<=x<=$ncols where $ncols<=255
209             # returns scaled data with type converted to byte
210             # doesn't rescale but just typecasts if data already fits into range, i.e.
211             # data ist not necessarily stretched to 0..$ncols
212             # needs some changes for full threading support ?? (explicit threading?)
213             *bytescl = \&PDLA::bytescl;
214             sub PDLA::bytescl {
215 3 50   3 0 650 barf 'Usage: bytescl $im[,$top]' if $#_ < 0;
216 3         7 my $pdl = shift;
217 3         8 my ($top,$force) = (255,0);
218 3 50       13 $top = shift if $#_ > -1;
219 3 100       9 if ($top < 0) { $force=1; $top *= -1; }
  2         4  
  2         6  
220 3 50       10 $top = 255 if $top > 255;
221              
222 3 50       9 print "bytescl: scaling from 0..$top\n" if $PDLA::debug;
223 3         5 my ($max, $min);
224 3         20 $max = max $pdl;
225 3         10 $min = min $pdl;
226 3 100 33     42 return byte $pdl if ($min >= 0 && $max <= $top && !$force);
      66        
227              
228             # check for pathological cases
229 2 50       12 if (($max-$min) < $EPS) {
230 0 0       0 print "bytescl: pathological case\n" if $PDLA::debug;
231 0 0 0     0 return byte $pdl
      0        
232             if (abs($max) < $EPS) || ($max >= 0 && $max <= $top);
233 0         0 return byte ($pdl/$max);
234             }
235              
236 2 100       14 my $type = $pdl->get_datatype > $PDLA_F ? $PDLA_D : $PDLA_F;
237 2         8 return byte ($top*($pdl->convert($type)-$min)/($max-$min)+0.5);
238             }
239              
240             ;# Exit with OK status
241              
242             1;
243              
244             =head1 BUGS
245              
246             This package doesn't yet contain enough useful functions!
247              
248             =head1 AUTHOR
249              
250             Copyright 1997 Christian Soeller
251             All rights reserved. There is no warranty. You are allowed
252             to redistribute this software / documentation under certain
253             conditions. For details, see the file COPYING in the PDLA
254             distribution. If this file is separated from the PDLA distribution,
255             the copyright notice should be included in the file.
256              
257              
258             =cut
259              
260              
261              
262              
263              
264              
265              
266              
267              
268              
269             *cquant_c = \&PDLA::cquant_c;
270              
271              
272              
273             ;
274              
275              
276              
277             # Exit with OK status
278              
279             1;
280              
281