about summary refs log tree commit diff
path: root/editor/ppmshadow
blob: ae6b1b0faf788f2f2c10ead6edab773c4b759adc (plain) (blame)
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
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
#!/bin/sh

##############################################################################
# This is essentially a Perl program.  We exec the Perl interpreter specifying
# this same file as the Perl program and use the -x option to cause the Perl
# interpreter to skip down to the Perl code.  The reason we do this instead of
# just making /usr/bin/perl the script interpreter (instead of /bin/sh) is
# that the user may have multiple Perl interpreters and the one he wants to
# use is properly located in the PATH.  The user's choice of Perl interpreter
# may be crucial, such as when the user also has a PERL5LIB environment
# variable and it selects modules that work with only a certain main
# interpreter program.
#
# An alternative some people use is to have /usr/bin/env as the script
# interpreter.  We don't do that because we think the existence and
# compatibility of /bin/sh is more reliable.
#
# Note that we aren't concerned about efficiency because the user who needs
# high efficiency can use directly the programs that this program invokes.
#
##############################################################################

exec perl -w -x -S -- "$0" "$@"

#!/usr/bin/perl
##############################################################################
#                              ppmshadow
##############################################################################
#
#            by John Walker  --  http://www.fourmilab.ch/
#                          version = 1.2;
#   --> with minor changes by Bryan Henderson to adapt to Netbpm.  
#   See above web site for the real John Walker work, named pnmshadow.
#
#   Bryan Henderson later made some major style changes (use strict, etc) and
#   eliminated most use of shells.  See Netbpm HISTORY file.
#
#   Pnmshadow is a brutal sledgehammer implemented in Perl which
#   adds attractive shadows to images, as often seen in titles
#   of World-Wide Web pages.  This program does not actually
#   *do* any image processing--it simply invokes components of
#   Jef Poskanzer's PBMplus package (which must be present on
#   the path when this script is run) to bludgeon the source
#   image into a plausible result.
#
#               This program is in the public domain.
#
##############################################################################

use strict;
use File::Temp;
require 5.0;
#  The good open() syntax, with the mode separate from the file name,
#  came after 5.0.  So did mkdir() with default mode.

my $true=1; my $false=0;



sub doVersionHack($) {
    my ($argvR) = @_;

    my $arg1 = $argvR->[0];

    if (defined($arg1) && (($arg1 eq "--version") || ($arg1 eq "-version"))) {
        my $termStatus = system('pamarith', '--version');
        exit($termStatus == 0 ? 0 : 1);
    }
}



sub imageDimensions($) {
    my ($fileName) = @_;
#-----------------------------------------------------------------------------
#  Return the dimensions of the Netpbm image in the file named $fileName.
#-----------------------------------------------------------------------------
    my ($width, $height, $depth);
    my $pamfileOutput = `pamfile $fileName`;
    if ($pamfileOutput =~
            m/.*\sP[BGP]M\s.*,\s*(\d*)\sby\s(\d*)\s*maxval\s(\d*)/) {
        ($width, $height, $depth) = ($1, $2, $3);
    } else {
        die("Unrecognized output from 'pamfile' shell command");
    }
    return ($width, $height, $depth);
}    

sub backgroundColor($) {
    my ($fileName) = @_;
#-----------------------------------------------------------------------------
#  Return the color of the backround of the image in the file named $fileName.
#-----------------------------------------------------------------------------
    # We call the color of the top left pixel the background color.

    my $ppmhistOut = qx{pamcut 0 0 1 1 $fileName | ppmhist -noheader -float};

    my ($ired, $igrn, $iblu, $lum, $count);

    if ($ppmhistOut =~
        m{\s*([01].\d+)\s*([01].\d+)\s*([01].\d+)\s*([01].\d+)\s*(\d+)}) {
        ($ired, $igrn, $iblu, $lum, $count) = ($1, $2, $3, $4, $5);
    } else {
        die("Unrecognized format of output from 'ppmhist' shell command");
    }
    my $irgb = sprintf("rgbi:%f/%f/%f", $ired, $igrn, $iblu);

    return $irgb;
}    



