Advertisement
Guest User

Untitled

a guest
Nov 4th, 2013
359
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
Perl 4.81 KB | None | 0 0
  1. #!/usr/bin/perl -ws
  2. # jpegrescan by Loren Merritt
  3. # Last updated: 2008-11-29 / 2013-03-19
  4. # This code is public domain.
  5.  
  6. use File::Slurp;
  7. use File::Temp qw/ tempfile /;
  8. use IPC::Run qw(start pump finish);
  9.  
  10. @ARGV==2 or die "usage: jpegrescan in.jpg out.jpg
  11. tries various progressive scan orders
  12. switches:
  13.  -s strip from all extra markers (`jpegtran -copy none` otherwise `jpegtran -copy all`)
  14.  -v verbose output
  15.  -q supress all output
  16.  -a use arithmetic coding (unsupported by most software)
  17. ";
  18. $fin = $ARGV[0];
  19. $fout = $ARGV[1];
  20. (undef, $ftmp) = tempfile(SUFFIX => ".scan");
  21. $jtmp = $fout;
  22. $verbose = $v;
  23. $quiet = $q;
  24. @strip = $s ? ("-copy","none") : ("-copy","all");
  25. @arith = $a ? ("-arithmetic") : ();
  26. undef $_ for $v,$q,$s,$a;
  27. undef $/;
  28. $|=1;
  29.  
  30. # convert the input to baseline, just to make all the other conversions faster
  31. # FIXME there's still a bunch of redundant computation in separate calls to jpegtran
  32. open $OLDERR, ">&", STDERR;
  33. open STDERR, ">", $ftmp;
  34. my $handle=start \("jpegtran", "-v", @strip, "-optimize", $fin),\$in,\$out,\$err;
  35. $in=$jtmp;
  36. pump $handle while length($in);
  37. finish $h or die "something is really wrong";
  38.  
  39. open STDERR, ">&", $OLDERR;
  40.  
  41. $type = read_file($ftmp);
  42. $type =~ /components=(\d+)/ or die;
  43. $rgb = $1==3 ? 1 : $1==1 ? 0 : die "not RGB nor gray\n";
  44.  
  45. # FIXME optimize order for either progressive transfer or decoding speed
  46. sub canonize {
  47.     my $txt = $prefix.$suffix.shift;
  48.     $txt =~ s/\s*;\s*/;\n/g;
  49.     $txt =~ s/^\s*//;
  50.     $txt =~ s/ +/ /g;
  51.     $txt =~ s/: (\d+) (\d+)/sprintf ": %2d %2d", $1, $2/ge;
  52.     # treat u and v identically. I shouldn't need to do this, but with jpegtran overhead it saves 9% speed. cost: .008% bitrate.
  53.     $txt =~ s/^2:.*\n//gm;
  54.     $txt =~ s/^1:(.+)\n/1:$1\n2:$1\n/gm;
  55.     # dc before ac, coarse before fine
  56.     my @txt = sort {"$a\n$b" =~ /: *(\d+) .* (\d);\n.*: *(\d+) .* (\d);/ or die; !$3 <=> !$1 or $4 <=> $2 or $a cmp $b;} split /\n/, $txt;
  57.     return join "\n", @txt;
  58. }
  59.  
  60. sub try {
  61.     my $txt = canonize(shift);
  62.     return $memo{$txt} if $memo{$txt};
  63.     write_file($ftmp, $txt);
  64.     open TRAN, "-|", "jpegtran", @arith, @strip, "-scans", $ftmp, $jtmp or die;
  65.     $data = <TRAN>;
  66.     close TRAN;
  67.     my $s = length $data;
  68.     $s or die;
  69.     $memo{$txt} = $s;
  70.     !$quiet && print $verbose ? "$txt\n$s\n\n" : ".";
  71.     return $s;
  72. }
  73.  
  74. sub triesn {
  75.     my($bmode, $bsize);
  76.     my ($limit, @modes) = @_;
  77.     my $overshoot = 0;
  78.     for(@modes) {
  79.         my $s = try($_);
  80.         if(!$bsize || $s < $bsize) {
  81.             $bsize = $s;
  82.             $bmode = $_;
  83.             $overshoot = 0;
  84.         } elsif(++$overshoot >= $limit) {
  85.             last;
  86.         }
  87.     }
  88.     return $bmode;
  89. }
  90.  
  91. sub tries { triesn(99, @_); }
  92.  
  93. $prefix = "";
  94. $suffix = "";
  95.  
  96. if($rgb) {
  97.     # 012 helps very little
  98.     # 0/12 and 0/1/2 are pretty evenly matched in frequency, but 0/12 wins in total size if every image had to use the same mode
  99.     # dc refinement passes never help
  100.     $dc = tries(
  101.     #           "0: 0 0 0 0; 1 2: 0 0 0 0;", # two scans expose a bug in Opera <= 11.61
  102.                 "0: 0 0 0 0; 1: 0 0 0 0; 2: 0 0 0 0;");
  103.     # jpegtran won't let me omit dc entirely, but I can at least quantize it away to make the rest of the tests faster.
  104.     $prefix = "0 1 2: 0 0 0 9;";
  105. } else {
  106.     $dc = "0: 0 0 0 0;";
  107.     $prefix = "0: 0 0 0 9;";
  108. }
  109.  
  110. # luma can make use of up to 3 refinement passes.
  111. # chroma can make use of up to 2 refinement passes.
  112. # refinement passes have some chance of being split (luma: 4%,4%,4%. chroma: 20%,8%) but the total bit gain is negligible.
  113. # msb pass should almost always be split (luma: 87%, chroma: 81%).
  114. # I have no theoretical reason for this list of split positions, they're just the most common in practice.
  115. # splitting into 3 ections is often slightly better, but the total number of bits saved is negligible.
  116. # FIXME: penalize lots of refinement passes because it's slower to decode. if so, then also force overwrite if bigger than the input.
  117. sub try_splits {
  118.     my $str = shift;
  119.     my %n = map {$_ => sprintf "$c: 1 %d $str; $c: %d 63 $str;", $_, $_+1} 2,5,8,12,18;
  120.     my $mode = triesn(3, "$c: 1 63 $str;", @n{2,8,5});
  121.     return $mode if $mode ne $n{8};
  122.     return triesn(1, $mode, @n{12,18});
  123. }
  124.  
  125. foreach $c (0..$rgb) {
  126.     my @modes;
  127.     my $ml = "";
  128.     for(0..($c?2:3)) {
  129.         push @modes, "$c: 1 8 0 $_; $c: 9 63 0 $_;".$ml;
  130.         $ml .= sprintf("$c: 1 63 %d %d;", $_+1, $_);
  131.     }
  132.     my $refine = triesn(1, @modes);
  133.     $refine =~ s/.* (0 \d);//;
  134.     $ac .= $refine . try_splits($1);
  135. }
  136.  
  137. $prefix = "";
  138. undef %memo;
  139. $mode = canonize($dc.$ac);
  140. try($mode);
  141. $size = $memo{$mode};
  142. !$quiet && print "\n$mode\n$size\n";
  143. $old_size = -s $fin;
  144. !$quiet && printf "%+.2f%%\n", ($size/$old_size-1)*100;
  145. if($size <= $old_size) {
  146.     write_file($fout, $data);
  147. }
  148. unlink $ftmp;
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement