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 findcommod ($) {
  25     my ($cname) = @_;
  26     my $me= $commodmap{$cname};  return $me if defined $me;
  27     my $val= $nextcommod++;
  28     my $res= '';
  29     while ($val || !length($res)) {
  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));
  35     }
  36     $commodmap{$cname}= $res;
  37 #    printf "%s:%s\n", $res,$cname;
  38     return $res;
  39 }
  40
  41 my $laststall='';
  42
  43 foreach my $k (sort keys %s) {
  44     my @r= @{ $s{$k} };
  45     $k =~ m/\t/;
  46     my ($stall,$commod) = ($`,$');
  47
  48     my $eol= '';
  49     my $prep= sub {
  50         return if $eol;
  51         $eol="\n";
  52         if ($stall ne $laststall) {
  53             printf "\"%s\n", $stall;
  54             $laststall= $stall;
  55         }
  56         print findcommod($commod);
  57     };
  58
  59     if (!defined($r[2])) {
  60         $prep->();
  61         printf "-\n";
  62         next;
  63     }
  64     my $qtydiff= $r[2] - ($r[0] || 0);
  65     if (!defined($r[0]) || $r[0] != $r[2]) {
  66         $prep->();
  67         printf "\@%d",$r[2];
  68     }
  69     if ($qtydiff) {
  70         $prep->();
  71         printf "%+d",$qtydiff;
  72     }
  73     print $eol;
  74 }