yarrg/canon

   1 #!/usr/bin/perl -w
   2 use strict qw(refs vars);
   3 our %s;
   4 my $bs= $ARGV[2];
   5 foreach my $ab (qw(0 1)) {
   6     open F, "zcat $ARGV[$ab] |" or die $!;
   7     while (<F>) {
   8         chomp;
   9         my @l= split /\t/, $_, -1;
  10         @l == 6 or die "$#l";
  11         if ($bs) { @l= ($l[0],$l[1],$l[4],$l[5]); }
  12         next unless length $l[2];
  13         $l[3]='1001' if $l[3] eq '>1000';
  14         my $k= sprintf "%-31s\t%-23s", $l[1], $l[0];
  15         $s{$k}[$ab*2]= $l[2];
  16         $s{$k}[$ab*2+1]= $l[3];
  17     }
  18     close F or die $!;
  19 }
  20
  21 my $nextcommod=0;
  22 my %commodmap;
  23
  24 sub alencodenum ($) {
  25     my ($val) = @_;
  26     my $res= '';
  27     while ($val || !length($res)) {
  28         # allowing empty strings, reusing "0" for 62, doing base63,
  29         # saves 0.5%
  30         my $dig= $val % 62;
  31         $val= ($val-$dig) / 62;
  32         $res = chr($dig + ($dig<10 ? 48 :
  33                            $dig<36 ? 97-10 :
  34                            $dig<62 ? 65-36 : die $dig)) . $res;
  35     }
  36     return $res;
  37 }
  38
  39 sub findcommod ($) {
  40     my ($cname) = @_;
  41     my $me= $commodmap{$cname};  return $me if defined $me;
  42     my $val= $nextcommod++;
  43     $commodmap{$cname}= $val;
  44 #    printf "%s:%s\n", $res,$cname;
  45     return $val;
  46 }
  47
  48 my $laststall='';
  49
  50 foreach my $k (sort keys %s) {
  51     my @r= @{ $s{$k} };
  52     $k =~ m/\t/;
  53     my ($stall,$commod) = ($`,$');
  54
  55     my $eol= '';
  56     my $prep= sub {
  57         return if $eol;
  58         $eol="\n";
  59         if ($stall ne $laststall) {
  60             printf "\"%s\n", $stall;
  61             $laststall= $stall;
  62         }
  63         print alencodenum(findcommod($commod));
  64     };
  65
  66     if (!defined($r[2])) {
  67         $prep->();
  68         printf "\n"; # no "-" here saves 3.5%
  69         next;
  70     }
  71     # base62-encoding all these numbers saves about 8%
  72     my $qtydiff= $r[2] - ($r[0] || 0);
  73     if (!defined($r[0]) || $r[0] != $r[2]) {
  74         $prep->();
  75         printf "\@%s",alencodenum($r[2]);
  76     }
  77     if ($qtydiff>0) {
  78         $prep->();
  79         printf "+%s",alencodenum($qtydiff);
  80     } elsif ($qtydiff<0) {
  81         $prep->();
  82         printf "-%s",alencodenum(-$qtydiff);
  83     }
  84     print $eol;
  85 }