Guest User

Dark Shikari

a guest
Sep 3rd, 2009
4,165
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  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;
  136.  
RAW Paste Data

Adblocker detected! Please consider disabling it...

We've detected AdBlock Plus or some other adblocking software preventing Pastebin.com from fully loading.

We don't have any obnoxious sound, or popup ads, we actively block these annoying types of ads!

Please add Pastebin.com to your ad blocker whitelist or disable your adblocking software.

×