Pastebin launched a little side project called VERYVIRAL.com, check it out ;-) Want more features on Pastebin? Sign Up, it's FREE!
Guest

Dark Shikari

By: a guest on Sep 3rd, 2009  |  syntax: Perl  |  size: 4.37 KB  |  views: 2,275  |  expires: Never
download  |  raw  |  embed  |  report abuse  |  print
Text below is selected. Please press Ctrl+C to copy to your clipboard. (⌘+C on Mac)
  1. #!/usr/bin/perl -ws
  2. # jpegrescan by Loren Merritt
  3. # Last updated: 2008-11-29
  4. # This code is public domain.
  5.  
  6. use File::Slurp;
  7. @ARGV==2 or die "usage: jpegrescan in.jpg out.jpg\ntries various progressive scan orders\n";
  8. $fin = $ARGV[0];
  9. $fout = $ARGV[1];
  10. $ftmp = "/tmp/$$.scan";
  11. $jtmp = "/tmp/$$.jpg";
  12. $verbose = $v;
  13. $quiet = $q;
  14. @restart = $r ? ("-restart", 1) : ();
  15. undef $_ for $v,$q,$r;
  16. undef $/;
  17. $|=1;
  18.  
  19. # convert the input to baseline, just to make all the other conversions faster
  20. # FIXME there's still a bunch of redundant computation in separate calls to jpegtran
  21. open $OLDERR, ">&", STDERR;
  22. open STDERR, ">", $ftmp;
  23. open TRAN, "-|", "jpegtran", "-v", "-optimize", $fin or die;
  24. write_file($jtmp, <TRAN>);
  25. close TRAN;
  26. open STDERR, ">&", $OLDERR;
  27.  
  28. $type = read_file($ftmp);
  29. $type =~ /components=(\d+)/ or die;
  30. $rgb = $1==3 ? 1 : $1==1 ? 0 : die "not RGB nor gray\n";
  31.  
  32. # FIXME optimize order for either progressive transfer or decoding speed
  33. sub canonize {
  34.     my $txt = $prefix.$suffix.shift;
  35.     $txt =~ s/\s*;\s*/;\n/g;
  36.     $txt =~ s/^\s*//;
  37.     $txt =~ s/ +/ /g;
  38.     $txt =~ s/: (\d+) (\d+)/sprintf ": %2d %2d", $1, $2/ge;
  39.     # treat u and v identically. I shouldn't need to do this, but with jpegtran overhead it saves 9% speed. cost: .008% bitrate.
  40.     $txt =~ s/^2:.*\n//gm;
  41.     $txt =~ s/^1:(.+)\n/1:$1\n2:$1\n/gm;
  42.     # dc before ac, coarse before fine
  43.     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;
  44.     return join "\n", @txt;
  45. }
  46.  
  47. sub try {
  48.     my $txt = canonize(shift);
  49.     return $memo{$txt} if $memo{$txt};
  50.     write_file($ftmp, $txt);
  51.     open TRAN, "-|", "jpegtran", "-scans", $ftmp, @restart, $jtmp or die;
  52.     $data = <TRAN>;
  53.     close TRAN;
  54.     my $s = length $data;
  55.     $s or die;
  56.     $memo{$txt} = $s;
  57.     !$quiet && print $verbose ? "$txt\n$s\n\n" : ".";
  58.     return $s;
  59. }
  60.  
  61. sub triesn {
  62.     my($bmode, $bsize);
  63.     my ($limit, @modes) = @_;
  64.     my $overshoot = 0;
  65.     for(@modes) {
  66.         my $s = try($_);
  67.         if(!$bsize || $s < $bsize) {
  68.             $bsize = $s;
  69.             $bmode = $_;
  70.             $overshoot = 0;
  71.         } elsif(++$overshoot >= $limit) {
  72.             last;
  73.         }
  74.     }
  75.     return $bmode;
  76. }
  77.  
  78. sub tries { triesn(99, @_); }
  79.  
  80. $prefix = "";
  81. $suffix = "";
  82.  
  83. if($rgb) {
  84.     # 012 helps very little
  85.     # 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
  86.     # dc refinement passes never help
  87.     $dc = tries("0: 0 0 0 0; 1 2: 0 0 0 0;",
  88.                 "0: 0 0 0 0; 1: 0 0 0 0; 2: 0 0 0 0;");
  89.     # jpegtran won't let me omit dc entirely, but I can at least quantize it away to make the rest of the tests faster.
  90.     $prefix = "0 1 2: 0 0 0 9;";
  91. } else {
  92.     $dc = "0: 0 0 0 0;";
  93.     $prefix = "0: 0 0 0 9;";
  94. }
  95.  
  96. # luma can make use of up to 3 refinement passes.
  97. # chroma can make use of up to 2 refinement passes.
  98. # refinement passes have some chance of being split (luma: 4%,4%,4%. chroma: 20%,8%) but the total bit gain is negligible.
  99. # msb pass should almost always be split (luma: 87%, chroma: 81%).
  100. # I have no theoretical reason for this list of split positions, they're just the most common in practice.
  101. # splitting into 3 ections is often slightly better, but the total number of bits saved is negligible.
  102. # FIXME: penalize lots of refinement passes because it's slower to decode. if so, then also force overwrite if bigger than the input.
  103. sub try_splits {
  104.     my $str = shift;
  105.     my %n = map {$_ => sprintf "$c: 1 %d $str; $c: %d 63 $str;", $_, $_+1} 2,5,8,12,18;
  106.     my $mode = triesn(2, "$c: 1 63 $str;", @n{2,8,5});
  107.     return $mode if $mode ne $n{8};
  108.     return triesn(1, $mode, @n{12,18});
  109. }
  110.  
  111. foreach $c (0..$rgb) {
  112.     my @modes;
  113.     my $ml = "";
  114.     for(0..($c?2:3)) {
  115.         push @modes, "$c: 1 8 0 $_; $c: 9 63 0 $_;".$ml;
  116.         $ml .= sprintf("$c: 1 63 %d %d;", $_+1, $_);
  117.     }
  118.     my $refine = triesn(1, @modes);
  119.     $refine =~ s/.* (0 \d);//;
  120.     $ac .= $refine . try_splits($1);
  121. }
  122.  
  123. $prefix = "";
  124. undef %memo;
  125. $mode = canonize($dc.$ac);
  126. try($mode);
  127. $size = $memo{$mode};
  128. !$quiet && print "\n$mode\n$size\n";
  129. $old_size = -s $fin;
  130. !$quiet && printf "%+.2f%%\n", ($size/$old_size-1)*100;
  131. if($size > $old_size && !@restart) {
  132.     $data = read_file($fin);
  133. }
  134. write_file($fout, $data);
  135. unlink $ftmp, $jtmp;