2
pp_add_exported('',"interlrgb rgbtogr bytescl cquant ");
4
#include "pdlppm.h" /* Local decs */
8
############################## PM CODE ########################################
10
pp_addpm({At=>Top},<<'EOD');
14
PDL::ImageRGB -- some utility functions for RGB image data handling
18
Collection of a few commonly used routines involved in handling of RGB, palette
19
and grayscale images. Not much more than a start. Should be a good place to
20
exercise some of the thread/map/clump PP stuff.
22
Other stuff that should/could go here:
27
color space conversion
44
use vars qw( $typecheck $EPS );
55
$PDL::ImageRGB::EPS = 1e-7; # there is probably a more portable way
63
quantize and reduce colours in 8-bit images
67
($out, $lut) = cquant($image [,$ncols]);
69
This function does color reduction for <=8bit displays and accepts 8bit RGB
70
and 8bit palette images. It does this through an interface to the ppm_quant
71
routine from the pbmplus package that implements the median cut routine which
72
intellegently selects the 'best' colors to represent your image on a <= 8bit
73
display (based on the median cut algorithm). Optional args: $ncols sets the
74
maximum nunmber of colours used for the output image (defaults to 256).
75
There are images where a different color
76
reduction scheme gives better results (it seems this is true for images
77
containing large areas with very smoothly changing colours).
79
Returns a list containing the new palette image (type PDL_Byte) and the RGB
84
# full threading support intended
85
*cquant = \&PDL::cquant;
87
barf 'Usage: ($out,$olut) = cquant($image[,$ncols])'
91
if ($#_ >= 0 ) { $ncols=shift; } else { $ncols = 256; };
92
my @Dims = $image->dims;
93
my ($out, $olut) = (null,null);
95
barf "input must be byte (3,x,x)" if (@Dims < 2) || ($Dims[0] != 3)
96
|| ($image->get_datatype != $PDL_B);
97
cquant_c($image,$out,$olut,$ncols);
106
Make an RGB image from a palette image and its lookup table.
110
$rgb = $palette_im->interlrgb($lut)
112
Input should be of an integer type and the lookup table (3,x,...). Will perform
113
the lookup for any N-dimensional input pdl (i.e. 0D, 1D, 2D, ...). Uses the
114
index command but will not dataflow by default. If you want it to dataflow the
115
dataflow_forward flag must be set in the $lut piddle (you can do that by saying
116
$lut->set_dataflow_f(1)).
120
# interlace a palette image, input as 8bit-image, RGB-lut (3,x,..) to
121
# (R,G,B) format for each pixel in the image
122
# should already support threading
123
*interlrgb=\&PDL::interlrgb;
127
# for our purposes $lut should be (3,z) where z is the number
128
# of colours in the lut
129
barf "exspecting (3,x) input" if ($lut->dims)[0] != 3;
130
# do the conversion as an implicitly threaded index lookup
132
$res = $lut->xchg(0,1)->index($pdl->dummy(0));
134
$res = $lut->xchg(0,1)->index($pdl->dummy(0))->sever;
144
Converts an RGB image to a grey scale using standard transform
150
Performs a conversion of an RGB input image (3,x,....) to a
151
greyscale image (x,.....) using standard formula:
153
Grey = 0.301 R + 0.586 G + 0.113 B
157
# convert interlaced rgb image to grayscale
158
# will convert any (3,...) dim pdl, i.e. also single lines,
159
# stacks of RGB images, etc since implicit threading takes care of this
160
# should already support threading
161
*rgbtogr = \&PDL::rgbtogr;
163
barf "Usage: \$im->rgbtogr" if $#_ < 0;
165
barf "rgbtogr: exspecting RGB (3,...) input"
166
if (($im->dims)[0] != 3);
168
my $type = $im->get_datatype;
169
my $rgb = float([77,150,29])/256; # vector for rgb conversion
170
my $oim = null; # flag PP we want it to allocate
171
inner($im,$rgb,$oim); # do the conversion as a threaded inner prod
173
return $oim->convert($type); # convert back to original type
180
Scales a pdl into a specified data range (default 0-255)
184
$scale = $im->bytescl([$top])
186
By default $top=255, otherwise you have to give the desired top value as an
187
argument to C<bytescl>. Normally C<bytescl> doesn't rescale data that fits
188
already in the bounds 0..$top (it only does the type conversion if required).
189
If you want to force it to rescale so that the max of the output is at $top and
190
the min at 0 you give a negative $top value to indicate this.
194
# scale any pdl linearly so that its data fits into the range
195
# 0<=x<=$ncols where $ncols<=255
196
# returns scaled data with type converted to byte
197
# doesn't rescale but just typecasts if data already fits into range, i.e.
198
# data ist not necessarily stretched to 0..$ncols
199
# needs some changes for full threading support ?? (explicit threading?)
200
*bytescl = \&PDL::bytescl;
202
barf 'Usage: bytescl $im[,$top]' if $#_ < 0;
204
my ($top,$force) = (255,0);
205
$top = shift if $#_ > -1;
206
if ($top < 0) { $force=1; $top *= -1; }
207
$top = 255 if $top > 255;
209
print "bytescl: scaling from 0..$top\n" if $PDL::debug;
213
return byte $pdl if ($min >= 0 && $max <= $top && !$force);
215
# check for pathological cases
216
if (($max-$min) < $EPS) {
217
print "bytescl: pathological case\n" if $PDL::debug;
219
if (abs($max) < $EPS) || ($max >= 0 && $max <= $top);
220
return byte ($pdl/$max);
223
my $type = $pdl->get_datatype > $PDL_F ? $PDL_D : $PDL_F;
224
return byte ($top*($pdl->convert($type)-$min)/($max-$min)+0.5);
227
;# Exit with OK status
233
This package doesn't yet contain enough useful functions!
237
Copyright 1997 Christian Soeller <c.soeller@auckland.ac.nz>
238
All rights reserved. There is no warranty. You are allowed
239
to redistribute this software / documentation under certain
240
conditions. For details, see the file COPYING in the PDL
241
distribution. If this file is separated from the PDL distribution,
242
the copyright notice should be included in the file.
248
################################ XS CODE #################################
249
# a is the input image
250
# b is the output image and c the output lut
252
'cquant_c',Doc=>undef,
253
Pars => 'a(m,n,o); [o]b(n,o); [o]c(m,p);',
255
OtherPars => 'int psz => p',
257
if ($SIZE(m) != 3) barf("need RGB data (3,x,...)");
258
status = ppm_quant($P(a), NULL, NULL, $SIZE(n),
259
$SIZE(o),$P(b), NULL, $P(c), 0,
262
barf("ppm_quant returned error status");'
added
removed
Lib/ImageRGB/imagergb.pd