sub makeConvolutionKernel($$) {
    my ($convkernelfile, $ckern) = @_;

    #   Create convolution kernel file to generate shadow
    
    open(OF, ">$convkernelfile") or die();
    printf(OF "P2\n$ckern $ckern\n%d\n", $ckern * $ckern * 2);
    my $a = ($ckern * $ckern) + 1;
    my $i;
    for ($i = 0; $i < $ckern; $i++) {
        my $j;
        for ($j = 0; $j < $ckern; $j++) {
            printf(OF "%d%s", $a, ($j < ($ckern - 1)) ? " " : "\n");
        }
    }
    close(OF);
}



##############################################################################
#                           MAINLINE
##############################################################################

doVersionHack(\@ARGV);

#   Process command line options

my $ifile; # Input file name
my ($xoffset, $yoffset);

my $convolve = 11;                   # Default blur convolution kernel size
my $keeptemp = $false;               # Don't preserve intermediate files
my $translucent = $false;            # Default not translucent

while (@ARGV) {
    my $arg = shift;

    if ((substr($arg, 0, 1) eq '-') && (length($arg) > 1)) {
        my $opt;
        $opt = substr($arg, 1, 1);
        $opt =~ tr/A-Z/a-z/;
        if ($opt eq 'b') {        # -B n  --  Blur size
            if (!defined($convolve = shift)) {
                die("Argument missing after -b option\n");
            }
            if (($convolve < 11) && (($convolve & 1) == 0)) {
                $convolve++;      # Round up even kernel specification
            }
        } elsif ($opt eq 'k') {   # -K  --  Keep temporary files
            $keeptemp = $true;
        } elsif ($opt eq 't') {   # -T  --  Translucent image
            $translucent = $true;
        } elsif ($opt eq 'x') {   # -X n  --  X offset
            if (!defined($xoffset = shift)) {
                die("Argument missing after -x option\n");
            }
            if ($xoffset < 0) {
                $xoffset = -$xoffset;
            }
        } elsif ($opt eq 'y') {   # -Y n  --  Y offset
            if (!defined($yoffset = shift)) {
                die("Argument missing after -x option\n");
            }
            if ($yoffset < 0) {
                $yoffset = -$xoffset;
            }
        } else {
            die("Unknown option '$opt'\n");
        }
    } else {
        if (defined $ifile) {
            die("Duplicate input file specification.");
        }
        $ifile = $arg;   
    }
}

# Create temporary directory

my $tmpdir = $ENV{TMPDIR} || "/tmp";
my $ourtmp;

if ($keeptemp) {
    $ourtmp = "$tmpdir/ppmshadow$$";
    mkdir($ourtmp, 0777) or
        die("Unable to create directory for temporary files '$ourtmp");
} else {
    $ourtmp = File::Temp::tempdir("$tmpdir/ppmshadowXXXX", UNLINK=>1);
}

#   Apply defaults for arguments not specified

if (!(defined $xoffset)) {
    #   Xoffset defaults to half the blur distance
    $xoffset = int($convolve / 2);
}

if (!(defined $yoffset)) {
    #   Yoffset defaults to Xoffset, however specified
    $yoffset = $xoffset;
}

# Save the Standard Output open instance so we can use the STDOUT
# file descriptor to pass files to our children.
open(OLDOUT, ">&STDOUT");
select(OLDOUT);  # avoids Perl bug where it says we never use STDOUT 

my $infile = "$ourtmp/infile.ppm";

if (defined($ifile) && $ifile ne "-") {
    open(STDIN, "<$ifile") or die();
}
open(STDOUT, ">$infile") or die("Unable to open '$infile' as STDOUT");
system("ppmtoppm");

