3 # Copyright 2001, Felix Ritter (Felix.Ritter@gmx.de)
5 # Original script (color mode) Copyright 2000,
6 # Andreas Widmann (widmann@rz.uni-leipzig.de)
8 # This script is free software; permission to use, copy, modify, and
9 # distribute this software and its documentation for any purpose without
10 # fee is hereby granted, provided that both the above copyright notice
11 # and this permission notice appear in all copies and in supporting
14 # This software is provided "as is" without express or implied warranty
19 print "gnuplot-boxfill.pl\n";
20 print " fills (and outlines) boxes in gnuplot 3.7.1 postscript files\n";
22 print " gnuplot-boxfill.pl [-c | -g | -p] [-o] [-r] [-z] <ps_in> <ps_out>\n";
24 print " -c color fill (default)\n";
25 print " -g gray fill\n";
26 print " -p pattern fill\n";
27 print " -o draw outline\n";
28 print " -r remove \"currentpoint stroke M\" (experimental!)\n";
29 print " -z outline zero height boxes (experimental!)\n";
31 print " <ps_in> postscript input file\n";
32 print " <ps_out> postscript output file\n";
39 $prolog = '/graymode true def
43 /dpiranges [ 2540 2400 1693 1270 1200 635 600 0 ] def
44 /PatFreq [ 10.5833 10.0 9.4055 10.5833 10.0 10.5833 10.0 9.375 ] def
46 /dpi 72 0 matrix defaultmatrix dtransform dup mul exch dup mul add sqrt def
49 0 1 dpiranges length 1 sub { dup dpiranges exch get 1 sub dpi le {exit} {pop} ifelse } for
52 /CurColors [ 0 0 0 1 0 0 0 1] def
54 /RealSetgray /setgray load def
55 /RealSetrgbcolor /setrgbcolor load def
58 3 { 3 index add 0 max 1 min 1 exch sub 3 1 roll} repeat
63 1 tintGray sub CurColors 0 4 getinterval aload pop
70 1 tintGray sub CurColors 4 3 getinterval aload pop
71 1 exch sub 3 index mul 1 exch sub 4 1 roll
72 1 exch sub 2 index mul 1 exch sub 4 1 roll
73 1 exch sub mul 1 exch sub 3 1 roll
76 /tintGray 1 1 CurGray sub CurColors 7 get mul sub def
78 [/Pattern [/DeviceCMYK]] setcolorspace
79 tintCMYK CurPat setcolor
81 CurColors 3 get 1.0 ge {
95 /patProcDict 5 dict dup begin
96 <0f1e3c78f0e1c387> { 3 setlinewidth -1 -1 moveto 9 9 lineto stroke
97 4 -4 moveto 12 4 lineto stroke
98 -4 4 moveto 4 12 lineto stroke} bind def
99 <0f87c3e1f0783c1e> { 3 setlinewidth -1 9 moveto 9 -1 lineto stroke
100 -4 4 moveto 4 -4 lineto stroke
101 4 12 moveto 12 4 lineto stroke} bind def
102 <8142241818244281> { 1 setlinewidth -1 9 moveto 9 -1 lineto stroke
103 -1 -1 moveto 9 9 lineto stroke } bind def
104 <03060c183060c081> { 1 setlinewidth -1 -1 moveto 9 9 lineto stroke
105 4 -4 moveto 12 4 lineto stroke
106 -4 4 moveto 4 12 lineto stroke} bind def
107 <8040201008040201> { 1 setlinewidth -1 9 moveto 9 -1 lineto stroke
108 -4 4 moveto 4 -4 lineto stroke
109 4 12 moveto 12 4 lineto stroke} bind def
111 /patDict 15 dict dup begin
115 /BBox [ 0 0 8 8 ] def
120 patProcDict bstring known {
121 patProcDict bstring get exec
123 8 8 true [1 0 0 -1 0 8] bstring imagemask
131 dup patCache exch known {
135 patDict /bstring 3 -1 roll put
137 65 PatFreq screenIndex get div dup matrix scale
140 patCache 4 -1 roll 3 -1 roll put
161 dup type /stringtype eq
169 array /fillvals exch def
170 dict /patCache exch def
175 fillvals 3 1 roll put
180 0 <03060c183060c081> DefPattern
181 1 <8040201008040201> DefPattern
182 2 <0f1e3c78f0e1c387> DefPattern
183 3 <0f87c3e1f0783c1e> DefPattern
184 4 <8142241818244281> DefPattern
185 5 <111111ff111111ff> DefPattern
188 $outlinestyle = 'LTb';
189 if(grep(/^-o$/, @ARGV) == 1) { $outline = "\ngsave\ncurrentpoint $outlinestyle M redo stroke\ngrestore" }
190 else { $outline = '' }
193 open(IN, $ARGV[$#ARGV - 1]) || die "Cannot open $ARGV[$#ARGV - 1]\n";
194 $content = join('', <IN>);
198 $key = '(-*\d+ -*\d+ M\n)(-*\d+)( -*\d+ V\n)(-*\d+ -*\d+ [RM]\n-*\d+ -*\d+ V\n-*\d+ -*\d+ V\n-*\d+ -*\d+ V\n-*\d+ -*\d+ V\n)';
199 #$key = '(-*\d+ -*\d+ M\n)(-*\d+)( -*\d+ V\n)(-*\d+ -*\d+ [RM]\n-*\d+ -*\d+ V\n-*\d+ -*\d+ V\n)'; #experimental
200 $box = '(?<!LTb)(\n-*\d+ -*\d+ [RM]\n)(-*\d+ -*\d+ V\n-*\d+ -*\d+ V\n-*\d+ -*\d+ V\n-*\d+ -*\d+ V)';
201 #$box = '(?<!LTb)(\n-*\d+ -*\d+ [RM]\n)(-*\d+ -*\d+ V\n-*\d+ -*\d+ V\n-*\d+ -*\d+ [LV]\n-*\d+ -*\d+ V)'; #experimental
202 $endComments = '(%%EndComments[ \t]*\n)';
203 $sftextcmd = '(/[LRC]show *{)(.*\n.*)(}.*def)';
204 $mftextcmd = '(/MFshow *{.*\n.*\n.*{)(show)(}.*\n.*} *bind *def)';
205 $ltTable = '(/LT)([0-8])( { PL \[.*\] ).* DL( } def)';
206 $bfDLPlace = '(/DL { Color)';
209 $content =~ s/(%%Title: ).*$/$1$ARGV[$#ARGV]/m;
210 $content =~ s/(%%Creator: ).*$/$1gnuplot-boxfill.pl/m;
211 $content =~ s/(%%CreationDate: ).*$/$1.localtime()/em;
213 #remove "currentpoint stroke M"
214 if(grep(/^-r$/, @ARGV) == 1) { $content =~ s/\ncurrentpoint stroke M\n/\n/g }
216 if(grep(/^-g$/, @ARGV) == 1) {
218 $content =~ s/$bfDLPlace/\/BfDL { Color {8 exch sub 4 div 1 sub 0.15 sub setgray Solid {pop []} if 0 setdash }\n {pop Solid {pop []} if 0 setdash} ifelse } def\n$1/;
219 $content =~ s/$ltTable/$1$2$3$2 BfDL$4/g;
221 #substitute boxplot commands
222 $content =~ s/$key/$1gsave\n\/redo \{0 vpt 1.25 div V $2 0 V 0 vpt 1.75 mul neg V $2 neg 0 V closepath\} bind def\ncurrentpoint M redo fill\ngrestore$outline\n$2 0 R\n$4/g;
223 $content =~ s/$box/$1gsave\n\/redo\{$2\} bind def\ncurrentpoint M redo fill\ngrestore$outline/g;
225 #modify text output commands
226 $content =~ s/$sftextcmd/$1gsave 0 setgray\n$2grestore\n$3/g;
227 $content =~ s/$mftextcmd/$1gsave 0 setgray $2 grestore$3/g;
229 elsif(grep(/^-p$/, @ARGV) == 1) {
230 #add postscript macros
231 $content =~ s/$endComments/$1$prolog\n/;
234 $content =~ s/$ltTable/$1$2$3$2 SetPattern$4/g;
236 #substitute boxplot commands
237 $content =~ s/$key/$1gsave\n\/redo \{0 vpt 1.25 div V $2 0 V 0 vpt 1.75 mul neg V $2 neg 0 V closepath\} bind def\ncurrentpoint currentpoint M redo gsave 1 setgray fill grestore M redo fill\ngrestore$outline\n$2 0 R\n$4/g;
238 $content =~ s/$box/$1gsave\n\/redo\{$2\} bind def\ncurrentpoint currentpoint M redo gsave 1 setgray fill grestore M redo fill\ngrestore$outline/g;
240 #modify text output commands
241 $content =~ s/$sftextcmd/$1gsave 0 setgray\n$2grestore\n$3/g;
242 $content =~ s/$mftextcmd/$1gsave 0 setgray $2 grestore$3/g;
245 #substitute boxplot commands
246 $content =~ s/$key/$1gsave\n\/redo \{0 vpt 1.25 div V $2 0 V 0 vpt 1.75 mul neg V $2 neg 0 V closepath\} bind def\ncurrentpoint M redo fill\ngrestore$outline\n$2 0 R\n$4/g;
247 $content =~ s/$box/$1gsave\n\/redo\{$2\} bind def\ncurrentpoint M redo fill\ngrestore$outline/g;
250 #outline zero height boxes
251 if(grep(/^-z$/, @ARGV) == 1) {
252 $boxshort = '(?<!LTb)(\n-*\d+ -*\d+ [RM]\n)(-*\d+ -*\d+ V\n-*\d+ -*\d+ V)(?!\n.*V\n)';
253 $content =~ s/$boxshort/$1gsave\n\/redo\{$2\} bind def\ncurrentpoint stroke M redo fill\ngrestore$outline/g;
256 #write to output file
257 open(OUT, ">$ARGV[$#ARGV]") || die "Cannot open $ARGV[$#ARGV]\n";
258 print OUT "$content";