+<%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 <ijackson@chiark.greenend.org.uk>
+ 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 <http://www.gnu.org/licenses/>.
+
+ 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.
+
+
+</%doc>
<%args>
$dbh
@islandids
@archipelagoes
+$qa
</%args>
+<%perl>
+
+my @flow_conds;
+my @query_params;
-%# So, add code to do right thing here:
+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 && $dst_i==$#islandids &&
+ $src_isle == $islandids[$dst_i])) {
+ if ($islandpair{$src_isle,$dst_isle}) {
+ $confusing= 1;
+ } 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,
+ buy_islands.islandname dst_name,
+ buy_islands.islandid dst_id,
+ buy.price dst_price,
+".($qa->{ShowStalls} ? "
+ sell.stallid org_stallid,
+ sell_stalls.stallname org_stallname,
+ sell.qty org_qty,
+ buy.stallid dst_stallid,
+ buy_stalls.stallname dst_stallname,
+ buy.qty dst_qty,
+" : "
+ sum(sell.qty) org_qty,
+ sum(buy.qty) dst_qty,
+")."
+ commods.commodname commodname,
+ commods.commodid commodid,
+ commods.unitmass unitmass,
+ commods.unitvolume unitvolume,
+ buy.price - sell.price unitprofit
+ FROM commods
+ JOIN buy on commods.commodid = buy.commodid
+ JOIN sell on commods.commodid = sell.commodid
+ JOIN islands as sell_islands on sell.islandid = sell_islands.islandid
+ JOIN islands as buy_islands on buy.islandid = buy_islands.islandid
+".($qa->{ShowStalls} ? "
+ JOIN stalls as sell_stalls on sell.stallid = sell_stalls.stallid
+ JOIN stalls as buy_stalls on buy.stallid = buy_stalls.stallid
+" : "")."
+ WHERE (
+ ".join("
+ OR ", @flow_conds)."
+ )
+ AND buy.price > sell.price
+".($qa->{ShowStalls} ? "" : "
+ GROUP BY commods.commodid, org_id, org_price, dst_id, dst_price
+")."
+ ORDER BY org_name, dst_name, commodname, unitprofit DESC,
+ org_price, dst_price DESC
+ ";
+
+my $sth= $dbh->prepare($stmt);
+$sth->execute(@query_params);
+my @flows;
+
+my @columns;
+if ($qa->{ShowStalls}) {
+ push @columns, qw(org_name org_stallname dst_name dst_stallname);
+} else {
+ push @columns, qw(org_name dst_name);
+}
+push @columns, qw(commodname
+ org_price org_qty dst_price dst_qty
+ unitprofit PctProfit
+ MaxQty MaxCapital MaxProfit);
+
+</%perl>
+
+% if ($qa->{'debug'}) {
<pre>
-Route is as follows:
-
-% foreach my $i (0..$#islandids) {
-% my $islandid= $islandids[$i];
-% my $archipelago= $archipelagoes[$i];
-% $islandid= '<undef>' unless defined $islandid;
-% $archipelago= '<undef>' unless defined $archipelago;
-%
- islandid=<% $islandid |h %> archipelago=<% $archipelago |h %>
-%
+<% $stmt |h %>
+<% join(' | ',@query_params) |h %>
+</pre>
+% }
+
+% {
+<& dumptable:start, qa => $qa, sth => $sth &>
+% my $flow;
+% while ($flow= $sth->fetchrow_hashref()) {
+% $flow->{Ix}= @flows;
+% $flow->{Var}= "f$flow->{Ix}";
+% push @flows, $flow;
+<& dumptable:row, qa => $qa, sth => $sth, row => $flow &>
+% }
+<& dumptable:end, qa => $qa &>
% }
+% my $optimise= $specific && !$confusing && @islandids>1;
+% if (!$optimise) {
+
+<p>
+% 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 trade pattern not calculated.
+
+% } else { # ========== OPTMISATION ==========
+<%perl>
+
+my $cplex= "
+Maximize
+
+ totalprofit:
+ ".(join " +
+ ", map { "$_->{unit_profit} $_->{Var}" } @flows)."
+
+Subject To
+";
+
+my %avail_csts;
+foreach my $flow (@flows) {
+ foreach my $od (qw(org dst)) {
+ my $cstname= join '_',
+ 'avail',
+ $flow->{'commodid'},
+ $od,
+ $flow->{"${od}_id"},
+ $flow->{"${od}_price"};
+ push @{ $avail_csts{$cstname}{Flows} }, $flow->{Var};
+ $avail_csts{$cstname}{Qty}= $flow->{"${od}_qty"};
+ }
+}
+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'}) {
+</%perl>
+<pre>
+<% $cplex |h %>
</pre>
+<%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 "<pre>\n" if $qa->{'debug'};
+ my $found_section= 0;
+ while (<$output>) {
+ 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 "</pre>\n" if $qa->{'debug'};
+ pipethrough_run_finish($output, 'glpsol');
+ die unless $found_section;
+};
+
+print join ' ', map { $_->{Optimal} } @flows;
+
+push @columns, qw(OptQty OptCapital OptProfit);
+
+</%perl>
+
+% } # ========== OPTIMISATION ==========
+
+% {
+% my $cdspan= $qa->{ShowStalls} ? ' colspan=2' : '';
+% my $cdstall= $qa->{ShowStalls} ? '<th>Stall</th>' : '';
+<table>
+<tr>
+<th<% $cdspan %>>Collect
+<th<% $cdspan %>>Deliver
+<th>
+<th colspan=2>Collect
+<th colspan=2>Deliver
+<th colspan=2>Profit
+<th colspan=3>Max
+% if ($optimise) {
+<th colspan=3>Suggested
+% }
+
+<tr>
+<th>Island <% $cdstall %>
+<th>Island <% $cdstall %>
+<th>Commodity
+<th>Price
+<th>Qty
+<th>Price
+<th>Qty
+<th>Unit
+<th>Margin
+<th>Qty
+<th>Capital
+<th>Profit
+% if ($optimise) {
+<th>Qty
+<th>Capital
+<th>Profit
+% }
+% }
+
+% foreach my $flow (@flows) {
+<tr>
+% foreach my $col (@columns) {
+% $flow->{MaxQty}= $flow->{'org_qty'} < $flow->{'dst_qty'}
+% ? $flow->{'org_qty'} : $flow->{'dst_qty'};
+% $flow->{MaxProfit}= $flow->{MaxQty} * $flow->{'unitprofit'};
+% $flow->{PctProfit}= sprintf "%3.1f%%",
+% $flow->{'dst_price'} * 100.0 / $flow->{'org_price'}
+% - 100.0;
+% $flow->{MaxCapital}= $flow->{MaxQty} * $flow->{'org_price'};
+<td><% $flow->{$col} |h %>
+% }
+% }
+</table>
<%init>
use CommodsWeb;
+use Commods;
</%init>
~yarrgweb / ypp-sc-tools.web-live.git / blobdiff