X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~yarrgweb/git?p=ypp-sc-tools.main.git;a=blobdiff_plain;f=yarrg%2Fweb%2Froutetrade;h=80fc2b13d5e8cf78f5ba1c61d0310e5de0280318;hp=d0d4a76624c99a5d89e2c844926b04d826f03563;hb=a4e2383b30189c028ae35d2f587b084803e5d888;hpb=4a7daddbd09806e47fc3b6df9cfc42ed5eb84758 diff --git a/yarrg/web/routetrade b/yarrg/web/routetrade index d0d4a76..80fc2b1 100644 --- a/yarrg/web/routetrade +++ b/yarrg/web/routetrade @@ -1,27 +1,696 @@ +<%doc> + + This is part of the YARRG website. YARRG is a tool and website + for assisting players of Yohoho Puzzle Pirates. + + Copyright (C) 2009 Ian Jackson + Copyright (C) 2009 Clare Boothby + + YARRG's client code etc. is covered by the ordinary GNU GPL (v3 or later). + The YARRG website is covered by the GNU Affero GPL v3 or later, which + basically means that every installation of the website will let you + download the source. + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU Affero General Public License as + published by the Free Software Foundation, either version 3 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Affero General Public License for more details. + + You should have received a copy of the GNU Affero General Public License + along with this program. If not, see . + + Yohoho and Puzzle Pirates are probably trademarks of Three Rings and + are used without permission. This program is not endorsed or + sponsored by Three Rings. + + + This Mason component is the core trade planner for a specific route. + + + <%args> +$dbh @islandids @archipelagoes +$qa +<&| script &> + da_pageload= Date.now(); + + +<%perl> + +my $now= time; +my $loss_per_league= 1e-7; + +my @flow_conds; +my @query_params; + +my $sd_condition= sub { + my ($bs, $ix) = @_; + my $islandid= $islandids[$ix]; + if (defined $islandid) { + return "${bs}.islandid = $islandid"; + } else { + push @query_params, $archipelagoes[$ix]; + return "${bs}_islands.archipelago = ?"; + } +}; + +my %islandpair; +# $islandpair{$a,$b}= [ $start_island_ix, $end_island_ix ] + +my $specific= !grep { !defined $_ } @islandids; +my $confusing= 0; + +foreach my $src_i (0..$#islandids) { + my $src_isle= $islandids[$src_i]; + my $src_cond= $sd_condition->('sell',$src_i); + my @dst_conds; + foreach my $dst_i ($src_i..$#islandids) { + my $dst_isle= $islandids[$dst_i]; + my $dst_cond= $sd_condition->('buy',$dst_i); + if ($dst_i==$src_i and !defined $src_isle) { + # we always want arbitrage, but mentioning an arch + # once shouldn't produce intra-arch trades + $dst_cond= + "($dst_cond AND sell.islandid = buy.islandid)"; + } + push @dst_conds, $dst_cond; + + if ($specific && !$confusing && + # With a circular route, do not carry goods round the loop + !(($src_i==0 || $src_i==$#islandids) && + $dst_i==$#islandids && + $src_isle == $islandids[$dst_i])) { + if ($islandpair{$src_isle,$dst_isle}) { + $confusing= 1; +print "confusing $src_i $src_isle $dst_i $dst_isle\n"; + } else { + $islandpair{$src_isle,$dst_isle}= + [ $src_i, $dst_i ]; + } + } + } + push @flow_conds, "$src_cond AND ( + ".join(" + OR ",@dst_conds)." + )"; +} + +my $stmt= " + SELECT sell_islands.islandname org_name, + sell_islands.islandid org_id, + sell.price org_price, + sell.qty org_qty_stall, + sell_stalls.stallname org_stallname, + sell.stallid org_stallid, + sell_uploads.timestamp org_timestamp, + buy_islands.islandname dst_name, + buy_islands.islandid dst_id, + buy.price dst_price, + buy.qty dst_qty_stall, + buy_stalls.stallname dst_stallname, + buy.stallid dst_stallid, + buy_uploads.timestamp dst_timestamp, +".($qa->{ShowStalls} ? " + sell.qty org_qty_agg, + buy.qty dst_qty_agg, +" : " + (SELECT sum(qty) FROM sell AS sell_agg + WHERE sell_agg.commodid = commods.commodid + AND sell_agg.islandid = sell.islandid + AND sell_agg.price = sell.price) org_qty_agg, + (SELECT sum(qty) FROM buy AS buy_agg + WHERE buy_agg.commodid = commods.commodid + AND buy_agg.islandid = buy.islandid + AND buy_agg.price = buy.price) dst_qty_agg, +")." + commods.commodname commodname, + commods.commodid commodid, + commods.unitmass unitmass, + commods.unitvolume unitvolume, + dist dist, + buy.price - sell.price unitprofit + FROM commods + JOIN sell ON commods.commodid = sell.commodid + JOIN buy ON commods.commodid = buy.commodid + JOIN islands AS sell_islands ON sell.islandid = sell_islands.islandid + JOIN islands AS buy_islands ON buy.islandid = buy_islands.islandid + JOIN uploads AS sell_uploads ON sell.islandid = sell_uploads.islandid + JOIN uploads AS buy_uploads ON buy.islandid = buy_uploads.islandid + JOIN stalls AS sell_stalls ON sell.stallid = sell_stalls.stallid + JOIN stalls AS buy_stalls ON buy.stallid = buy_stalls.stallid + JOIN dists ON aiid = sell.islandid AND biid = buy.islandid + WHERE ( + ".join(" + OR ", @flow_conds)." + ) + AND buy.price > sell.price + ORDER BY org_name, dst_name, commodname, unitprofit DESC, + org_price, dst_price DESC, + org_stallname, dst_stallname + "; + +my $sth= $dbh->prepare($stmt); +$sth->execute(@query_params); +my @flows; -%# So, add code to do right thing here: +my @cols= ({ NoSort => 1 }); +my $addcols= sub { + my $base= shift @_; + foreach my $name (@_) { + my $col= { Name => $name, %$base }; + $col->{Numeric}=1 if !$col->{Text}; + push @cols, $col; + } +}; + +if ($qa->{ShowStalls}) { + $addcols->({ Text => 1 }, qw( + org_name org_stallname + dst_name dst_stallname + )); +} else { + $addcols->({Text => 1 }, qw( + org_name dst_name + )); +} +$addcols->({ Text => 1 }, qw(commodname)); +$addcols->({ DoReverse => 1 }, + qw( org_price org_qty_agg dst_price dst_qty_agg + )); +$addcols->({ DoReverse => 1, SortColKey => 'MarginSortKey' }, + qw( Margin + )); +$addcols->({ DoReverse => 1 }, + qw( unitprofit MaxQty + MaxCapital MaxProfit + )); + + + +% if ($qa->{'debug'}) { 
-Route is as follows:
+<% $stmt |h %>
+<% join(' | ',@query_params) |h %>
+
+% } + +<& dumptable:start, qa => $qa, sth => $sth &> +% { +% my $got; +% while ($got= $sth->fetchrow_hashref()) { +<%perl> + + my $f= $flows[$#flows]; + if ( !$f || + $qa->{ShowStalls} || + grep { $f->{$_} ne $got->{$_} } + qw(org_id org_price dst_id dst_price commodid) + ) { + # Make a new flow rather than adding to the existing one + + $f= { + Ix => scalar(@flows), + Var => "f".@flows, + %$got + }; + $f->{"org_stallid"}= $f->{"dst_stallid"}= 'all' + if !$qa->{ShowStalls}; + push @flows, $f; + } + foreach my $od (qw(org dst)) { + $f->{"${od}Stalls"}{ + $got->{"${od}_stallname"} + } = + $got->{"${od}_qty_stall"} + ; + } + + +<& dumptable:row, qa => $qa, sth => $sth, row => $f &> +% } +<& dumptable:end, qa => $qa &> +% } + +<%perl> + +if (!@flows) { + print 'No profitable trading opportunities were found.'; + return; +} + +foreach my $f (@flows) { + + $f->{MaxQty}= $f->{'org_qty_agg'} < $f->{'dst_qty_agg'} + ? $f->{'org_qty_agg'} : $f->{'dst_qty_agg'}; + $f->{MaxProfit}= $f->{MaxQty} * $f->{'unitprofit'}; + $f->{MaxCapital}= $f->{MaxQty} * $f->{'org_price'}; + + $f->{MarginSortKey}= sprintf "%d", + $f->{'dst_price'} * 10000 / $f->{'org_price'}; + $f->{Margin}= sprintf "%3.1f%%", + $f->{'dst_price'} * 100.0 / $f->{'org_price'} - 100.0; + + $f->{ExpectedUnitProfit}= + $f->{'dst_price'} * (1.0 - $loss_per_league) ** $f->{'dist'} + - $f->{'org_price'}; + + my @uid= $f->{commodid}; + foreach my $od (qw(org dst)) { + push @uid, + $f->{"${od}_id"}, + $f->{"${od}_price"}; + push @uid, + $f->{"${od}_stallid"} + if $qa->{ShowStalls}; + } + $f->{UidLong}= join '_', @uid; + + my $base= 31; + my $cmpu= ''; + map { + my $uue= $_; + my $first= $base; + do { + my $this= $uue % $base; +print STDERR "uue=$uue this=$this "; + $uue -= $this; + $uue /= $base; + $this += $first; + $first= 0; + $cmpu .= chr($this + ($this < 26 ? ord('a') : + $this < 52 ? ord('A')-26 + : ord('0')-52)); +print STDERR " uue=$uue this=$this cmpu=$cmpu\n"; +die "$cmpu $uue ?" if length $cmpu > 20; + } while ($uue); + $cmpu; + } @uid; + $f->{UidShort}= $cmpu; + + if ($qa->{'debug'}) { + my @outuid; + $_= $f->{UidShort}; + my $mul; + while (m/./) { + my $v= m/^[a-z]/ ? ord($&)-ord('a') : + m/^[A-Z]/ ? ord($&)-ord('A')+26 : + m/^[0-9]/ ? ord($&)-ord('0')+52 : + die "$_ ?"; + if ($v >= $base) { + push @outuid, 0; + $v -= $base; + $mul= 1; +#print STDERR "(next)\n"; + } + die "$f->{UidShort} $_ ?" unless defined $mul; + $outuid[$#outuid] += $v * $mul; + +#print STDERR "$f->{UidShort} $_ $& v=$v mul=$mul ord()=".ord($&). +# "[vs.".ord('a').",".ord('A').",".ord('0')."]". +# " outuid=@outuid\n"; + + $mul *= $base; + s/^.//; + } + my $recons_long= join '_', @outuid; + $f->{UidLong} eq $recons_long or + die "$f->{UidLong} = $f->{UidShort} = $recons_long ?"; + } + if (defined $qa->{"R$f->{UidShort}"} && + !defined $qa->{"T$f->{UidShort}"}) { + $f->{Suppress}= 1; + } + +} + + +% my $optimise= $specific && !$confusing && @islandids>1; +% if (!$optimise) { + +

+% if (@islandids<=1) { +Route is trivial. +% } +% if (!$specific) { +Route contains archipelago(es), not just specific islands. +% } +% if ($confusing) { +Route is complex - it visits the same island several times +and isn't a simple loop. +% } +Therefore, optimal voyage trade plan not calculated. + +% } else { # ========== OPTMISATION ========== +<%perl> + +my $cplex= " +Maximize + + totalprofit: + ".(join " + + ", map { + sprintf "%.20f %s", $_->{ExpectedUnitProfit}, $_->{Var} + } @flows)." + +Subject To +"; + +my %avail_csts; +foreach my $flow (@flows) { + if ($flow->{Suppress}) { + $cplex .= " + $flow->{Var} = 0 +"; + next; + } + foreach my $od (qw(org dst)) { + my $cstname= join '_', ( + 'avail', + $flow->{'commodid'}, + $od, + $flow->{"${od}_id"}, + $flow->{"${od}_price"}, + $flow->{"${od}_stallid"}, + ); + + push @{ $avail_csts{$cstname}{Flows} }, $flow->{Var}; + $avail_csts{$cstname}{Qty}= $flow->{"${od}_qty_agg"}; + } +} +foreach my $cstname (sort keys %avail_csts) { + my $c= $avail_csts{$cstname}; + $cplex .= " + ". sprintf("%-30s","$cstname:")." ". + join("+", @{ $c->{Flows} }). + " <= ".$c->{Qty}."\n"; +} + +$cplex.= " +Bounds + ".(join " + ", map { "$_->{Var} >= 0" } @flows)." + +End +"; + +if ($qa->{'debug'}) { + +

+<% $cplex |h %>
+
+<%perl> +} + +{ + my $input= pipethrough_prep(); + print $input $cplex or die $!; + my $output= pipethrough_run_along($input, undef, 'glpsol', + qw(glpsol --cpxlp /dev/stdin -o /dev/stdout)); + print "
\n" if $qa->{'debug'};
+	my $found_section= 0;
+	my $glpsol_out= '';
+	while (<$output>) {
+		$glpsol_out.= $_;
+		print encode_entities($_) if $qa->{'debug'};
+		if (m/^\s*No\.\s+Column name\s+St\s+Activity\s/) {
+			die if $found_section>0;
+			$found_section= 1;
+			next;
+		}
+		next unless $found_section==1;
+		next if m/^[- ]+$/;
+		if (!/\S/) {
+			$found_section= 2;
+			next;
+		}
+		my ($ix, $qty) =
+			m/^\s*\d+\s+f(\d+)\s+\S+\s+(\d+)\s/ or die "$_ ?";
+		my $flow= $flows[$ix] or die;
+		$flow->{OptQty}= $qty;
+		$flow->{OptProfit}= $flow->{'unitprofit'} * $qty;
+		$flow->{OptCapital}= $flow->{OptQty} * $flow->{'org_price'};
+	}
+	print "
\n" if $qa->{'debug'}; + my $prerr= "\n=====\n$cplex\n=====\n$glpsol_out\n=====\n "; + pipethrough_run_finish($output,$prerr); + die $prerr unless $found_section; +}; + +$addcols->({ DoReverse => 1 }, qw( + OptQty + )); +$addcols->({ Total => 0, DoReverse => 1 }, qw( + OptCapital OptProfit + )); + + + +% } # ========== OPTIMISATION ========== + +% my %ts_sortkeys; +% { +% my $cdspan= $qa->{ShowStalls} ? ' colspan=2' : ''; +% my $cdstall= $qa->{ShowStalls} ? 'Stall' : ''; + +++<% $qa->{ShowStalls} ? '' : '' %> ++++++% if ($optimise) { ++% } + + + +% foreach my $col (@cols) { + + +
+>Collect +>Deliver + +Collect +Deliver +Profit +Max +% if ($optimise) { +Planned +% } + +
+Island <% $cdstall %> +Island <% $cdstall %> +Commodity +Price +Qty +Price +Qty +Margin +Unit +Qty +Capital +Profit +% if ($optimise) { +Qty +Capital +Profit +% } +% } + +
+% } + +% foreach my $flowix (0..$#flows) { +% my $flow= $flows[$flowix]; +% my $rowid= "id_row_$flow->{UidShort}"; +
{UidShort} %> value=""> + {UidShort} %> value="" + <% $flow->{Suppress} ? '' : 'checked' %> > +% foreach my $ci (1..$#cols) { +% my $col= $cols[$ci]; +% my $v= $flow->{$col->{Name}}; +% $col->{Total} += $v if defined $col->{Total}; +% $v='' if !$col->{Text} && !$v; +% my $sortkey= $col->{SortColKey} ? +% $flow->{$col->{SortColKey}} : $v; +% $ts_sortkeys{$ci}{$rowid}= $sortkey; +{Text} ? '' : 'align=right' %>><% $v |h %> +% } +% } +
+Total +% foreach my $ci (3..$#cols) { +% my $col= $cols[$ci]; + +% if (defined $col->{Total}) { +<% $col->{Total} |h %> +% } +% } +
+ +<& tabsort, cols => \@cols, table => 'trades', rowclass => 'datarow', + throw => 'trades_sort', tbrow => 'trades_total' &> +<&| script &> + ts_sortkeys= <% to_json_protecttags(\%ts_sortkeys) %>; + function all_onload() { + ts_onload__trades(); + } + window.onload= all_onload; + + + + +% if ($optimise) { # ========== TRADING PLAN ========== +% +% my $iquery= $dbh->prepare('SELECT islandname FROM islands +% WHERE islandid = ?'); +% my %da_ages; +% my $total_total= 0; +% +

Voyage trading plan

+ % foreach my $i (0..$#islandids) { -% my $islandid= $islandids[$i]; -% my $archipelago= $archipelagoes[$i]; -% $islandid= '' unless defined $islandid; -% $archipelago= '' unless defined $archipelago; + + +% } +% $total += $t->{Total}; +% my $span= 0 + keys %{ $t->{Stalls} }; +% my $td= "td rowspan=$span"; + +<<% $td %>><% $collectdeliver %> +<<% $td %>><% $t->{'commodname'} |h %> % -% } +% my @stalls= sort keys %{ $t->{Stalls} }; +% my $pstall= sub { +% my $name= $stalls[$_[0]]; + +% $pstall->($stallix); +% } +% +% $dline ^= 1; +% } +% }; +% my $show_total= sub { +% my ($totaldesc, $sign)= @_; +% if (defined $total) { + + +
+% $iquery->execute($islandids[$i]); +% my ($islandname) = $iquery->fetchrow_array(); +% if (!$i) { +Start at <% $islandname |h %> +% } else { +Sail to <% $islandname |h %> +% } + +<%perl> + my $age_reported= 0; + my %flowlists; + foreach my $od (qw(org dst)) { + foreach my $f (@flows) { + next if $f->{Suppress}; + next unless $f->{"${od}_id"} == $islandids[$i]; + next unless $f->{OptQty}; + my $arbitrage= $f->{'org_id'} == $f->{'dst_id'}; + my $loop= $islandids[0] == $islandids[-1] && + ($i==0 || $i==$#islandids); + next if $loop and ($arbitrage ? $i : + !!$i == !!($od eq 'org')); + my $price= $f->{"${od}_price"}; + my $stallname= $f->{"${od}_stallname"}; + my $todo= \$flowlists{$od}{ + $f->{'commodname'}, + (sprintf "%07d", ($od eq 'dst' ? + 9999999-$price : $price)), + $stallname + }; + $$todo= { + Qty => 0, + orgArbitrage => 0, + dstArbitrage => 0, + } unless $$todo; + $$todo->{'commodname'}= $f->{'commodname'}; + $$todo->{'stallname'}= $stallname; + $$todo->{Price}= $price; + $$todo->{Timestamp}= $f->{"${od}_timestamp"}; + $$todo->{Qty} += $f->{OptQty}; + $$todo->{Total}= $$todo->{Price} * $$todo->{Qty}; + $$todo->{Stalls}= $f->{"${od}Stalls"}; + $$todo->{"${od}Arbitrage"}= 1 if $arbitrage; + } + } + + my $total; + my $dline= 0; + my $show_flows= sub { + my ($od,$arbitrage,$collectdeliver) = @_; + % - islandid=<% $islandid %> archipelago=<% $archipelago %> +% my $todo= $flowlists{$od}; +% return unless $todo; +% foreach my $tkey (sort keys %$todo) { +% my $t= $todo->{$tkey}; +% next if $t->{"${od}Arbitrage"} != $arbitrage; +% if (!$age_reported++) { +% my $age= $now - $t->{Timestamp}; +% my $cellid= "da_${i}"; +% $da_ages{$cellid}= $age; +\ +(Data age: <% prettyprint_age($age) %>) +% } elsif (!defined $total) { +% $total= 0; +
<% $name |h %> +% }; +% +% $pstall->(0); +<<% $td %> align=right><% $t->{Price} |h %> poe ea. +<<% $td %> align=right><% $t->{Qty} |h %> unit(s) +<<% $td %> align=right><% $t->{Total} |h %> total +% +% foreach my $stallix (1..$#stalls) { +
+<% $totaldesc %> +<% $total |h %> total +% $total_total += $sign * $total; +% } +% $total= undef; +% $dline= 0; +<%perl> + }; - + $show_flows->('dst',0,'Deliver'); $show_total->('Proceeds',1); + $show_flows->('org',1,'Collect'); $show_total->('(Arbitrage) outlay',-1); + $show_flows->('dst',1,'Deliver'); $show_total->('(Arbitrage) proceeds',1); + $show_flows->('org',0,'Collect'); $show_total->('Outlay',-1); + +} + +
+Overall net cash flow +<% + $total_total < 0 ? -$total_total." loss" : $total_total." gain" + %> +
+<& query_age:dataages, id2age => \%da_ages &> +% +% } # ========== TRADING PLAN ========== <%init> use CommodsWeb; -db_setocean('Midnight'); -db_connect(); +use Commods;