@ISA = qw(Exporter);
@EXPORT = qw(&parse_info_clientside &fetch_with_rsync
&parse_info_serverside &parse_info_serverside_ocean
- %oceans %commods %clients %routes %route_mysteries
+ %oceans %commods %clients
+ %vessels %shotname2damage
&parse_pctb_commodmap %pctb_commodmap @pctb_commodmap
&get_our_version &check_tsv_line
&pipethrough_prep &pipethrough_run
our %oceans; # eg $oceans{'Midnight'}{'Ruby'}{'Eta Island'}= $sources;
our %clients; # eg $clients{'ypp-sc-tools'}= [ qw(last-page) ];
-our %routes; # eg $routes{'Midnight'}{'Orca'}{'Tinga'}= $sources NB abbrevs!
-our %route_mysteries; # eg $route_mysteries{'Midnight'}{'Norse'}= 3
+our %vessels; # eg $vessels{'War Brig'}{Shot}='medium'
+ # $vessels{'War Brig'}{Volume}= 81000
+ # $vessels{'War Brig'}{Mass}= 54000
+our %shotname2damage; # eg $shotname2damage{'medium'}= 3;
# $sources = 's[l]b';
# 's' = Special Circumstances; 'l' = local ; B = with Bleach
$oceans{$ocean}{$arch}{$_} .= $src;
};
});
- } elsif (m/^routes (\w+)$/) {
- my $ocean= $1;
+ } elsif (m/^vessels$/) {
+ @ctx= (sub {
+ return if m/^[-+|]+$/;
+ m/^ \| \s* ([A-Z][a-z\ ]+[a-z]) \s*
+ \| \s* (small|medium|large) \s*
+ \| \s* ([1-9][0-9,]+) \s*
+ \| \s* ([1-9][0-9,]+) \s*
+ \| $/x
+ or die;
+ my $name= $1;
+ my $v= { Shot => $2, Volume => $3, Mass => $4 };
+ foreach my $vm (qw(Volume Mass)) { $v->{$vm} =~ s/,//g; }
+ $vessels{$name}= $v;
+ });
+ } elsif (m/^shot$/) {
@ctx= (sub {
- m/^(\S[^\t]*\S),\s*(\S[^\t]*\S),\s*([1-9][0-9]{0,2})$/ or die;
- $routes{$ocean}{$1}{$2}= $3;
+ m/^ ([a-z]+) \s+ (\d+) $/x or die;
+ $shotname2damage{$1}= $2;
});
} elsif (m/^client (\S+.*\S)$/) {
my $client= $1;
}
};
foreach (@rawcm) { &$ca($_,$src); }
-
- foreach my $on (keys %routes) {
- my $routes= $routes{$on};
- my $ocean= $oceans{$on};
- die unless defined $ocean;
-
- my @allislands;
- foreach my $an (sort keys %$ocean) {
- my $arch= $ocean->{$an};
- push @allislands, sort keys %$arch;
- }
- parse_info_maproutes($on, \@allislands, $routes);
- foreach my $route (values %$routes) {
- parse_info_maproutes($on, \@allislands, $route);
- }
- }
}
sub parse_info_clientside () {
return $local;
}
-sub parse_info_maproutes ($$$) {
- my ($on, $allislands, $routemap) = @_;;
- foreach my $k (sort keys %$routemap) {
- my @ok= grep { index($_,$k) >= 0 } @$allislands;
- die "ambiguous $k" if @ok>1;
- if (!@ok) {
- $route_mysteries{$on}{$k}++;
- delete $routemap->{$k};
- } elsif ($ok[0] ne $k) {
- $routemap->{$ok[0]}= $routemap->{$k};
- delete $routemap->{$k};
- }
- }
-}
-
sub parse_info_serverside () {
parse_info1('source-info.txt','s',0);
}
@EXPORT = qw(&dbw_connect &ocean_list &sourcebasedir
&to_json_shim &to_json_protecttags
&set_ctype_utf8
+ &expected_error &dbw_lookup_string
&prettyprint_age &meta_prettyprint_age);
%EXPORT_TAGS = ( );
}
+sub dbw_lookup_string ($$$$$$$$) { # => ( $emsg, @dbresults )
+ my ($each,
+ $sth, $stmt_nqs, $abbrev_initials, $maxambig,
+ $em_nomatch, $em_manyambig, $emf_ambiguous) = @_;
+
+ $each =~ s/^\s*//; $each =~ s/\s*$//; $each =~ s/\s+/ /g;
+ my %m;
+ my $results;
+ my @pats= ("$each", "$each \%", "$each\%", "\%$each\%");
+ if ($abbrev_initials) {
+ push @pats, join ' ', map { "$_%" } split //, $each;
+ }
+ foreach my $pat (@pats) {
+ $sth->execute(($pat) x $stmt_nqs);
+ $results= $sth->fetchall_arrayref();
+ last if @$results==1;
+ $m{ $_->[0] }=1 for @$results;
+ $results= undef;
+ }
+ if (!$results) {
+ if (!%m) {
+ return $em_nomatch;
+ } elsif (keys(%m) > $maxambig) {
+ return $em_manyambig;
+ } else {
+ return $emf_ambiguous->($each, join(', ', sort keys %m));
+ }
+ }
+ return (undef, @{ $results->[0] });
+}
+
+sub expected_error ($) {
+ my $r= { Emsg => $_[0] };
+ bless $r, 'CommodsWeb::ExpectedError';
+ die $r;
+}
+
+package CommodsWeb::ExpectedError;
+
+sub emsg ($) {
+ my ($self) = @_;
+ return $self->{Emsg};
+}
+
1;
ypp-sc-tools and YARRG are
Copyright (C) 2009 Ian Jackson <ijackson@chiark.greenend.org.uk>
Copyright (C) 2009 Clare Boothby
+Copyright (C) 2009 Steve Early
This program is free software: you can redistribute it and/or modify
it under the terms of
UPLOADER
--------
- sometimes fails to work on Sage - sunshine widget resets or something
+detect all unexpected mouse movements
- detect all unexpected mouse movements
+more flexible installation arrangements
- more flexible installation arrangements
+figure out why pctb.ilk.org isn't working
- W windows uploader
+windows uploader
DATABASE/DICTIONARY MANAGER
---------------------------
- commodity mass/volume in live database
- eliminate black dye from live database
+eliminate black dye from live database
- when update rejected print better error message including
- broken commodity name
+when update rejected print better error message including
+ broken commodity name
- notice commodities deleted from source-info and warn about them
+notice commodities deleted from source-info and warn about them
- support Opal and Jade (currently there are some unicode problems)
+support Opal and Jade (currently there are some unicode problems)
WEBSITE
-------
- multi-visit routes / circular routes
+allow unticking based on minimum margin or minimum profit
- adjustable potential cost of losses (rather than fixed
- 1e-BIG per league)
- use power formula (compound interest)
- suggest 0.5%
+initial/final stocks feature
- initial/final stocks feature
-
- max volume/mass
-
- max capital
-
- better documentation
-
- printable voyage trading plan
-
-
-KEYLETTERS
-----------
-
-P needed before public release
-O needed before public release to support multiple oceans
-
-C needs ypp client and network connection
-N needs network connection
-W needs to be done by someone with Windows
-
-D dependencies unsatisfied
+printable voyage trading plan
dist INTEGER NOT NULL,
PRIMARY KEY (aiid, biid)
);
+ CREATE TABLE IF NOT EXISTS vessels (
+ name TEXT NOT NULL,
+ mass INTEGER NOT NULL,
+ volume INTEGER NOT NULL,
+ shot INTEGER NOT NULL,
+ PRIMARY KEY (name)
+ );
END
;
$dbh->commit;
}
-#---------- island list ----------
-#---------- routes ----------
-# now done by yppedia-chart-parser
-
-__DATA__
+#---------- vessel types ----------
+{
+ my $idempotent= $dbh->prepare(<<'END')
+ INSERT OR REPLACE INTO vessels (name, shot, mass, volume)
+ VALUES (?,?,?,?)
+END
+ ;
+ foreach my $name (sort keys %vessels) {
+ my $v= $vessels{$name};
+ my $shotdamage= $shotname2damage{$v->{Shot}};
+ die "no shot damage for shot $v->{Shot} for vessel $name"
+ unless defined $shotdamage;
+ my @qa= ($name, $shotdamage, map { $v->{$_} } qw(Mass Volume));
+ $idempotent->execute(@qa);
+ }
+ $dbh->commit;
+}
#print Dumper($results);
print "strict graph $ocean {\n";
-#print " nodesep=10;\n";
+print " splines=true;\n";
+print " nslimit=10;\n";
+print " mclimit=10;\n";
foreach my $row (@$islands) {
my ($id,$str) = @$row;
}
foreach my $row (@$routes) {
my ($ia,$ib,$dist) = @$row;
- print " n$ia -- n$ib [ len=2, label=$dist ];\n";
- #len=$dist, minlen=$dist, weight=".(1.0/$dist).", len=".($dist*0.25+1).",
+ print " n$ia -- n$ib [ w=".(1.0/($dist*$dist)).", len=".(0.5*$dist+1).", label=$dist ];\n";
+ #len=$dist, minlen=$dist, , ,
#w=".(1.0/$dist).",
}
+vessels
+#| Ship Name |Gun Size|Volume | Mass |
+ |Sloop |small |20,250 |13,500 |
+ |----------------+--------+-------+-------|
+ |Cutter |small |60,750 |40,500 |
+ |----------------+--------+-------+-------|
+ |Dhow |medium |20,250 |13,500 |
+ |----------------+--------+-------+-------|
+ |Longship |small |20,250 |13,500 |
+ |----------------+--------+-------+-------|
+ |Baghlah |medium |27,000 |18,000 |
+ |----------------+--------+-------+-------|
+ |Merchant brig |medium |135,000|90,000 |
+ |----------------+--------+-------+-------|
+ |War brig |medium |81,000 |54,000 |
+ |----------------+--------+-------+-------|
+ |Merchant galleon|large |405,000|270,000|
+ |----------------+--------+-------+-------|
+ |Xebec |medium |182,250|121,500|
+ |----------------+--------+-------+-------|
+ |War frigate |large |324,000|216,000|
+ |----------------+--------+-------+-------|
+ |Grand frigate |large |810,000|540,000|
+# From http://yppedia.puzzlepirates.com/Ship; when updating,
+# delete unused columns and check heading is the same as above.
+# If fields reordered must change parser in Commods.pm.
+
+shot
+ small 2
+ medium 3
+ large 4
+
commods
kraken's blood 1kg
%c dye 1kg
next if $h =~ m/^nocommods/;
}
next if $sfn =~ m/source-info/ && $h =~ m/^ocean\b/;
- next if $h =~ m/^client\b/;
+ next if $h =~ m/^client|^vessels|^shot\b/;
print $df $_, "\n" or die $!;
}
This Mason component simply defines how to interpret capacities.
</%doc>
-
-<%attr>
-</%attr>
-
-<%method preparse>
+<%method execute>
<%args>
-$h
+$string
+$dbh
+$debugf
</%args>
<%perl>
-my $def= sub {
- my ($what,$val) = @_;
- if (defined $h->{$what}) {
- $h->{Emsg}= "Multiple definitions of maximum $what.";
+my $commodsth;
+
+my @mv_names= qw(mass volume);
+my @mv_units= qw(kg l);
+
+my (@mv)= (undef,undef);
+return ('',@mv) unless $string =~ m/\S/;
+
+my @canon= ();
+my ($signum,$signopstr)= (+1,undef);
+my $show_answer=0;
+my $first_term=1;
+my $last_signopstr= 'NONE';
+
+my $canon_numeric= sub {
+ my ($val,$mvi) = @_;
+ sprintf "%g%s", $val, $mv_units[$mvi];
+};
+
+my $parse_values= sub {
+ local ($_) = @_;
+ $debugf->("TERM VALUES '$_'");
+ $_ .= ' ';
+ my $def= sub {
+ my ($mvi,$val) = @_;
+ if ($first_term) {
+ expected_error("Initial term specifies".
+ " $mv_names[$mvi] more than once.")
+ if defined $mv[$mvi];
+ $mv[$mvi]= $val;
+ } else {
+ expected_error("Cannot add or subtract mass to/from volume")
+ unless defined $mv[$mvi];
+ $mv[$mvi] += $signum * $val;
+ }
+ push @canon, $canon_numeric->($val,$mvi);
+ };
+ while (m/\S/) {
+ $debugf->("VALUE '$_'");
+ my $iqtyrex= '[1-9] \d{0,8}';
+ my $fqtyrex= '\d{1,9} \. \d{0,3} |' . $iqtyrex;
+ if (s/^( $fqtyrex ) \s* kg \s+ //xo) { $def->(0, $1 ); }
+ elsif (s/^( $fqtyrex ) \s* t \s+ //xo) { $def->(0, $1 * 1000.0 ); }
+ elsif (s/^( $fqtyrex ) \s* l \s+ //xo) { $def->(1, $1 ); }
+ elsif (s/^( $fqtyrex ) \s* kl \s+ //xo) { $def->(1, $1 * 1000.0 ); }
+ elsif (s/^( $iqtyrex ) \s* ([a-z ]+) \s+ //xo) {
+ my ($qty,$spec) = ($1,$2);
+ $debugf->("VALUE COMMOD $qty '$spec'");
+ expected_error("Capacity specification must start with".
+ " ship size or amount with units")
+ if $first_term;
+ $commodsth ||=
+ $dbh->prepare("SELECT commodname,unitmass,unitvolume
+ FROM commods WHERE commodname LIKE ?");
+ my ($emsg,$commod,@umv)=
+ dbw_lookup_string($spec,$commodsth,1,0,0,
+ "No commodity or unit matches \`$spec'",
+ "Ambiguous commodity (or unit) \`$spec'",
+ undef);
+ expected_error($emsg) if defined $emsg;
+ $debugf->("VALUE COMMOD FOUND '$commod' @umv");
+ foreach my $mvi (0,1) {
+ next unless defined $mv[$mvi];
+ $mv[$mvi] += $signum * $qty * $umv[$mvi] * 0.001;
+ }
+ push @canon, sprintf "%d", $qty;
+ push @canon, $commod;
+ } else {
+ s/\s+$//;
+ expected_error("Did not understand value \`$_'");
}
- print STDERR "SET $what $val\n";
- $h->{$what}= $val;
+ }
};
-foreach $_ (split /\s+/, ${ $h->{String} }) {
- print STDERR "ITEM \`$_'\n";
- next unless length;
- if (m/^([1-9]\d{0,8})l$/) {
- $def->('volume', $1);
- } elsif (m/^([1-9]\d{0,8})kg$/) {
- $def->('mass', $1);
- } elsif (m/^([1-9]\d{0,5}(?:\.\d{0,3})?)kl/) {
- $def->('volume', $1 * 1000);
- } elsif (m/^([1-9]\d{0,5}(?:\.\d{0,3})?)t/) {
- $def->('mass', $1 * 1000);
+my $parse_term= sub {
+ local ($_) = @_;
+ $debugf->("TERM '$_' signum=$signum");
+ s/^\s+//; s/\s+$//;
+ expected_error("empty term in capacity") unless m/\S/;
+ if (m/^\s*(\d{1,2}(?:\.\d{0,4})?)\%\s*$/) {
+ $debugf->("TERM PERCENT $1");
+ expected_error("percentage may not be first item")
+ if $first_term;
+ my $pct= 100.0 + $signum * $1;
+ foreach (@mv) {
+ next unless defined;
+ $_ *= $pct / 100.0;
+ }
+ push @canon, sprintf "%g%%", $pct;
+ } elsif (!m/[^a-z]/) {
+ $debugf->("TERM NAME");
+ expected_error("Name (should be unit or commodity) \`$_'".
+ " without preceding quantity")
+ unless $first_term;
+ my $sth= $dbh->prepare("SELECT name,mass,volume".
+ " FROM vessels WHERE name LIKE ?");
+ my ($emsg,$ship,@smv)=
+ dbw_lookup_string($_,$sth,1,1,2,
+ "Ship name `$_' not understood.",
+ "Too many matching ship types.",
+ sub { "Ambiguous - could be $_[0]" });
+ expected_error($emsg) if defined $emsg;
+ $debugf->("TERM NAME SHIP '$ship' @smv");
+ $show_answer= 1;
+ @mv = @smv;
+ push @canon, $ship;
} else {
- ${ $h->{Emsg} }= "Cannot understand capacity \`$_'.";
- last;
+ $parse_values->($_);
}
+ $first_term= 0;
+};
+
+while ($string =~ s/^(.*?)(\bminus\b|-|\bplus\b|\+)//) {
+ my ($lhs)= ($1);
+ my @nextsign= $2 =~ m/^p|^\+/ ? (+1,'+') : (-1,'-');
+ $show_answer= 1;
+ $debugf->("GROUP S='$2'");
+ $parse_term->($lhs);
+ ($signum,$signopstr)= @nextsign;
+ push @canon, ($last_signopstr=$signopstr)
+ if $signopstr ne $last_signopstr;
}
-</%perl>
-</%method>
+$parse_term->($string);
-<%method postquery>
-<%args>
-$h
-</%args>
-<%perl>
+my $canon= join ' ', @canon;
-if (defined $h->{'mass'} or defined $h->{'volume'}) {
- @{ $h->{Results} } = [ $h->{'mass'}, $h->{'volume'} ];
+if ($show_answer) {
+ $canon .= " [=";
+ foreach my $mvi (0,1) {
+ next unless defined $mv[$mvi];
+ $canon .= ' '.$canon_numeric->($mv[$mvi], $mvi);
+ }
+ $canon .= "]";
+}
- ${ $h->{Canon} }=
- 'mass limit: '.(defined $h->{'mass'} ? $h->{'mass'} .'kg' : 'none').'; '.
- 'volume limit: '.(defined $h->{'volume'} ? $h->{'volume'} .'l' : 'none').'.';
+$debugf->("FINISHING canon='$canon'");
+
+foreach my $mvi (0,1) {
+ next unless defined $mv[$mvi];
+ next if $mv[$mvi] >= 0;
+ expected_error(sprintf "%s limit is negative: %s",
+ ucfirst($mv_names[$mvi]), $canon_numeric->($mv[$mvi], $mvi));
}
+return ($canon, @mv);
+
</%perl>
</%method>
--- /dev/null
+<%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 simply defines how to interpret capital.
+
+</%doc>
+
+<%method execute>
+<%args>
+$string
+$dbh
+$debugf
+</%args>
+<%perl>
+
+$_= $string;
+s/^\s+//; s/\s+$//;
+
+my $capital;
+my $canon;
+
+if (!m/\S/) {
+ $canon= '';
+} elsif (m/^([1-9]\d*)( PoE)?$/i) {
+ $capital= $1;
+ $canon= "$capital PoE";
+} else {
+ expected_error("Cannot understand capital \`$_'.");
+}
+
+return ($canon,$capital);
+
+</%perl>
+</%method>
sponsored by Three Rings.
- This Mason component simply defines how to interpret capacities.
+ This Mason component simply defines how to interpret losses per league.
</%doc>
-
-<%attr>
-</%attr>
-
-<%method preparse>
+<%method execute>
<%args>
-$h
+$string
+$dbh
+$debugf
</%args>
<%perl>
-$_= ${ $h->{String} };
+$_= $string;
s/^\s+//; s/\s+$//;
-my $res= sub {
- my ($pct,$str) = @_;
- push @{ $h->{Results} }, [ $pct ];
- ${ $h->{Canon} }= "$str per league";
-};
+my ($pct,$str);
if (!m/\S/) {
+ $str= '';
} elsif (m/^(\d{1,2}(?:\.\d{0,5})?)\%$/) {
- $res->( $1 * 1.0, sprintf("%g%%", $1) );
+ $pct= $1 * 1.0;
+ $str= sprintf("%g%%", $1);
} elsif (m/^1\s*\/\s*([1-9]\d{0,4})/) {
- $res->( 100.0/$1, sprintf("1/%d", $1) );
+ $pct= 100.0/$1;
+ $str= sprintf("1/%d", $1);
} else {
- ${ $h->{Emsg} }= "Cannot understand loss per league \`$_'.";
- return;
+ expected_error("Cannot understand loss per league \`$_'.");
}
+return ("$str per league", $pct);
+
</%perl>
</%method>
-Copyright 2009 Ian Jackson, Clare Boothby
\ No newline at end of file
+Copyright 2009 Ian Jackson, Clare Boothby, Steve Early
\ No newline at end of file
</%doc>
-<html><head><title>YARRG (Yet Another Revenue Research Gatherer)</title>
+<html lang="en"><head>
+<title>YARRG (Yet Another Revenue Research Gatherer)</title>
</head><body>
<a href="lookup">YARRG</a> -
Yet Another Revenue Research Gatherer
|
-<b>development</b>
-|
<a href="intro">introduction</a>
|
<a href="docs">documentation</a>
+|
+<b>development</b>
<h1>YARRG development, contribution and troubleshooting</h1>
licences for details. Not only the client but also the website code
is Free. The yarrg client, support files, and so forth are under
the GNU GPL (v3 or later); the website is under the GNU Affero GPL (v3
-or later). </p>
+or later).
<p>
If you would like to run a (perhaps modified) copy of the YARRG
website it would be very easy for us to make our system send you
copies of updates submitted by users of the official YARRG client, in
-the format expected by the YARRG code. Please just ask us - it's just
-a matter of us adding your database instance's special email address
-to our alias file.
+the format expected by the YARRG code. Please just ask us - at our
+end it's just a matter of us adding your database instance's special
+email address to our alias file.
<p>
</%doc>
-<html><head><title>Website documentation - YARRG</title>
+<html lang="en"><head><title>Website documentation - YARRG</title>
</head><body>
<a href="lookup">YARRG</a> -
Yet Another Revenue Research Gatherer
|
-<a href="devel">development</a>
-|
<a href="intro">introduction</a>
|
<b>documentation</b>
+|
+<a href="devel">development</a>
<h1>Looking up data in YARRG</h1>
and select `Update' to get a new plan. The unticked trades will be
excluded from the voyage plan (if any) and also from the totals.
-<h3>Vessel capacity</h3>
+<h3><a name="capacity">Vessel capacity</a></h3>
If you don't specify a vessel or a vessel capacity, the trading plan
will not take into account the fact that your voyage will be on a ship
<p>
-So you should specify your vessel capacity. Currently you must
-specify the actual mass and volume, as two numbers each with units.
-The system understands the units t (tonnes), kg, l and kl
-(kilolitres). There should be a space between the two limits, and no
-space before the unit.
+So you should specify your vessel capacity. You can enter things
+like:
+<dl>
+<dt>sloop
+<dd>The capacity of a sloop, leaving no allowance for rum and shot
+<dt>wb - 1%
+<dd>The capacity of a war brig minus 1%
+<dt>13t 20kl
+<dd>13 tonnes (13,000kg), 20 kilolitres (20,000l)
+<dt>sloop - 10 small 40 rum
+<dd>The capacity of a sloop which remains after
+ 10 small shot and 40 rum are loaded
+<dt>2t plus 500kg minus 200kg
+<dd>2300kg, with no limit on volume
+</dl>
+Evaluation is strictly from left to right.
+
+<p>
+
+More formally:
+<pre>
+ capacity-string := [ first-term term* ]
+ term := ('+' | '-' | 'plus' | 'minus') (value+ | number'%')
+ value := mass | volume
+ | integer commodity-name-or-abbreviation
+ mass := number ('t' | 'kg')
+ volume := number ('kl' | 'l')
+ first-term := mass | volume | mass volume | volume mass
+ | ship-name-or-abbreviation
+</pre>
-<h3>Expected losses</h3>
+If the first term specifies only one of mass or volume, all the
+subsequent terms may only adjust that same value.
+
+<h3><a name="losses">Expected losses</a></h3>
In theory if you were guaranteed to have a trouble-free voyage it
would be worth trading goods at very low margins. However, in
<p>
-Trades whose margin is less than the expected loss are never selected.
-For example, if you select 1% loss per league, and plan a voyage of 5
-leagues, then any trade with a margin of less than 5.15% would be
-completely excluded (5.15% not 5% because the loss works like compound
-interest). Theoretically very profitable trades which are close to
-the expected break-even point because of the distance can also be
-rejected by the optimiser in favour of shorter distance trades with
-theoretically smaller margins.
+Trades whose margin is less than the expected loss are never included
+in the suggested plan. For example, if you select 1% loss per league,
+and plan a voyage of 5 leagues, then any trade with a margin of less
+than 5.15% would be completely excluded (5.15% not 5% because the loss
+works like compound interest). Theoretically very profitable trades
+which are close to the expected break-even point because of the
+distance can also be rejected by the optimiser in favour of shorter
+distance trades with theoretically smaller margins, if it's not
+possible to do both.
<p>
-As a guide: you may expect to lose between 0.1% and 1% per league.
-0.1% would correspond, for example, to losing one fight to brigands
-every ten 10-league voyages.
+As a guide: you may expect to lose between 0.01% and 1% per league.
+For example 0.1% would correspond to losing one fight to brigands (who
+take 10% if they win) for every 100 leagues sailed.
<p>
You can enter the value in the box either as a percentage, or as a
-fraction 1/<em>divisor</em>, eg 1/200 is the same as 0.5%; in each
+fraction 1/<em>divisor</em>, eg 1/2000 is the same as 0.05%; in each
case it is taken as the loss for each league of the voyage.
+<h3><a name="capital">Available capital</a></h3>
+
+If you don't specify the amount of capital you have available to
+invest in the voyage, the trading plan will assume that your capital
+is unlimited. If you specify an amount in PoE here, the trading plan
+will never require you to spend more than that amount on commodities.
+
+<p>
+
+The trading plan does not take into account accumulated profits from
+each leg of the journey when applying the available capital
+constraint. For example, if you specify a journey from A to B to C
+and a capital limit of 10000 PoE, the trading plan will not tell you
+to buy 1000 peas at A for 10 PoE each, sail them to B and sell all of
+them for 20 PoE each, and then buy 2000 beans at B for 10 PoE each and
+sail them to C to sell for 20 PoE each even if such a trade would in
+fact be possible. In practice this is unlikely to be a problem!
+
<& footer &>
This Mason component is helpful for debugging and developing. It
outputs plain HTML tables eg for SQL query results. You can either:
- <& dumptable, sth = $executed_statement_handle &>
+ <& dumptable, sth => $executed_statement_handle &>
in which case it will consume the results of the statement and
print them unconditionally, or do the equivalent of:
<& dumptable:start, sth => $sth, [ qa => $qa ] &> or
--- /dev/null
+<%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 generates form contents for selecting a commodity.
+
+
+</%doc>
+<%args>
+$qa
+$dbh
+$emsg_r
+
+$commodname_r
+$cmid_r
+</%args>
+
+%#---------- textbox, user enters commodity as string ----------
+% if (!$qa->{Dropdowns}) {
+
+Enter commodity (abbreviations are OK):<br>
+
+<&| qtextstring, qa => $qa, dbh => $dbh, emsgstore => $emsg_r,
+ thingstring => 'commodstring', prefix => 'cm',
+ onresults => sub { ($$commodname_r,$$cmid_r)= @{ $_[0] } if @_ }
+ &>
+ size=80
+</&>
+
+% } else { #---------- dropdowns, user selects from menus ----------
+
+% my $sth= $dbh->prepare("SELECT commodname,commodid FROM commods
+% ORDER BY commodname");
+% $sth->execute();
+% my $row;
+<select name="commodid">
+<option value="">Select commodity...</option>
+% while ($row= $sth->fetchrow_arrayref) {
+% my $selected= $qa->{'commodid'} eq $row->[1] ? 'selected' : '';
+<option value="<% $row->[1] %>" <% $selected %>><% $row->[0] |h %></option>
+% ($$commodname_r,$$cmid_r) = @$row if $selected;
+% }
+</select>
+<p>
+
+% } #---------- end of dropdowns, now common middle of page code ----------
--- /dev/null
+<%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 generates form contents for selecting a list
+ of locations (eg, a route).
+
+
+</%doc>
+<%args>
+$qa
+$dbh
+$emsg_r
+$warningfs_r
+
+$enterwhat
+$islandids_r
+$archipelagoes_r
+</%args>
+
+%#---------- textbox, user enters route as string ----------
+% if (!$qa->{Dropdowns}) {
+
+<% $enterwhat %> (islands, or archipelagoes, separated by |s or commas;
+ abbreviations are OK):<br>
+
+<&| qtextstring, qa => $qa, dbh => $dbh, emsgstore => $emsg_r,
+ thingstring => 'routestring', prefix => 'rl',
+ onresults => sub {
+ foreach (@_) {
+ my ($canonname, $island, $arch) = @$_;
+ push @$islandids_r, $island;
+ push @$archipelagoes_r, defined $island ? undef : $arch;
+ }
+ }
+ &>
+ size=80
+</&>
+
+% } else { #---------- dropdowns, user selects from menus ----------
+
+<%perl>
+my %islandid2;
+my ($sth,$row);
+my @archlistdata;
+my %islandlistdata;
+$islandlistdata{'none'}= [ [ "none", "Select island..." ] ];
+
+my $optionlistmap= sub {
+ my ($optlist, $selected) = @_;
+ my $out='';
+ foreach my $entry (@$optlist) {
+ $out.= sprintf('<option value="%s" %s>%s</option>',
+ encode_entities($entry->[0]),
+ defined $selected && $entry->[0] eq $selected
+ ? 'selected' : '',
+ encode_entities($entry->[1]));
+ }
+ return $out;
+};
+
+$sth= $dbh->prepare("SELECT DISTINCT archipelago FROM islands
+ ORDER BY archipelago;");
+$sth->execute();
+
+while ($row=$sth->fetchrow_arrayref) {
+ my ($arch)= @$row;
+ push @archlistdata, [ $arch, $arch ];
+ $islandlistdata{$arch}= [ [ "none", "Whole arch" ] ];
+}
+
+$sth= $dbh->prepare("SELECT islandid,islandname,archipelago
+ FROM islands
+ ORDER BY islandname;");
+$sth->execute();
+
+while ($row=$sth->fetchrow_arrayref) {
+ my $arch= $row->[2];
+ push @{ $islandlistdata{'none'} }, [ @$row ];
+ push @{ $islandlistdata{$arch} }, [ @$row ];
+ $islandid2{$row->[0]}= { Name => $row->[1], Arch => $arch };
+}
+
+my %resetislandlistdata;
+foreach my $arch (keys %islandlistdata) {
+ $resetislandlistdata{$arch}=
+ $optionlistmap->($islandlistdata{$arch}, '');
+}
+
+</%perl>
+
+<&| script &>
+ms_lists= <% to_json_protecttags(\%resetislandlistdata) %>;
+function ms_Setarch(dd) {
+ debug('ms_SetArch '+dd+' arch='+arch);
+ var arch= document.getElementsByName('archipelago'+dd).item(0).value;
+ var got= ms_lists[arch];
+ if (got == undefined) return; // unknown arch ? hrm
+ debug('ms_SetArch '+dd+' arch='+arch+' got ok');
+ var select= document.getElementsByName('islandid'+dd).item(0);
+ select.innerHTML= got;
+ debug('ms_SetArch '+dd+' arch='+arch+' innerHTML set');
+}
+</&script>
+
+<table style="table-layout:fixed; width:90%;">
+
+<tr>
+% for my $dd (0..$qa->{Dropdowns}-1) {
+<td>
+<select name="archipelago<% $dd %>" onchange="ms_Setarch(<% $dd %>)">
+<option value="none">Whole ocean</option>
+<% $optionlistmap->(\@archlistdata, $qa->{"archipelago$dd"}) %></select></td>
+% }
+</tr>
+
+<tr>
+% for my $dd (0..$qa->{Dropdowns}-1) {
+% my $arch= $qa->{"archipelago$dd"};
+% $arch= 'none' if !defined $arch;
+<td>
+<select name="islandid<% $dd %>">
+<% $optionlistmap->($islandlistdata{$arch}, $qa->{"islandid$dd"}) %>
+</select></td>
+% }
+</tr>
+
+</table>
+
+<%perl>
+
+my $argorundef= sub {
+ my ($dd,$base) = @_;
+ my $thing= $qa->{"${base}${dd}"};
+ $thing= undef if defined $thing and $thing eq 'none';
+ return $thing;
+};
+
+for my $dd (0..$qa->{Dropdowns}-1) {
+ my $arch= $argorundef->($dd,'archipelago');
+ my $island= $argorundef->($dd,'islandid');
+ next unless defined $arch or defined $island;
+ if (defined $island and defined $arch) {
+ my $ii= $islandid2{$island};
+ my $iarch= $ii->{Arch};
+ if ($iarch ne $arch) {
+ push @$warningfs_r, sub {
+</%perl>
+ Specified archipelago <% $arch %> but
+ island <% $ii->{Name} %>
+ which is in <% $iarch %>; using the island.<p>
+<%perl>
+ };
+ }
+ $arch= undef;
+ }
+ push @$archipelagoes_r, $arch;
+ push @$islandids_r, $island;
+}
+
+</%perl>
+<p>
+
+% }
You may share and modify the code and the
website, according to the terms of the GNU General Public Licence and
the GNU Affero General Public Licence respectively (v3 or later).
+Note that there is <strong>NO WARRANTY</strong>.
% if (!$isdevel) {
Please see the <a href="devel">YARRG Development webpage</a> for
details of how to obtain the client and server code and full details
</%doc>
-<html><head><title>YARRG (Yet Another Revenue Research Gatherer)</title>
+<html lang="en"><head>
+<title>YARRG (Yet Another Revenue Research Gatherer)</title>
</head><body>
<a href="lookup">YARRG</a> -
Yet Another Revenue Research Gatherer
|
-<a href="devel">development</a>
-|
<b>introduction</b>
|
<a href="docs">documentation</a>
+|
+<a href="devel">development</a>
<h1>Introduction to YARRG</h1>
<h2>Uploading from Linux</h2>
The YARRG upload client uploads both to YARRG and to the
-<a href="pctb.ilk.org">PCTB testing server</a>.
+<a href="http://pctb.ilk.org/">PCTB testing server</a>.
<p>
Before => 'Query: ',
Values => [ [ 'route', 'Trades for route' ],
[ 'commod', 'Prices for commodity' ],
+ [ 'offers', 'Offers at location' ],
[ 'age', 'Data age' ] ]
}, { Name => 'BuySell',
Before => '',
% }
</%method>
-<html><head><title><% ucfirst $ahtml{Query} %> - YARRG</title>
+<html lang="en"><head><title><% ucfirst $ahtml{Query} %> - YARRG</title>
<style type="text/css">
body {
color: #000000;
<a href="<% $m->current_comp()->name() |u %>">YARRG</a> -
Yet Another Revenue Research Gatherer
|
-<a href="devel">development</a>
-|
<a href="intro">introduction</a>
|
<a href="docs">documentation</a>
+|
+<a href="devel">development</a>
<p>
<%perl>
foreach my $var (keys %ARGS) {
next unless $var =~
- m/^(?: (?:route|commod|capacity)string |
+ m/^(?: (?:route|commod|capacity|capital)string |
lossperleague |
commodid |
islandid \d |
$dbh
$thingstring
$emsgstore
-$perresult
+$onresults
$prefix => 'ts';
+$helpref => undef;
</%args>
<%perl>
my $stringval= $qa->{$thingstring};
id="<% $thingstring %>" name="<% $thingstring %>"
onchange="<%$p%>Needed();" onkeyup="<%$p%>Later();"
value="<% $stringval |h %>"
- >
+ ><% defined($helpref) ? "<a href=\"docs#$helpref\">[?]</a>" : '' %>
<br>
<div id="<%$p%>results"> </div><br>
<%perl>
if (length $thingstring) {
- my ($emsg,$canonstring,$results)= $m->comp('qtextstringcheck',
+ my ($emsg,$canonstring,@results)= $m->comp('qtextstringcheck',
what => $thingstring,
ocean => $qa->{Ocean},
string => $stringval,
$$emsgstore='' unless defined $$emsgstore;
$$emsgstore .= $emsg. ' ';
}
-
- foreach my $entry (@$results) {
-#print STDERR "qts entry perresult \`@$entry'\n";
- $perresult->(@$entry);
- }
+ $onresults->(@results);
}
</%perl>
$string
$what
$dbh => undef
+$debug => 0
</%args>
<%flags>
use Data::Dumper;
use HTML::Entities;
use CommodsWeb;
+use Scalar::Util qw(blessed);
die if $what =~ m/[^a-z]/;
my $chk= $m->fetch_comp("check_${what}");
my $mydbh;
$dbh ||= ($mydbh= dbw_connect($ocean));
-#print STDERR "qtsc string=\`$string'\n";
+my $debugf= !$debug ? sub { } : sub {
+ print "@_\n";
+};
-my ($sth, @sqlstmt_qs);
-if ($chk->method_exists('sqlstmt')) {
- my $sqlstmt= $chk->scall_method("sqlstmt");
- $sth= $dbh->prepare($sqlstmt);
- @sqlstmt_qs= $sqlstmt =~ m/\?/g;
-}
+$debugf->("QTSC STRING '$string'");
my $emsg= '';
my @results;
-my @specs;
my $canontext;
-my $hooks = { Emsg => \$emsg, String => \$string,
- Results => \@results, Specs => \@specs,
- Canon => \$canontext
- };
-if ($chk->method_exists('preparse')) {
- $chk->call_method('preparse', h => $hooks);
-} else {
- @specs= $chk->attr('multiple') ? (split m#[/|,]#, $string) : ($string);
-}
+$string =~ s/^\s*//;
+$string =~ s/\s$//;
+$string =~ s/\s+/ /g;
-no warnings qw(exiting);
-
-foreach my $each (@specs) {
- $each =~ s/^\s*//; $each =~ s/\s*$//; $each =~ s/\s+/ /g;
- next if !length $each;
- my $err= sub { $emsg= $_[0]; last; };
- my %m;
- my $results;
- foreach my $pat ("$each", "$each\%", "\%$each\%") {
- $sth->execute(($pat) x @sqlstmt_qs);
- $results= $sth->fetchall_arrayref();
- last if @$results==1;
- map { $m{ $_->[0] }=1 } @$results;
- $results= undef;
+if ($chk->method_exists('execute')) {
+ ($canontext, @results)= eval {
+ $chk->call_method('execute',
+ dbh => $dbh, string => $string,
+ debugf => $debugf);
+ };
+ if ($@) {
+ die unless blessed $@ && $@->isa('CommodsWeb::ExpectedError');
+ $emsg= $@->emsg();
}
- if (!$results) {
- if (!%m) {
- $err->($chk->scall_method("nomatch",
- spec => $each));
- } elsif (keys(%m) > $chk->attr('maxambig')) {
- $err->($chk->scall_method("manyambig"));
- } else {
- $err->($chk->scall_method("ambiguous",
- spec => $each,
- couldbe => join(', ', sort keys %m)));
+} else {
+ my $sqlstmt= $chk->scall_method("sqlstmt");
+ my $sth= $dbh->prepare($sqlstmt);
+ my @sqlstmt_nqs= $sqlstmt =~ m/\?/g;
+ my $sqlstmt_nqs= @sqlstmt_nqs;
+
+ my @specs= $chk->attr('multiple')
+ ? (split m#\s*[/|,]\s*#, $string)
+ : ($string);
+
+ foreach my $each (@specs) {
+ next unless $each =~ m/\S/;
+ my ($temsg, @tresults) =
+ dbw_lookup_string($each,
+ $sth, $sqlstmt_nqs,
+ $chk->attr_exists('abbrev_initials'),
+ $chk->attr('maxambig'),
+ $chk->scall_method("nomatch", spec => $each),
+ $chk->scall_method("manyambig"),
+ sub {
+ $chk->scall_method("ambiguous",
+ spec => $each, couldbe => $_[1])
+ });
+ if (defined $temsg) {
+ $emsg= $temsg;
+ last;
}
- }
- push @results, $results->[0];
-};
+ push @results, [ @tresults ];
+ };
+}
if (!defined $canontext) {
$canontext= join ' | ', map { $_->[0] } @results;
}
-if ($chk->method_exists('postquery')) {
- $chk->call_method('postquery', h => $hooks);
-}
$emsg='' if !defined $emsg;
@results=() if length $emsg;
-#print STDERR "qtsc emsg=\`$emsg' results=\`@results'\n";
+$debugf->("QTSC EMSG='$emsg' RESULTS='@results'");
if ($format =~ /json/) {
- $r->content_type($ctype or $format);
+ $ctype ||= $format;
+ die unless grep { $_ eq $ctype }
+ qw(application/json text/plain text/xml);
+ $r->content_type($ctype);
my $jobj= {
success => 1*!length $emsg,
show => (length $emsg ? $emsg :
return $emsg,
$canontext,
- [ @results ];
+ @results;
</%perl>
<tr id=<% $rowid %> class="<% 'datarow'.($rowix & 1) %>"
> <td><% $row->{'archipelago'} |h
%> <td><% $row->{'islandname'} |h
- %> <td id="<% $cellid %>"><% prettyprint_age($age) %> </tr>
+ %> <td id="<% $cellid %>" align=right><% prettyprint_age($age) %> </tr>
% $rowix++;
% }
</table>
<form action="<% $quri->() |h %>" method="get">
-%#---------- textbox, user enters route as string ----------
-% if (!$qa->{Dropdowns}) {
-
-Enter commodity (abbreviations are OK):<br>
-
-<&| qtextstring, qa => $qa, dbh => $dbh,
- thingstring => 'commodstring', emsgstore => \$emsg,
- perresult => sub { ($commodname,$cmid)= @_; }
+<& enter_commod, qa => $qa, dbh => $dbh, emsg_r => \$emsg,
+ commodname_r => \$commodname,
+ cmid_r => \$cmid
&>
- size=80
-</&>
-
-% } else { #---------- dropdowns, user selects from menus ----------
-
-% my $sth= $dbh->prepare("SELECT commodname,commodid FROM commods
-% ORDER BY commodname");
-% $sth->execute();
-% my $row;
-<select name="commodid">
-<option value="">Select commodity...</option>
-% while ($row= $sth->fetchrow_arrayref) {
-% my $selected= $commodid eq $row->[1] ? 'selected' : '';
-<option value="<% $row->[1] %>" <% $selected %>><% $row->[0] |h %></option>
-% ($commodname,$cmid) = @$row if $selected;
-% }
-</select>
-
-% } #---------- end of dropdowns, now common middle of page code ----------
<input type=submit name=submit value="Go">
% my $ours= sub { $_[0] =~ m/^commodstring|^commodid/; };
% my $rowix= 0;
% while ($island= $islands->fetchrow_hashref) {
% if (!$rowix) {
-<table id="<% $bs %>_table">
+<table id="<% $bs %>_table" rules=groups>
+<colgroup span=2>
+<colgroup span=1>
+<colgroup span=2>
+<colgroup span=3>
<tr>
-<th colspan=3>
+<th colspan=2>
+<th colspan=1>
<th colspan=2>Prices
<th colspan=3>Quantity at price
<tr id="<% $bs %>_table_thr">
<td><% $s->[0]= $island->{'archipelago'} |h %>
<td><% $s->[1]= $island->{'islandname'} |h %>
<td><% $stallname |h %>
- <td><% $s->[3]= (length $bestqty ? $bestprice : '-') %>
- <td><% $s->[4]= $median %>
- <td><% $s->[5]= $bestqty %>
- <td><% $s->[6]= $approxqty %>
- <td><% $s->[7]= $cqty %>
+ <td align=right><% $s->[3]= (length $bestqty ? $bestprice : '-') %>
+ <td align=right><% $s->[4]= $median %>
+ <td align=right><% $s->[5]= $bestqty %>
+ <td align=right><% $s->[6]= $approxqty %>
+ <td align=right><% $s->[7]= $cqty %>
</tr>
% for my $cix (0..$#$s) {
% $ts_sortkeys{$cix}{$rowid}= $s->[$cix];
--- /dev/null
+<%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 generates the core of the `offers' query.
+
+
+</%doc>
+<%args>
+$quri
+$dbh
+$commodid => undef;
+$commodstring => '';
+$islandid => undef;
+$prselector
+$someresults
+$emsgokorprint
+</%args>
+
+<%perl>
+my $emsg;
+my @warningfs;
+my @islandids;
+my @archipelagoes;
+my ($commodname,$cmid);
+
+my $qa= \%ARGS;
+</%perl>
+
+<h1>Prices for commodity at location(s)</h1>
+
+% $prselector->('BuySell');
+
+<form action="<% $quri->() |h %>" method="get">
+
+<& enter_commod, qa => $qa, dbh => $dbh, emsg_r => \$emsg,
+ commodname_r => \$commodname,
+ cmid_r => \$cmid
+ &>
+
+<& enter_route, qa => $qa, dbh => $dbh, emsg_r => \$emsg,
+ warningfs_r => \@warningfs,
+ enterwhat => 'Enter location',
+ islandids_r => \@islandids,
+ archipelagoes_r => \@archipelagoes
+ &>
+
+<input type=submit name=submit value="Go">
+% my $ours= sub { $_[0] =~
+% m/^commodstring|^commodid|^routestring|^archipelago|^island/;
+% };
+<& "lookup:formhidden", ours => $ours &>
+
+</form>
+
+%#========== results ==========
+<%perl>
+
+$emsgokorprint->($emsg) or $cmid=undef;
+return unless defined $cmid and @islandids;
+
+foreach my $wf (@warningfs) { $wf->(); }
+
+if ($qa->{'debug'}) {
+</%perl>
+<pre>
+bs= <% $qa->{BuySell} %>
+cmdid= <% $cmid %>
+islandids= <% join ',', map { defined($_) ? $_ : 'U' } @islandids %>
+</pre>
+<%perl>
+}
+
+my $locdesc;
+if (@islandids>1) {
+ $locdesc= ' at specified locations';
+} elsif (defined $islandids[0]) {
+ my $sth= $dbh->prepare("SELECT islandname FROM islands
+ WHERE islandid == ?");
+ $sth->execute($islandids[0]);
+ $locdesc= ' at '.($sth->fetchrow_array())[0];
+} else {
+ $locdesc= ' in '.$archipelagoes[0];
+}
+
+my $now= time;
+
+my @conds;
+my @condvals;
+push @condvals, $cmid;
+foreach my $ix (0..$#islandids) {
+ my $iid= $islandids[$ix];
+ my $arch= $archipelagoes[$ix];
+ if (defined $iid) {
+ push @conds, 'offers.islandid == ?';
+ push @condvals, $iid;
+ } else {
+ push @conds, 'islands.archipelago == ?';
+ push @condvals, $arch;
+ }
+}
+foreach my $bs (split /_/, $qa->{BuySell}) {
+ my %da_ages;
+ my %ts_sortkeys;
+
+ die unless grep { $bs eq $_ } qw(buy sell);
+ my $ascdesc= $bs eq 'buy' ? 'DESC' : 'ASC';
+</%perl>
+<h2>Offers to <% uc $bs |h %> <% $commodname |h %> <% $locdesc %></h2>
+<%perl>
+ my $stmt= "
+ SELECT archipelago, islandname,
+ stallname, price, qty, timestamp,
+ offers.stallid
+ FROM $bs AS offers
+ JOIN islands ON offers.islandid==islands.islandid
+ JOIN uploads ON offers.islandid==uploads.islandid
+ JOIN stalls ON offers.stallid==stalls.stallid
+ WHERE offers.commodid == ?
+ AND ( ".join("
+ OR ", @conds)."
+ )
+ ORDER BY archipelago, islandname, price $ascdesc, qty ASC,
+ stallname $ascdesc
+";
+ if ($qa->{'debug'}) {
+</%perl>
+<pre>
+<% $stmt %>
+<% join ',', @condvals |h %>
+</pre>
+<%perl>
+ }
+
+ my $row;
+ my $sth= $dbh->prepare($stmt);
+ $sth->execute(@condvals);
+ my $rowix= 0;
+</%perl>
+% while ($row= $sth->fetchrow_arrayref) {
+% if (!$rowix) {
+<table id="<% $bs %>_table" rules=groups>
+<colgroup span=2>
+<colgroup span=3>
+<colgroup span=1>
+<tr>
+<th>Archipelago
+<th>Island
+<th>Stall or Shoppe
+<th>Price
+<th>Quantity
+<th>Data age
+</tr>
+% }
+% my $rowid= ${bs}.$row->[6];
+% my $tscellid= "c$rowid";
+% my $age= $now - $row->[5];
+% $da_ages{$rowid}= $age;
+% $row->[5]=
+<tr id=<% $rowid %> class="<% 'datarow'.($rowix & 1) %>" >
+% foreach my $ci (0..4) {
+% my $val= $row->[$ci];
+% $ts_sortkeys{$ci}{$rowid}= $val;
+<td <% $ci >= 3 ? 'align=right' : '' %> ><% $val |h %>
+% }
+<td id="<% $tscellid %>" align=right><% prettyprint_age($age) %>
+</tr>
+% $rowix++;
+% }
+% if ($rowix) {
+</table>
+
+<&| tabsort, table => "${bs}_table", rowclass => 'datarow', cols => [
+ {}, {}, {},
+ { Numeric => 1, DoReverse => 1 },
+ { Numeric => 1, DoReverse => 1 },
+ { Numeric => 1, DoReverse => 1, SortKey => "${bs}_ages[rowid]" }],
+ sortkeys => "${bs}_sortkeys"
+ &>
+ <%$bs%>_sortkeys= <% to_json_protecttags(\%ts_sortkeys) %>;
+ <%$bs%>_ages= <% to_json_protecttags(\%da_ages) %>;
+</&tabsort>
+% } else {
+No offers.
+% }
+
+<%perl>
+}
+</%perl>
+
+<p>
+(Please don't use these pages to scrape data out of the YARRG
+database. This will be a pain for you to program, slow to run, and
+pointlessly overload our server. Instead, see our
+<a href="devel">information for developers</a>
+to find out how to get testing data or a real-time feed.)
$routestring => '';
$capacitystring => '';
$lossperleague => '';
+$capitalstring => '';
$someresults
$emsgokorprint
</%args>
<%perl>
my $emsg;
+my @warningfs;
my @archipelagoes;
my @islandids;
-my %islandid2;
my ($max_volume, $max_mass);
my $lossperleaguepct;
+my $capital;
my $qa= \%ARGS;
<h1>Specify route</h1>
-% $prselector->('ShowStalls');
-
-%#---------- textbox, user enters route as string ----------
+% # Sadly we need to do this rather hacky thing to make it be a POST
+% # form if the user has already selected some thing(s)
% if (!$qa->{Dropdowns}) {
+% $startform->($routestring =~ m/\S/);
+% } else {
+% $startform->(grep {
+% defined $qa->{"archipelago$_"} ||
+% defined $qa->{"islandid$_"}
+% } (0..$qa->{Dropdowns}-1));
+% }
-Enter route (islands, or archipelagoes, separated by |s or commas;
- abbreviations are OK):<br>
-
-% $startform->($routestring =~ m/\S/);
+% $prselector->('ShowStalls');
-<&| qtextstring, qa => $qa, dbh => $dbh,
- thingstring => 'routestring', emsgstore => \$emsg,
- perresult => sub {
- my ($canonname, $island, $arch) = @_;
- push @islandids, $island;
- push @archipelagoes, defined $island ? undef : $arch;
- }
+<& enter_route, qa => $qa, dbh => $dbh, emsg_r => \$emsg,
+ warningfs_r => \@warningfs,
+ enterwhat => 'Enter route',
+ islandids_r => \@islandids,
+ archipelagoes_r => \@archipelagoes
&>
- size=80
-</&>
+
+%#---------- textboxes, user enters details as strings ----------
+% if (!$qa->{Dropdowns}) {
<strong>Advanced options - you may leave these blank:</strong>
<p>
-<table>
-<tr>
-<td>
+<table><tr><td>
Vessel or capacity:
<&| qtextstring, qa => $qa, dbh => $dbh, prefix => 'cs',
thingstring => 'capacitystring', emsgstore => \$emsg,
- perresult => sub {
- ($max_volume,$max_mass) = @_;
- }
+ helpref => 'capacity',
+ onresults => sub { ($max_mass,$max_volume) = @_; }
&>
- size=30
+ size=40
</&>
<td>
<&| qtextstring, qa => $qa, dbh => $dbh, prefix => 'll',
thingstring => 'lossperleague', emsgstore => \$emsg,
- perresult => sub { ($lossperleaguepct)= @_; }
+ helpref => 'losses',
+ onresults => sub { ($lossperleaguepct)= @_; }
&>
- size=10
+ size=9
</&>
</table>
+<table><tr>
-% } else { #---------- dropdowns, user selects from menus ----------
-
-% $startform->(grep {
-% defined $ARGS{"archipelago$_"} ||
-% defined $ARGS{"islandid$_"}
-% } (0..$qa->{Dropdowns}-1));
-
-<%perl>
-my ($sth,$row);
-my @archlistdata;
-my %islandlistdata;
-$islandlistdata{'none'}= [ [ "none", "Select island..." ] ];
-
-my $optionlistmap= sub {
- my ($optlist, $selected) = @_;
- my $out='';
- foreach my $entry (@$optlist) {
- $out.= sprintf('<option value="%s" %s>%s</option>',
- encode_entities($entry->[0]),
- defined $selected && $entry->[0] eq $selected
- ? 'selected' : '',
- encode_entities($entry->[1]));
- }
- return $out;
-};
-
-$sth= $dbh->prepare("SELECT DISTINCT archipelago FROM islands
- ORDER BY archipelago;");
-$sth->execute();
-
-while ($row=$sth->fetchrow_arrayref) {
- my ($arch)= @$row;
- push @archlistdata, [ $arch, $arch ];
- $islandlistdata{$arch}= [ [ "none", "Whole arch" ] ];
-}
-
-$sth= $dbh->prepare("SELECT islandid,islandname,archipelago
- FROM islands
- ORDER BY islandname;");
-$sth->execute();
+<td>Available capital:
-while ($row=$sth->fetchrow_arrayref) {
- my $arch= $row->[2];
- push @{ $islandlistdata{'none'} }, [ @$row ];
- push @{ $islandlistdata{$arch} }, [ @$row ];
- $islandid2{$row->[0]}= { Name => $row->[1], Arch => $arch };
-}
-
-my %resetislandlistdata;
-foreach my $arch (keys %islandlistdata) {
- $resetislandlistdata{$arch}=
- $optionlistmap->($islandlistdata{$arch}, '');
-}
-
-</%perl>
-
-<&| script &>
-ms_lists= <% to_json_protecttags(\%resetislandlistdata) %>;
-function ms_Setarch(dd) {
- debug('ms_SetArch '+dd+' arch='+arch);
- var arch= document.getElementsByName('archipelago'+dd).item(0).value;
- var got= ms_lists[arch];
- if (got == undefined) return; // unknown arch ? hrm
- debug('ms_SetArch '+dd+' arch='+arch+' got ok');
- var select= document.getElementsByName('islandid'+dd).item(0);
- select.innerHTML= got;
- debug('ms_SetArch '+dd+' arch='+arch+' innerHTML set');
-}
-</&script>
-
-<table style="table-layout:fixed; width:90%;">
-
-<tr>
-% for my $dd (0..$qa->{Dropdowns}-1) {
-<td>
-<select name="archipelago<% $dd %>" onchange="ms_Setarch(<% $dd %>)">
-<option value="none">Whole ocean</option>
-<% $optionlistmap->(\@archlistdata, $ARGS{"archipelago$dd"}) %></select></td>
-% }
-</tr>
-
-<tr>
-% for my $dd (0..$qa->{Dropdowns}-1) {
-% my $arch= $ARGS{"archipelago$dd"};
-% $arch= 'none' if !defined $arch;
-<td>
-<select name="islandid<% $dd %>">
-<% $optionlistmap->($islandlistdata{$arch}, $ARGS{"islandid$dd"}) %>
-</select></td>
-% }
-</tr>
+<&| qtextstring, qa => $qa, dbh => $dbh, prefix => 'ac',
+ thingstring => 'capitalstring', emsgstore => \$emsg,
+ helpref => 'capital',
+ onresults => sub { ($capital)= @_; }
+ &>
+ size=9
+</&>
</table>
<input type=submit name=submit value="<% $goupdate->() %>">
% my $ours= sub { $_[0] =~
-% m/^island|^archipelago|^routestring|^capacitystring|^lossperleague|^[RT]/;
+% m/^island|^archipelago|^routestring|^capacitystring|^lossperleague|^capitalstring|^[RT]/;
% };
<& "lookup:formhidden", ours => $ours &>
$emsgokorprint->($emsg) or @islandids=();
-my $argorundef= sub {
- my ($dd,$base) = @_;
- my $thing= $ARGS{"${base}${dd}"};
- $thing= undef if defined $thing and $thing eq 'none';
- return $thing;
-};
-
-for my $dd (0..$qa->{Dropdowns}-1) {
- my $arch= $argorundef->($dd,'archipelago');
- my $island= $argorundef->($dd,'islandid');
- next unless defined $arch or defined $island;
- if (defined $island and defined $arch) {
- my $ii= $islandid2{$island};
- my $iarch= $ii->{Arch};
- if ($iarch ne $arch) {
- $someresults->();
-</%perl>
- Specified archipelago <% $arch %> but
- island <% $ii->{Name} %>
- which is in <% $iarch %>; using the island.<br>
-<%perl>
- }
- $arch= undef;
- }
- push @archipelagoes, $arch;
- push @islandids, $island;
+foreach my $warningf (@warningfs) {
+ $someresults->();
+ $warningf->();
}
</%perl>
qa => $qa,
max_mass => $max_mass,
max_volume => $max_volume,
- lossperleaguepct => $lossperleaguepct
+ lossperleaguepct => $lossperleaguepct,
+ max_capital => $capital
&>
-</form>
% }
+</form>
$max_mass
$max_volume
$lossperleaguepct
+$max_capital
</%args>
<&| script &>
da_pageload= Date.now();
<%perl>
my $loss_per_league= defined $lossperleaguepct ? $lossperleaguepct*0.01 : 1e-7;
+my $loss_per_delay_slot= 1e-8;
my $now= time;
}
};
-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 %ipair2subflowinfs;
+# $ipair2subflowinfs{$orgi,$dsti}= [ [$orgix,$distix], ... ]
+
+my @subflows;
+# $subflows[0]{Flow} = { ... }
+# $subflows[0]{Org} = $orgix
+# $subflows[0]{Dst} = $dstix
+
+foreach my $org_i (0..$#islandids) {
+ my $org_isle= $islandids[$org_i];
+ my $org_cond= $sd_condition->('sell',$org_i);
my @dst_conds;
- foreach my $dst_i ($src_i..$#islandids) {
+ foreach my $dst_i ($org_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) {
+ # Don't ever consider sailing things round the houses:
+ next if defined $dst_isle and
+ grep { $dst_isle == $_ } @islandids[$org_i..$dst_i-1];
+ next if defined $org_isle and
+ grep { $org_isle == $_ } @islandids[$org_i+1..$dst_i];
+ my $dst_cond;
+ if ($dst_i==$org_i and !defined $org_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)";
+ $dst_cond= "sell.islandid = buy.islandid";
+ } else {
+ $dst_cond= $sd_condition->('buy',$dst_i);
}
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 ];
- }
+ if ($specific) {
+ push @{ $ipair2subflowinfs{$org_isle,$dst_isle} },
+ [ $org_i, $dst_i ];
}
}
- push @flow_conds, "$src_cond AND (
+ push @flow_conds, "$org_cond AND (
".join("
OR ",@dst_conds)."
)";
$f= {
Ix => scalar(@flows),
- Var => "f".@flows,
%$got
};
$f->{"org_stallid"}= $f->{"dst_stallid"}= 'all'
<%perl>
+my @sail_total;
+
if (!@flows) {
print 'No profitable trading opportunities were found.';
return;
$f->{"Max$v"}= sprintf "%.1f", $f->{"Max${v}SortKey"} * 1e-6;
}
+ my $sfis= $ipair2subflowinfs{$f->{'org_id'},$f->{'dst_id'}};
+ foreach my $sfi (@$sfis) {
+ my $subflow= {
+ Flow => $f,
+ Org => $sfi->[0],
+ Dst => $sfi->[1],
+ Var => sprintf "f%ss%s", $f->{Ix}, $sfi->[0]
+ };
+ push @{ $f->{Subflows} }, $subflow;
+ push @subflows, $subflow;
+ }
+
$f->{MarginSortKey}= sprintf "%d",
$f->{'dst_price'} * 10000 / $f->{'org_price'};
$f->{Margin}= sprintf "%3.1f%%",
my $first= $base;
do {
my $this= $uue % $base;
-print STDERR "uue=$uue this=$this ";
+#print STDERR "uue=$uue this=$this ";
$uue -= $this;
$uue /= $base;
$this += $first;
$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;
+#print STDERR " uue=$uue this=$this cmpu=$cmpu\n";
+ die "$cmpu $uue ?" if length $cmpu > 20;
} while ($uue);
$cmpu;
} @uid;
}
</%perl>
-% my $optimise= $specific && !$confusing && @islandids>1;
+% my $optimise= $specific;
% if (!$optimise) {
<p>
-% if (@islandids<=1) {
-Route contains only one location.
-% }
% 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 ==========
Maximize
totalprofit:
- ".(join "
- ", map {
- sprintf "%+.20f %s", $_->{ExpectedUnitProfit}, $_->{Var}
- } @flows)."
+";
+
+foreach my $sf (@subflows) {
+ my $eup= $sf->{Flow}{ExpectedUnitProfit};
+ $eup *= (1.0-$loss_per_delay_slot) ** $sf->{Org};
+ $cplex .= sprintf "
+ %+.20f %s", $eup, $sf->{Var};
+}
+$cplex .= "
Subject To
";
-my %avail_csts;
+my %avail_lims;
foreach my $flow (@flows) {
if ($flow->{Suppress}) {
- $cplex .= "
- $flow->{Var} = 0
-";
+ foreach my $sf (@{ $flow->{Subflows} }) {
+ $cplex .= "
+ $sf->{Var} = 0";
+ }
next;
}
foreach my $od (qw(org dst)) {
- my $cstname= join '_', (
+ my $limname= join '_', (
'avail',
$flow->{'commodid'},
$od,
$flow->{"${od}_price"},
$flow->{"${od}_stallid"},
);
-
- push @{ $avail_csts{$cstname}{Flows} }, $flow->{Var};
- $avail_csts{$cstname}{Qty}= $flow->{"${od}_qty_agg"};
+
+ push @{ $avail_lims{$limname}{SubflowVars} },
+ map { $_->{Var} } @{ $flow->{Subflows} };
+ $avail_lims{$limname}{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";
+foreach my $limname (sort keys %avail_lims) {
+ my $c= $avail_lims{$limname};
+ $cplex .=
+ sprintf(" %-30s","$limname:")." ".
+ join("+", @{ $c->{SubflowVars} }).
+ " <= ".$c->{Qty}."\n";
}
foreach my $ci (0..($#islandids-1)) {
- my @rel_flows;
+ my @rel_subflows;
+
foreach my $f (@flows) {
next if $f->{Suppress};
- next if $f->{'org_id'} == $f->{'dst_id'};
- next unless grep { $f->{'org_id'} == $_ }
- @islandids[0..$ci];
- next unless grep { $f->{'dst_id'} == $_ }
- @islandids[$ci+1..@islandids-1];
- push @rel_flows, $f;
-#print " RELEVANT $ci $f->{Ix} ";
+ my @relsubflow= grep {
+ $_->{Org} <= $ci &&
+ $_->{Dst} > $ci;
+ } @{ $f->{Subflows} };
+ next unless @relsubflow;
+ die unless @relsubflow == 1;
+ push @rel_subflows, @relsubflow;
+#print " RELEVANT $ci $relsubflow[0]->{Var} ";
}
-#print " RELEVANT $ci COUNT ".scalar(@rel_flows)." ";
- next unless @rel_flows;
- foreach my $mv (qw(mass volume)) {
- my $max_vn= "max_$mv";
- my $max= $mv eq 'mass' ? $max_mass : $max_volume;
- next unless defined $max;
+#print " RELEVANT $ci COUNT ".scalar(@rel_subflows)." ";
+ if (!@rel_subflows) {
+ foreach my $mv (qw(mass volume)) {
+ $sail_total[$ci]{$mv}= 0;
+ }
+ next;
+ }
+
+ my $applylimit= sub {
+ my ($mv, $max, $f2val) = @_;
+ $max= 1e9 unless defined $max;
#print " DEFINED MAX $mv $max ";
$cplex .= "
". sprintf("%-10s","${mv}_$ci:")." ".
- join(" + ", map { ($_->{"unit$mv"}*1e-3).' f'.$_->{Ix} } @rel_flows).
- " <= $max";
- }
+ join(" + ", map {
+#print " PART MAX $_->{Var} $_->{Flow}{Ix} ";
+ $f2val->($_->{Flow}) .' '. $_->{Var};
+ } @rel_subflows).
+ " <= $max";
+ };
+
+ $applylimit->('mass', $max_mass, sub { $_[0]{'unitmass'} *1e-3 });
+ $applylimit->('volume', $max_volume, sub { $_[0]{'unitvolume'}*1e-3 });
+ $applylimit->('capital',$max_capital,sub { $_[0]{'org_price'} });
$cplex.= "\n";
}
$cplex.= "
Bounds
".(join "
- ", map { "$_->{Var} >= 0" } @flows)."
+ ", map { "$_->{Var} >= 0" } @subflows)."
";
$cplex.= "
Integer
".(join "
- ", map { "f$_" } (0..$#flows))."
+ ", map { $_->{Var} } @subflows)."
End
";
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));
+ qw(glpsol --tmlim 2 --memlim 5 --intopt --cuts --bfs
+ --cpxlp /dev/stdin -o /dev/stdout));
print "<pre>\n" if $qa->{'debug'};
my $found_section= 0;
my $glpsol_out= '';
+ my $continuation='';
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;
+ if (m/^\s*No\.\s+(Row|Column) name\s+(?:St\s+)?Activity\s/) {
+ die "$_ $found_section ?" if $found_section>0;
$found_section= 1;
next;
}
next unless $found_section==1;
- next if m/^[- ]+$/;
- if (!/\S/) {
- $found_section= 2;
- next;
+ if (!length $continuation) {
+ next if !$continuation && m/^[- ]+$/;
+ if (!/\S/) {
+ $found_section= 0;
+ next;
+ }
+ if (m/^ \s* \d+ \s+ \w+ $/x) {
+ $continuation= $&;
+ next;
+ }
+ }
+ $_= $continuation.$_;
+ $continuation= '';
+ my ($varname, $qty) = m/^
+ \s* \d+ \s+
+ (\w+) \s+ (?: [A-Z*]+ \s+ )?
+ ([0-9.]+) \s
+ /x or die "$_ ?";
+ if ($varname =~ m/^f(\d+)s(\d+)$/) {
+ my ($ix,$orgix) = ($1,$2);
+ my $flow= $flows[$ix] or die;
+ my @relsubflow= grep { $_->{Org} == $orgix }
+ @{ $flow->{Subflows} };
+ die "$ix $orgix @relsubflow" unless @relsubflow == 1;
+ my $sf= $relsubflow[0];
+ $sf->{OptQty}= $qty;
+ $sf->{OptProfit}= $qty * $flow->{'unitprofit'};
+ $sf->{OptCapital}= $qty * $flow->{'org_price'};
+ } elsif ($varname =~ m/^(mass|volume)_(\d+)$/) {
+ my ($mv,$ix) = ($1,$2);
+ $sail_total[$ix]{$mv}= $qty;
}
- 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'};
my $prerr= "\n=====\n$cplex\n=====\n$glpsol_out\n=====\n ";
pipethrough_run_finish($output,$prerr);
- die $prerr unless $found_section;
+ map { defined $_->{OptQty} or die "$prerr $_->{Flow}{Ix}" } @subflows;
};
-$addcols->({ DoReverse => 1, Special => sub {
+$addcols->({ DoReverse => 1, TotalSubflows => 1, Special => sub {
my ($flow,$col,$v,$spec) = @_;
if ($flow->{ExpectedUnitProfit} < 0) {
$spec->{Span}= 3;
} }, qw(
OptQty
));
-$addcols->({ Total => 0, DoReverse => 1 }, qw(
+$addcols->({ Total => 0, DoReverse => 1, TotalSubflows => 1 }, qw(
OptCapital OptProfit
));
% Span => 1,
% Align => ($col->{Text} ? '' : 'align=right')
% };
-% my $v= $flow->{$col->{Name}};
+% my $cn= $col->{Name};
+% my $v;
+% if (!$col->{TotalSubflows}) {
+% $v= $flow->{$cn};
+% } else {
+% $v= 0;
+% $v += $_->{$cn} foreach @{ $flow->{Subflows} };
+% }
% if ($col->{Special}) { $col->{Special}($flow,$col,$v,$spec); }
% $col->{Total} += $v
% if defined $col->{Total} and not $flow->{Suppress};
<table rules=groups>
% foreach my $i (0..$#islandids) {
<tbody>
-<tr><td colspan=3>
+<tr><td colspan=4>
% $iquery->execute($islandids[$i]);
% my ($islandname) = $iquery->fetchrow_array();
% if (!$i) {
% } else {
% my $this_dist= $distance->($islandids[$i-1],$islandids[$i]);
% $total_dist += $this_dist;
+<%perl>
+ my $total_value= 0;
+ foreach my $sf (@subflows) {
+ next unless $sf->{Org} < $i && $sf->{Dst} >= $i;
+ $total_value +=
+ $sf->{OptQty} * $sf->{Flow}{'dst_price'};
+ }
+</%perl>
<strong>Sail to <% $islandname |h %></strong>
-- <% $this_dist |h %> leagues </td>
+- <% $this_dist |h %> leagues,
+ <% $total_value %>poe at risk
+ </td>
% }
<%perl>
my $age_reported= 0;
my %flowlists;
+ #print "<tr><td colspan=6>" if $qa->{'debug'};
foreach my $od (qw(org dst)) {
- foreach my $f (@flows) {
+ #print " [[ i $i od $od " if $qa->{'debug'};
+ foreach my $sf (@subflows) {
+ my $f= $sf->{Flow};
next if $f->{Suppress};
- next unless $f->{"${od}_id"} == $islandids[$i];
- next unless $f->{OptQty};
+ next unless $sf->{ucfirst $od} == $i;
+ #print " FLOW $f->{Ix} SUB #$sf->{Org}..$sf->{Dst} "
+ # if $qa->{'debug'};
+ next unless $sf->{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'));
+ die if $arbitrage and $sf->{Org} != $sf->{Dst};
my $price= $f->{"${od}_price"};
my $stallname= $f->{"${od}_stallname"};
my $todo= \$flowlists{$od}{
$$todo->{'stallname'}= $stallname;
$$todo->{Price}= $price;
$$todo->{Timestamp}= $f->{"${od}_timestamp"};
- $$todo->{Qty} += $f->{OptQty};
+ $$todo->{Qty} += $sf->{OptQty};
$$todo->{Total}= $$todo->{Price} * $$todo->{Qty};
$$todo->{Stalls}= $f->{"${od}Stalls"};
$$todo->{"${od}Arbitrage"}= 1 if $arbitrage;
}
+ #print "]] " if $qa->{'debug'};
}
+ #print "</tr>" if $qa->{'debug'};
- my $total;
+ my ($total, $total_to_show);
my $dline= 0;
- my $show_flows= sub {
- my ($od,$arbitrage,$collectdeliver) = @_;
+ my $show_total= sub {
+ my ($totaldesc, $sign) = @_;
+ if (defined $total) {
+ die if defined $total_to_show;
+ $total_total += $sign * $total;
+ $total_to_show= [ $totaldesc, $total ];
+ $total= undef;
+ }
+ $dline= 0;
+ };
+ my $show_total_now= sub {
+ my ($xinfo) = @_;
+ return unless defined $total_to_show;
+ my ($totaldesc,$totalwas) = @$total_to_show;
</%perl>
-%
+<tr>
+<td colspan=1>
+<td colspan=2><% $xinfo %>
+<td colspan=2 align=right><% $totaldesc %>
+<td align=right><% $totalwas |h %> total
+<%perl>
+ $total_to_show= undef;
+ };
+</%perl>
+% my $show_flows= sub {
+% my ($od,$arbitrage,$collectdeliver) = @_;
% my $todo= $flowlists{$od};
% return unless $todo;
% foreach my $tkey (sort keys %$todo) {
% my $t= $todo->{$tkey};
% next if $t->{"${od}Arbitrage"} != $arbitrage;
+% $show_total_now->('');
% if (!$age_reported++) {
% my $age= $now - $t->{Timestamp};
% my $cellid= "da_${i}";
% $da_ages{$cellid}= $age;
-<td colspan=3>\
+<td colspan=2>\
(Data age: <span id="<% $cellid %>"><% prettyprint_age($age) %></span>)
% } elsif (!defined $total) {
% $total= 0;
% $dline ^= 1;
% }
% };
-% my $show_total= sub {
-% my ($totaldesc, $sign)= @_;
-% if (defined $total) {
-<tr>
-<td colspan=3>
-<td colspan=2 align=right><% $totaldesc %>
-<td align=right><% $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);
-
+ my $totals= '';
+ if ($i < $#islandids) {
+ $totals .= "In hold $sail_total[$i]{mass}kg,".
+ " $sail_total[$i]{volume} l";
+ my $delim= '; spare ';
+ my $domv= sub {
+ my ($max, $got, $units) = @_;
+ return unless defined $max;
+ $totals .= $delim;
+ $totals .= sprintf "%g %s", ($max-$got), $units;
+ $delim= ', ';
+ };
+ $domv->($max_mass, $sail_total[$i]{mass}, 'kg');
+ $domv->($max_volume, $sail_total[$i]{volume}, 'l');
+ $totals .= ".\n";
+ }
+ $show_total_now->($totals);
}
</%perl>
<tbody><tr>
% print $m->content();
-% my $sortfn= "ts_sort__$table";
+% my $sortfn= "ts_s_$table";
function <% $sortfn %>(compar) {
debug('sorting compar='+compar);
var table= document.getElementById('<% $table %>');
% my $thhtml= '';
% next if $col->{NoSort};
-% my $mapfn= "ts_compar${cix}_map__$table";
-function <% $mapfn %>(rowelement) {
- var rowid = rowelement.id;
+% my $mapfn= "ts_${cix}m_$table";
+function <% $mapfn %>(re) {
+ var rowid = re.id;
% if ($col->{SortKey}) {
return <% $col->{SortKey} %>;
% } else {
% }
}
-% my $comparefn= "ts_compar${cix}_cmp0__$table";
+% my $comparefn= "ts_${cix}c0_$table";
function <% $comparefn %>(a,b) {
- var a_key = <% $mapfn %>(a);
- var b_key = <% $mapfn %>(b);
+ var ak = <% $mapfn %>(a);
+ var bk = <% $mapfn %>(b);
% if ($col->{Numeric}) {
- return a_key - b_key
+ return ak - bk
% } else {
- if (a_key < b_key) return -1;
- if (a_key > b_key) return +1;
+ if (ak < bk) return -1;
+ if (ak > bk) return +1;
return 0;
% }
}
% foreach my $reverse (qw(1 0)) {
-% my $tcomparefn= "ts_compar${cix}_cmp${reverse}__$table";
+% my $tcomparefn= "ts_${cix}c${reverse}_$table";
% if ($reverse) {
% next unless $col->{DoReverse};
function <% $tcomparefn %>(a,b) { return -<% $comparefn %>(a,b); }
+
% }
% $thhtml .= "<a href=\"javascript:$sortfn($tcomparefn)\">".
% ($reverse ? '∨' : '∧'). '</a>';
~yarrgweb / ypp-sc-tools.db-live.git / commitdiff