# You would think we could and should close stdin and stdout now, but if
# we do that, system() pipelines later on fail mysteriously.  They don't
# seem to be able to open stdin and stdout pipes properly if stdin and 
# stdout didn't already exist.  2002.09.07 BJH

my ($sourceImageWidth, $sourceImageHeight, $sourceImageDepth) =
    imageDimensions($infile);

my $bgColorIrgb = backgroundColor($infile);

# Create an all-background-color image (same size as original image),
# named $backgroundfile. 

my $backgroundfile = "$ourtmp/background.ppm";
system("ppmmake $bgColorIrgb $sourceImageWidth $sourceImageHeight " .
    "-maxval $sourceImageDepth " .
    ">$backgroundfile");

# Create mask file for background, named $bgmaskfile.  It is a PBM, white
# wherever there is background image in the input.

my $bgmaskfile = "$ourtmp/bgmask.pbm";
system("ppmchange -remainder=black $bgColorIrgb white $infile | " .
       "ppmtopgm | pgmtopbm -threshold -value=0.5 >$bgmaskfile"); 

my $ckern = $convolve <= 11 ? $convolve : 11;

my $convkernelfile = "$ourtmp/convkernel.pgm";

makeConvolutionKernel($convkernelfile, $ckern);

if ($translucent) {

    #   Convolve the input color image with the kernel
    #   to create a translucent shadow image.

    system("pnmconvol -quiet $convkernelfile $infile >$ourtmp/blurred.ppm");
    unlink("$convkernelfile") unless $keeptemp;
    while ($ckern < $convolve) {
        system("pnmsmooth $ourtmp/blurred.ppm >$ourtmp/convolvedx.ppm");
        rename("$ourtmp/convolvedx.ppm", "$ourtmp/blurred.ppm");
        ++$ckern;
    }
} else {

    #   Convolve the positive mask with the kernel to create shadow
 
    my $blurredblackshadfile = "$ourtmp/blurredblackshad.pgm";
    system("pamdepth -quiet $sourceImageDepth $bgmaskfile | " .
           "pnmconvol -quiet $convkernelfile >$blurredblackshadfile");
    unlink($convkernelfile) unless $keeptemp;

    while ($ckern < $convolve) {
        my $smoothedfile = "$ourtmp/smoothed.pgm";
        system("pnmsmooth $blurredblackshadfile >$smoothedfile");
        rename($smoothedfile, $blurredblackshadfile);
        ++$ckern;
    }

    #   Multiply the shadow by the background color

    system("pamarith -multiply $blurredblackshadfile $backgroundfile " .
           ">$ourtmp/blurred.ppm");
    unlink($blurredblackshadfile) unless $keeptemp;
}

#   Cut shadow image down to size of our frame.

my $shadowfile = "$ourtmp/shadow.ppm";
{
    my $width = $sourceImageWidth - $xoffset;
    my $height = $sourceImageHeight - $yoffset;
    open(STDIN, "<$ourtmp/blurred.ppm") or die();
    open(STDOUT, ">$shadowfile") or die();
    system("pamcut", "-left=0", "-top=0", 
           "-width=$width", "-height=$height");
}
unlink("$ourtmp/blurred.ppm") unless $keeptemp;


#   Paste shadow onto background.

my $shadbackfile = "$ourtmp/shadback.ppm";
open(STDOUT, ">$shadbackfile") or die();
system("pnmpaste", "-replace", $shadowfile, $xoffset, $yoffset,
       $backgroundfile);
unlink($shadowfile) unless $keeptemp;
unlink($backgroundfile) unless $keeptemp;


#   Create composite file, send to original Standard Output.

open(STDOUT, ">&OLDOUT");

system("pamcomp -invert -alpha $bgmaskfile $infile $shadbackfile");
unlink($bgmaskfile) unless $keeptemp;
unlink($infile) unless $keeptemp;
unlink($shadbackfile) unless $keeptemp;

if (!$keeptemp) {
    rmdir($ourtmp) or die ("Unable to remove temporary directory '$ourtmp'");
}