chiark / gitweb /
Merge ijackson@chiark:/home/ijackson/things/ypp-sc-tools.pctb-dict-test
[ypp-sc-tools.main.git] / pctb / commod-results-processor
1 #!/usr/bin/perl -w
2
3 # helper program for processing commodity output
4
5 # This is part of ypp-sc-tools, a set of third-party tools for assisting
6 # players of Yohoho Puzzle Pirates.
7 #
8 # Copyright (C) 2009 Ian Jackson <ijackson@chiark.greenend.org.uk>
9 #
10 # This program is free software: you can redistribute it and/or modify
11 # it under the terms of the GNU General Public License as published by
12 # the Free Software Foundation, either version 3 of the License, or
13 # (at your option) any later version.
14 #
15 # This program is distributed in the hope that it will be useful,
16 # but WITHOUT ANY WARRANTY; without even the implied warranty of
17 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
18 # GNU General Public License for more details.
19 #
20 # You should have received a copy of the GNU General Public License
21 # along with this program.  If not, see <http://www.gnu.org/licenses/>.
22 #
23 # Yohoho and Puzzle Pirates are probably trademarks of Three Rings and
24 # are used without permission.  This program is not endorsed or
25 # sponsored by Three Rings.
26
27
28 use strict (qw(vars));
29 use HTTP::Request;
30 use IO::File;
31 use POSIX;
32 use LWP::UserAgent;
33 use XML::Parser;
34
35 # $commod{'Hemp'}{Buy|Sell}{'stall'}{Stall}
36 # $commod{'Hemp'}{Buy|Sell}{'stall'}{Price}
37 # $commod{'Hemp'}{Buy|Sell}{'stall'}{Qty}
38 # $commod{'Hemp'}{Hold}
39
40 our @v;
41 our ($commod,$stall,%commod);
42
43 @ARGV==1 or die "You probably don't want to run this program directly.\n";
44 our ($mode) = shift @ARGV;
45
46 # ./yppsc-commod-processor tsv <t |less -x40,80,90,100,110
47
48 sub bs_read ($$) {
49     my ($bs,$c) = @_;
50     return if @v <= $c;
51     my ($price,$qty) = @v[$c..$c+1];
52     return if !length($price) && !length($qty);
53     die "$_ ?" unless length($price) && length($qty);
54     $commod{$commod}{$bs}{$stall}= {
55         Stall => $stall,
56         Price => $price,
57         Qty => $qty,
58     };
59 }
60
61 while (<>) {
62     chomp;
63     @v= split /\t/;
64 #print STDERR "[".join("|",@v)."]\n";
65     ($commod,$stall) = @v;
66     bs_read(Buy,  2);
67     bs_read(Sell, 4);
68     $commod{$commod}{Hold}= $v[6]+0 if @v>6;
69 }
70
71 our $current;
72
73 sub bs_p ($$$) {
74     my ($commod,$bs,$sortmul) = @_;
75     my $ary= $current->{$bs};
76     my $r= [ ];
77 #print Dumper($ary);
78     foreach my $stall (sort {
79         $sortmul * ($ary->{$a}{Price} <=> $ary->{$b}{Price});
80     } keys %$ary) {
81         push @$r, $ary->{$stall};
82     }
83     return $r;
84 }
85
86 sub bs_p_bestprice ($) {
87     my ($l) = @_;
88     if (@$l) {
89         printf("| %-25.25s %4d", $l->[0]{Stall}, $l->[0]{Price}) or die $!;
90     } else {
91         printf("| %25s %4s","","") or die $!;
92     }
93 }
94
95 sub main__arbitrage () {
96     my @arbs= ();
97     foreach $commod (sort keys %commod) {
98         $current= $commod{$commod};
99         my @buys=  @{ bs_p($commod,Buy, -1) };
100         my @sells= @{ bs_p($commod,Sell,+1) };
101         my $profit= 0;
102         my $cqty= 0;
103         my $info= '';
104         my $arbs= [];
105         for (;;) {
106 #print Dumper($commod,\@buys,\@sells);
107             last unless @buys;
108             last unless @sells;
109             my $pricediff= $buys[0]{Price} - $sells[0]{Price};
110             last unless $pricediff > 0;
111             our $qty= 1000;
112             sub arb_check_qty (\@) {
113                 my ($verbs) = @_;
114                 my $vqty= $verbs->[0]{Qty};
115                 return if $vqty =~ m/^\>/;
116                 $qty= $vqty if $qty > $vqty;
117                 return if $vqty;
118                 my $verb= shift @$verbs;
119             }
120             arb_check_qty(@buys);
121             arb_check_qty(@sells);
122             next unless $qty;
123             my $tprofit= $qty*$pricediff;
124             $profit += $tprofit;
125             $cqty += $qty;
126             
127             $info.=
128                 sprintf("%-13.13s| %-19.19s %4d| %-19.19s %4d|%3d x%3d =%3d\n",
129                        $commod,
130                        $buys[0]{Stall},$buys[0]{Price},
131                        $sells[0]{Stall},$sells[0]{Price},
132                        $qty, $pricediff, $tprofit);
133             sub arb_subtract_qty (\@) {
134                 my ($verbs) = @_;
135                 my $verb= shift @$verbs;
136                 unshift @$verbs, {
137                     Stall => $verb->{Stall},
138                     Price => $verb->{Price},
139                     Qty => $verb->{Qty} - $qty
140                 };
141             }
142             arb_subtract_qty(@buys);
143             arb_subtract_qty(@sells);
144         }
145         next unless $profit;
146         $info.=
147             sprintf("%-13.13s| %19s %4s| %19s %4s|%3d      %4d\n",
148                     $commod, '','', '','', $cqty, $profit);
149         push @arbs, { Profit => $profit, Info => $info };
150     }
151     my $allprofit;
152
153     if (!@arbs) {
154         print "No arbitrage opportunities.\n" or die $!;
155         return;
156     }
157     my $bigdiv= <<END;
158 =============+=========================+=========================+=============
159 END
160
161     print <<END or die $!;
162
163 commodity    | seller             price| buyer              price| qty  ea prof
164 END
165
166     my $div= $bigdiv;
167     foreach my $arb (sort {
168         $b->{Profit} <=> $a->{Profit};
169     } @arbs) {
170         print $div,$arb->{Info} or die $1;
171         $div= <<END;
172 -------------+-------------------------+-------------------------+-------------
173 END
174         $allprofit += $arb->{Profit};
175     }
176     print $bigdiv or die $!;
177     printf("%-13.13s  %19s %4s  %19s %4s %-5s %7d\n",
178            '', '','', '','', 'TOTAL', $allprofit)
179         or die $!;
180 }
181
182 sub main__bestprices () {
183     foreach $commod (sort keys %commod) {
184         $current= $commod{$commod};
185         my $buys=  bs_p($commod,Buy, -1);
186         my $sells= bs_p($commod,Sell,+1);
187         printf("%-15.15s", $commod) or die $!;
188         bs_p_bestprice($buys);
189         bs_p_bestprice($sells);
190         print("\n") or die $!;
191     }
192 }
193
194 sub bs_p_tsv ($) {
195     my ($bs) = @_;
196     if (exists $current->{$bs}{$stall}) {
197         my $si= $current->{$bs}{$stall};
198         printf("\t%d\t%s", $si->{Price}, $si->{Qty}) or die $!;
199     } else {
200         printf("\t\t") or die $!;
201     }
202 }
203
204 sub main__tsv () {
205     foreach $commod (sort keys %commod) {
206         $current= $commod{$commod};
207         my %stalls;
208         map { $stalls{$_}=1; } keys %{ $current->{Buy}  };
209         map { $stalls{$_}=1; } keys %{ $current->{Sell} };
210         foreach $stall (sort keys %stalls) {
211             printf("%s\t%s", $commod, $stall) or die $!;
212             bs_p_tsv(Buy);
213             bs_p_tsv(Sell);
214             print("\n") or die $!;
215         }
216     }
217 }
218
219
220 our (%commodmap);
221 our ($pctb) = $ENV{'YPPSC_PCTB_PCTB'};  die unless $pctb;
222
223 our ($ua)= LWP::UserAgent->new;
224
225 sub load_commodmap() {
226     undef %commodmap;
227     my $c= new IO::File "#commodmap#.tsv";
228     if (!$c) { $!==&ENOENT or die $!; return; }
229     while (<$c>) {
230         m/^(\S.*\S)\t(\d+)\n$/ or die "$_";
231         $commodmap{$1}= $2;
232     }
233     $c->error and die $!;
234     close $c;
235 }
236
237 sub refresh_commodmap() {
238     my $resp= $ua->get("$pctb/commodmap.php?version=2");
239     die $resp->status_line unless $resp->is_success;
240
241     my $cdata='';
242     my $incommodmap=0;
243     my $intag='';
244     my %got;
245     my $o= new IO::File "#commodmap#.tsv.new",'w' or die $!;
246     undef %commodmap;
247
248     my $xp= new XML::Parser
249         (Handlers =>
250          {
251              Start => sub {
252                  $_=$_[1];
253 #print STDERR "START [$_] intag=$intag icm=$incommodmap\n";
254                  if (m/^commodmap$/i) {
255                      $incommodmap++;
256                      undef %got;
257                  } elsif (m/^(?:name|index)$/i) {
258                      $cdata='';
259                      $intag=lc($_) if $incommodmap;
260 #print STDERR "START RECOGNISED $intag icm=$incommodmap\n";
261 #                } else {
262 #print STDERR "START UNRECOGNISED\n";
263                  }
264              },
265              End => sub {
266                  $_=$_[1];
267 #print STDERR "END [$_] intag=$intag icm=$incommodmap\n";
268                  if (m/^commodmap$/i) {
269                      $incommodmap--;
270                      die unless exists $got{'name'};
271                      die unless exists $got{'index'};
272                      die unless $got{'index'} =~ m/^\s*([1-9]\d{0,3})\s*$/;
273                      my $index= $1;
274                      $_= $got{'name'};
275                      s/^\s+//; s/\s+$//; s/\n/ /g; s/\s+/ /;
276                      die "$_ ?" if exists $commodmap{$_};
277                      $commodmap{$_}= $index;
278                      print $o "$_\t$index\n" or die $!;
279                  } elsif (lc $_ eq $intag) {
280                      $got{$intag}= $cdata;
281                  }
282              },
283              Char => sub {
284 #print STDERR "CHAR [$_[1]] intag=$intag icm=$incommodmap\n";
285                  $cdata .= $_[1];
286              }
287          }) or die;
288     my $content= $resp->content;
289
290 #    print STDERR "[[[$content]]]\n";
291     $xp->parse($content);
292     close $o or die $!;
293     rename "#commodmap#.tsv.new","#commodmap#.tsv" or die $!;
294 }
295
296 our (%stallmap, @stallmap);
297
298 sub bs_gen_md ($$) {
299     my ($bs,$sortmul) = @_;
300     my $count= 0;
301     my $o= '';
302     
303     foreach $commod (sort {
304         $commodmap{$a} <=> $commodmap{$b}
305     } keys %commod) {
306 #print STDERR "COMMOD $commod\n";
307         $current= $commod{$commod};
308         my $l= bs_p($commod,$bs,$sortmul);
309         next unless @$l;
310 #print STDERR "COMMOD $commod  has ".scalar(@$l)."\n";
311         $o .= writeint($commodmap{$commod});
312         $o .= writeint(scalar @$l);
313         foreach my $cs (@$l) {
314             $stall= $cs->{Stall};
315             my $stallix= $stallmap{$stall};
316             if (!defined $stallix) {
317                 push @stallmap, $stall;
318                 $stallmap{$stall}= $stallix= @stallmap;
319 #print STDERR "STALL DEF $stallix $stall\n";
320             }
321             my $qty= $cs->{Qty};
322             $qty =~ s/^\>\s*//;
323             $o .= writeint($stallix, $cs->{Price}, $qty+0);
324             $count++;
325         }
326     }
327 #print STDERR "COMMOD $commod COUNT WAS $count\n";
328     return
329         writeint($count).$o;
330 }
331
332 sub writeint { return pack 'v*', @_; }
333
334 sub genmarketdata () {
335     our $version= '005b';
336
337     load_commodmap();
338     my @missing= grep { !exists $commodmap{$_} } keys %commod;
339     if (@missing) {
340         refresh_commodmap();
341         my $missing=0;
342         foreach $commod (sort keys %commod) {
343             next if exists $commodmap{$commod};
344             printf STDERR "Unknown commodity \`%s'!\n", $commod;
345             $missing++;
346         }
347         die "$missing unknown commoditi(es).  OCR failure?\n"
348             if $missing;
349     }    
350
351     my $ob='';
352     $ob .= bs_gen_md(Buy, -1);
353     $ob .= bs_gen_md(Sell,+1);
354
355     my $ot= sprintf("$version\n".
356                     "%d\n",
357                     scalar(@stallmap));
358     foreach $stall (@stallmap) { $ot .= "$stall\n"; }
359     return $ot.$ob;
360 }
361
362 sub main__genmarketdata () {
363     my $o= genmarketdata();
364     print $o or die $!;
365 }
366
367 sub main__upload () {
368     my $o= genmarketdata();
369     my $url= "$pctb/upload.php";
370     $url= "http://www.chiark.greenend.org.uk/ucgi/~ijackson/check/upload.php";
371     my $content= {
372         'marketdata' => [ undef, "marketdata.gz",
373                           Content_Type => 'application/gzip',
374                           Content => $o
375                           ]
376                       };
377     my $resp= $ua->post("$url", Content => $content,
378                         Content_Type => 'form-data');
379     die $resp->status_line unless $resp->is_success;
380
381     print "[[ ",$resp->content," ]]\n";
382 }
383
384
385 $mode =~ s/\-//;
386 &{"main__$mode"};
387 close(STDOUT) or die $!;