doc/charts/boxfill.pl

   1 #!/usr/bin/perl -w
   2
   3 # Copyright 2001, Felix Ritter (Felix.Ritter@gmx.de)
   4 #
   5 # Original script (color mode) Copyright 2000,
   6 # Andreas Widmann (widmann@rz.uni-leipzig.de)
   7 #
   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
  12 # documentation.
  13 #
  14 # This software is provided "as is" without express or implied warranty
  15 # of any kind.
  16
  17 #introstuff
  18 sub usage_info() {
  19   print "gnuplot-boxfill.pl\n";
  20   print "  fills (and outlines) boxes in gnuplot 3.7.1 postscript files\n";
  21   print "usage:\n";
  22   print "  gnuplot-boxfill.pl [-c | -g | -p] [-o] [-r] [-z] <ps_in> <ps_out>\n";
  23   print "options:\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";
  30   print "arguments:\n";
  31   print "  <ps_in>    postscript input file\n";
  32   print "  <ps_out>   postscript output file\n";
  33 }
  34 if ($#ARGV < 1) {
  35   &usage_info();
  36   exit(0);
  37 }
  38
  39 $prolog = '/graymode true def
  40
  41 /BfDict 400 dict def
  42
  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
  45
  46 /dpi 72 0 matrix defaultmatrix dtransform dup mul exch dup mul add sqrt def
  47
  48 /screenIndex {
  49         0 1 dpiranges length 1 sub { dup dpiranges exch get 1 sub dpi le {exit} {pop} ifelse } for
  50 } bind def
  51
  52 /CurColors [ 0 0 0 1 0 0 0 1] def
  53
  54 /RealSetgray /setgray load def
  55 /RealSetrgbcolor /setrgbcolor load def
  56 /RealSetcmykcolor {
  57         4 1 roll
  58         3 { 3 index add 0 max 1 min 1 exch sub 3 1 roll} repeat
  59         RealSetrgbcolor pop
  60 } bind def
  61
  62 /tintCMYK {
  63         1 tintGray sub CurColors 0 4 getinterval aload pop
  64         4 index mul 5 1 roll
  65         3 index mul 5 1 roll
  66         2 index mul 5 1 roll
  67         mul 4 1 roll
  68 }bind def
  69 /tintRGB {
  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
  74 }bind def
  75 /combineColor {
  76         /tintGray 1 1 CurGray sub CurColors 7 get mul sub def
  77         graymode not {
  78                 [/Pattern [/DeviceCMYK]] setcolorspace
  79                 tintCMYK CurPat setcolor
  80         } {
  81                 CurColors 3 get 1.0 ge {
  82                         tintGray RealSetgray
  83                 } {
  84                         graymode {
  85                                 tintCMYK
  86                                 RealSetcmykcolor
  87                         } {
  88                                 tintRGB
  89                                 RealSetrgbcolor
  90                         } ifelse
  91                 } ifelse
  92         } ifelse
  93 } bind def
  94
  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
 110 end def
 111 /patDict 15 dict dup begin
 112         /PatternType 1 def
 113         /PaintType 2 def
 114         /TilingType 3 def
 115         /BBox [ 0 0 8 8 ] def
 116         /XStep 8 def
 117         /YStep 8 def
 118         /PaintProc {
 119                 begin
 120                 patProcDict bstring known {
 121                         patProcDict bstring get exec
 122                 } {
 123                         8 8 true [1 0 0 -1 0 8] bstring imagemask
 124                 } ifelse
 125                 end
 126         } bind def
 127 end def
 128
 129 /setPatternMode {
 130         pop pop
 131         dup patCache exch known {
 132                 patCache exch get
 133         } {
 134                 dup
 135                 patDict /bstring 3 -1 roll put
 136                 patDict
 137                 65 PatFreq screenIndex get div dup matrix scale
 138                 makepattern
 139                 dup
 140                 patCache 4 -1 roll 3 -1 roll put
 141         } ifelse
 142         /CurGray 0 def
 143         /CurPat exch def
 144         /graymode false def
 145         combineColor
 146 } bind def
 147 /setGrayScaleMode {
 148         graymode not {
 149                 /graymode true def
 150         } if
 151         /CurGray exch def
 152         combineColor
 153 } bind def
 154
 155 BfDict begin [
 156         /fillvals
 157 ] { 0 def } forall
 158
 159 /SetPattern {
 160         fillvals exch get
 161         dup type /stringtype eq
 162         {8 1 setPatternMode}
 163         {setGrayScaleMode}
 164         ifelse
 165         } bind def
 166
 167 /InitPattern {
 168         BfDict begin dup
 169         array /fillvals exch def
 170         dict /patCache exch def
 171         end
 172         } def
 173 /DefPattern {
 174         BfDict begin
 175         fillvals 3 1 roll put
 176         end
 177         } def
 178
 179 7 InitPattern
 180 0 <03060c183060c081> DefPattern
 181 1 <8040201008040201> DefPattern
 182 2 <0f1e3c78f0e1c387> DefPattern
 183 3 <0f87c3e1f0783c1e> DefPattern
 184 4 <8142241818244281> DefPattern
 185 5 <111111ff111111ff> DefPattern
 186 6 0 DefPattern';
 187
 188 $outlinestyle = 'LTb';
 189 if(grep(/^-o$/, @ARGV) == 1) { $outline = "\ngsave\ncurrentpoint $outlinestyle M redo stroke\ngrestore" }
 190 else { $outline = '' }
 191
 192 #read input file
 193 open(IN, $ARGV[$#ARGV - 1]) || die "Cannot open $ARGV[$#ARGV - 1]\n";
 194 $content = join('', <IN>);
 195 close(IN);
 196
 197 #search patterns
 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)';
 207
 208 #substitute comments
 209 $content =~ s/(%%Title: ).*$/$1$ARGV[$#ARGV]/m;
 210 $content =~ s/(%%Creator: ).*$/$1gnuplot-boxfill.pl/m;
 211 $content =~ s/(%%CreationDate: ).*$/$1.localtime()/em;
 212
 213 #remove "currentpoint stroke M"
 214 if(grep(/^-r$/, @ARGV) == 1) { $content =~ s/\ncurrentpoint stroke M\n/\n/g }
 215
 216 if(grep(/^-g$/, @ARGV) == 1) {
 217   #modify colors
 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;
 220
 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;
 224
 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;
 228 }
 229 elsif(grep(/^-p$/, @ARGV) == 1) {
 230   #add postscript macros
 231   $content =~ s/$endComments/$1$prolog\n/;
 232
 233   #modify colors
 234   $content =~ s/$ltTable/$1$2$3$2 SetPattern$4/g;
 235
 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;
 239
 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;
 243 }
 244 else {
 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;
 248 }
 249
 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;
 254 }
 255
 256 #write to output file
 257 open(OUT, ">$ARGV[$#ARGV]") || die "Cannot open $ARGV[$#ARGV]\n";
 258 print OUT "$content";
 259 close(OUT);