diff options
Diffstat (limited to 'Master/texmf-dist/doc/generic/pst-geo/pst-geo-compress.pl')
| -rw-r--r-- | Master/texmf-dist/doc/generic/pst-geo/pst-geo-compress.pl | 460 |
1 files changed, 460 insertions, 0 deletions
diff --git a/Master/texmf-dist/doc/generic/pst-geo/pst-geo-compress.pl b/Master/texmf-dist/doc/generic/pst-geo/pst-geo-compress.pl new file mode 100644 index 00000000000..051b37b4470 --- /dev/null +++ b/Master/texmf-dist/doc/generic/pst-geo/pst-geo-compress.pl @@ -0,0 +1,460 @@ +#!/usr/bin/env perl +use strict; +$^W=1; +# pst-geo-compress.pl +# Copyright (C) 2009 Heiko Oberdiek. +# +# This work may be distributed and/or modified under the +# conditions of the LaTeX Project Public License, either version 1.3 +# of this license or (at your option) any later version. +# The latest version of this license is in +# http://www.latex-project.org/lppl.txt +# and version 1.3 or later is part of all distributions of LaTeX +# version 2005/12/01 or later. +# +# This work has the LPPL maintenance status `maintained'. +# +# The Current Maintainer of this work is Heiko Oberdiek. +# +# See file "README" for a list of files that belong to this project. +my $file = "pst-geo-compress.pl"; +my $program = uc($&) if $file =~ /^\w+/; +my $version = "1.1"; +my $date = "2009/07/30"; +my $author = "Heiko Oberdiek"; +my $copyright = "Copyright (c) 2009 by $author."; +# History: +# 2009/07/30 v1.0: First release. +my $title = "$program $version, $date - $copyright\n"; +print $title; +my $prg_gs = "gs"; +$prg_gs = "gs386" if $^O =~ /dos/i; +$prg_gs = "gsos2" if $^O =~ /os2/i; +$prg_gs = "gswin32c" if $^O =~ /mswin32/i; +$prg_gs = "gswin32c" if $^O =~ /cygwin/i; +$prg_gs = "mgs" if defined($ENV{"TEXSYSTEM"}) and + $ENV{"TEXSYSTEM"} =~ /miktex/i; +my $prg_gstest = $prg_gs; + +my $data = 1; +my @bool = ('false', 'true'); +$::opt_help = 0; +$::opt_test = 0; +$::opt_gscmd = ''; +$::opt_gstestcmd = ''; + +my $usage = <<"END_OF_USAGE"; +Function: Compresses data files for pst-geo +Options: (defaults:) + --help print usage + --data1 | -1 .dat files from data.tgz ($bool[$data == 1]) + --data2 | -2 .dat files from dataII.tgz ($bool[$data == 2]) + --gscmd <name> call of ghostscript ($prg_gs) + --gstestcmd <name> call of ghostscript for testing ($prg_gstest) + --test test mode without compressing ($bool[$::opt_test]) +END_OF_USAGE +use Getopt::Long; +GetOptions( + "help!", + "test!", + "data1|1" => sub { $data = 1; }, + "data2|2" => sub { $data = 2; }, + "prediction!", + "gscmd=s", + "gstestcmd=s", +) or die $usage; +!$::opt_help or die $usage; + +$prg_gs = $::opt_gscmd if $::opt_gscmd; +if ($::opt_gstestcmd) { + $prg_gstest = $::opt_gstestcmd; +} +else { + $prg_gstest = $prg_gs; +} + +my $tmpfile = "__geo-pst-compress__$$.tmp"; +my $predict_threshold = 0.95; + +my @data1 = qw[ + aus.dat + canada.dat + capitals.dat + c-cap.dat + citysub.dat + corse.dat + c-sub.dat + france.dat + mex.dat + pborder.dat + pcoast.dat + pisland.dat + plake.dat + rhone.dat + ridge.dat + river.dat + seine.dat + transfrm.dat + trench.dat + usa.dat + wfraczon.dat + wmaglin.dat +]; + +my @data2 = qw[ + africa-bdy.dat + africa-cil.dat + africa-riv.dat + asia-bdy.dat + asia-cil.dat + asia-isl.dat + asia-riv.dat + c-cap.dat + citycapitals.dat + citysub.dat + c-sub.dat + europe-bdy.dat + europe-cil.dat + europe-riv.dat + namer-bdy.dat + namer-cil.dat + namer-pby.dat + namer-riv.dat + samer-arc.dat + samer-bdy.dat + samer-cil.dat + samer-riv.dat +]; + +my @data = ($data == 1) ? @data1 : @data2; + +my %city = ( + 'capitals.dat' => 1, + 'c-cap.dat' => 1, + 'citysub.dat' => 1, + 'c-sub.dat' => 1, + 'citycapitals.dat' => 1, +); + +my %predict = ( + # data 1 + 'pborder.dat' => 24, + 'pcoast.dat' => 24, + 'pisland.dat' => 25, + 'plake.dat' => 24, + 'ridge.dat' => 25, + 'river.dat' => 24, + 'seine.dat' => 26, + 'transfrm.dat' => 24, + 'trench.dat' => 25, + 'wfraczon.dat' => 25, + 'wmaglin.dat' => 25, + # data 2 + 'africa-cil.dat' => 22, + 'asia-cil.dat' => 23, + 'europe-riv.dat' => 21, + 'samer-cil.dat' => 23, +); + +my %array; + +sub catch_zap { + unlink $tmpfile if -f $tmpfile; + my $signame = shift; + chomp $signame; + die "!!! Aborted by SIG$signame!\n"; +} +$SIG{'INT'} = \&catch_zap; +$SIG{'__DIE__'} = sub { unlink $tmpfile if -f $tmpfile; }; + +sub tmp_open () { + open(TMP, '>', $tmpfile) or die "!!! Error: Cannot write `$tmpfile'!\n"; +} +sub file_open ($) { + my $file = shift; + open(IN, '<', $file) or die "!!! Error: Cannot open `$file'!\n"; +} + +sub tmp_move ($) { + my $file = shift; + close(IN); + close(TMP); + unlink $file or die "!!! Error: Cannot delete `$file'!\n"; + rename $tmpfile, $file or die "!!! Error: Cannot move `$tmpfile' to `$file'!\n"; +} + +# 1. sanitizing +print "\n"; +print "1. Sanitizing\n"; +print "=============\n"; + +foreach my $file (@data) { + if ($::opt_test) { + print "[skipping because of test mode]\n"; + last; + } + print "* $file\n"; + file_open $file; + my $old_line = <IN>; + not($old_line =~ /^%!PS/) + or die "!!! Error: File `$file' is already compressed!\n"; + $old_line =~ /\/([\w\-]+)(\s|\[)/ + or die "!!! Internal error: Name not found!\n"; + $array{$file} = $1; + $old_line =~ s/%.*$// unless $city{$file}; + $old_line =~ s/\s+$//; + tmp_open; + while (<IN>) { + if ($old_line and $old_line =~ /%/) { + print TMP "$old_line\n"; + $old_line = ''; + } + s/%.*$// unless $city{$file}; + s/^\s+//; + s/\s+$//; + /^\[%/ or s/(.)%.*$/$1/; + s/\s+$//; + s/([\[\]])\s+/$1/g; + s/\s+(\])/$1/g; + s/\s+/ /g; + if ($file eq 'seine.dat') { + s/(\[\d) /$1.000000000 /; + s/(\[\d\.\d) /${1}00000000 /; + s/(\[\d\.\d\d) /${1}0000000 /; + s/( \d+)\]/$1.00000000]/; + s/(\d\.\d)\]/${1}0000000]/; + s/(\d\.\d\d)\]/${1}000000]/; + } + if ($city{$file}) { + s/(\.0+)(\D)/$2/g; + s/(\.\d*[1-9])0+(\D)/$1$2/g; + s/(\D)0\./$1./g; + } + next unless $_; + if ($_ eq '[' or $_ eq ']' or $_ eq ']def' or $_ =~ /\[%/) { + $old_line .= $_; + next; + } + if ($_ eq 'def') { + $old_line .= $_; + $_ = ''; + } + if ($old_line) { + print TMP "$old_line\n"; + $old_line = ''; + } + print TMP "$_\n" if $_; + } + print TMP "$old_line\n" if $old_line; + tmp_move $file; +} +print "\n"; + +# 2. line length analysis +print "2. Line length analysis\n"; +print "=======================\n"; + +foreach my $file (@data) { + if ($::opt_test) { + print "[skipping because of test mode]\n"; + last; + } + print "* $file\n"; + my @lens; + my $num; + file_open $file; + while (<IN>) { + $num++; + my $len = length $_; + if ($lens[$len]) { + $lens[$len]++; + } + else { + $lens[$len] = 1; + } + } + close(IN); + my $max = 0; + for (my $i = 0; $i < @lens; $i++) { + next unless $lens[$i]; + $max = $i; + print " $i: $lens[$i]\n"; + my $threshold = $predict_threshold * $num; + next if $predict{$file}; + if (($lens[$i] > $threshold) or + ($lens[$i-1] and ($lens[$i-1] + $lens[$i] > $threshold)) or + ($lens[$i-1] and $lens[$i-2] and + ($lens[$i-2] + $lens[$i-1] + $lens[$i] > $threshold))) { + $predict{$file} = $i; + } + } + if ($predict{$file}) { + print " --> predict($file) = $predict{$file}\n"; + $predict{$file} == $max + or die "!!! Internal error: prediction ($predict{$file}) too small ($max)!\n"; + } + else { + print " --> predict($file) = ??\n"; + } +} +print "\n"; + +# 3. Prediction preparation +print "3. Prepare prediction\n"; +print "=====================\n"; + +foreach my $file (@data) { + if ($::opt_test) { + print "[skipping because of test mode]\n"; + last; + } + next unless $predict{$file}; + print "* $file\n"; + my $predict = $predict{$file}; + tmp_open; + file_open $file; + while (<IN>) { + my $len = length $_; + if ($len % $predict == 0) { + print TMP $_; + next; + } + chomp; + $_ .= ' ' x ($predict - ($len % $predict)); + $_ .= "\n"; + length($_) % $predict == 0 or die "!!! Internal Error!\n"; + print TMP $_; + } + tmp_move $file; +} +print "\n"; + +# 4. Compression +print "4. Compress files\n"; +print "=================\n"; + +sub check_gs_end () { + if ($? & 127) { + die sprintf "!!! Error: Ghostscript died with signal %d!\n", + ($? & 127); + } + elsif ($? != 0) { + die sprintf "!!! Error: Ghostscript exited with error code %d!\n", + $? >> 8; + } +} + +foreach my $file (@data) { + if ($::opt_test) { + print "[skipping because of test mode]\n"; + last; + } + print "* $file\n"; + my $predict = $predict{$file}; + my $filter_dict = ''; + $filter_dict = "<</Predictor 12/Columns $predict>>" if $predict; + my $compress_dict = "<</Effort 9>>"; + $compress_dict = "<</Effort 9/Predictor 12/Columns $predict>>" if $predict; + my $ps_code = <<"END_PS_CODE"; +%!PS +/buf 10000 string def +/tmpfilename ($tmpfile) def +/header (%!PS\\ncurrentfile$filter_dict/FlateDecode filter cvx exec\\n) def +($file) +% Convert file, stack: <file name> +( converting `) print dup print (' ... ) print flush +dup (r) file +% test if file is already converted +dup header length string readstring +{ + 1 index 0 setfileposition + header eq + { + (nothing to do.\\n) print flush + false + } + {true} + ifelse +} +{ + (read error.\\n) print flush + false +} +ifelse +{ + tmpfilename (w) file + dup header writestring + $compress_dict + /FlateEncode filter + exch + % stack: <input file name> <output file obj> <input file obj> + { + 2 copy + buf readstring + 3 1 roll + writestring + not {exit} if + } loop + closefile + closefile + dup deletefile tmpfilename exch renamefile + (done.\\n) print flush +} if +quit +%%EOF +END_PS_CODE + my @cmd = ( + $prg_gs, + '-q', + '-sDEVICE=nullpage', + '-dBATCH', + '-c', + $ps_code + ); + system @cmd; + check_gs_end; +} +print "\n"; + +# 5. Test +print "5. Testing\n"; +print "==========\n"; + +foreach my $file (@data) { + print "* $file\n"; + my $ps_code = <<"END_PS_CODE"; +%!PS +( testing `$file' ... ) print flush +($file) run +END_PS_CODE + $ps_code .= <<"END_PS_CODE" if $::opt_test; +(\\n) print flush +END_PS_CODE + $ps_code .= <<"END_PS_CODE" unless $::opt_test; +$array{$file} type /arraytype eq +{ + (ok.\\n) print flush +}{ + (FAILED!\\n) print flush + ioerror +} +ifelse +END_PS_CODE + $ps_code .= <<"END_PS_CODE"; +quit +%%EOF +END_PS_CODE + my @cmd = ( + $prg_gstest, + '-q', + '-sDEVICE=nullpage', + '-dBATCH', + '-c', + $ps_code + ); + system @cmd; + check_gs_end; +} + +print "\n"; +__END__ |