UPLOADER
--------
+ sometimes fails to work on Sage - sunshine widget resets or something
+
detect all unexpected mouse movements
more flexible installation arrangements
--- /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 capacities.
+
+</%doc>
+
+<%attr>
+</%attr>
+
+<%method preparse>
+<%args>
+$h
+</%args>
+<%perl>
+
+my $def= sub {
+ my ($what,$val) = @_;
+ if (defined $h->{$what}) {
+ $h->{Emsg}= "Multiple definitions of maximum $what.";
+ }
+ 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);
+ } else {
+ ${ $h->{Emsg} }= "Cannot understand capacity \`$_'.";
+ last;
+ }
+}
+</%perl>
+</%method>
+
+<%method postquery>
+<%args>
+$h
+</%args>
+<%perl>
+
+if (defined $h->{'mass'} or defined $h->{'volume'}) {
+ @{ $h->{Results} } = [ $h->{'mass'}, $h->{'volume'} ];
+
+ ${ $h->{Canon} }=
+ 'mass limit: '.(defined $h->{'mass'} ? $h->{'mass'} .'kg' : 'none').'; '.
+ 'volume limit: '.(defined $h->{'volume'} ? $h->{'volume'} .'l' : 'none').'.';
+}
+
+</%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 capacities.
+
+</%doc>
+
+<%attr>
+</%attr>
+
+<%method preparse>
+<%args>
+$h
+</%args>
+<%perl>
+
+$_= ${ $h->{String} };
+s/^\s+//; s/\s+$//;
+
+my $res= sub {
+ my ($pct,$str) = @_;
+ push @{ $h->{Results} }, [ $pct ];
+ ${ $h->{Canon} }= "Considering expected losses of $str per league";
+};
+
+if (!m/\S/) {
+} elsif (m/^(\d{1,2}(?:\.\d{0,5})?)\%$/) {
+ $res->( $1 * 1.0, sprintf("%g%%", $1) );
+} elsif (m/^1\s*\/\s*([1-9]\d{0,4})/) {
+ $res->( 100.0/$1, sprintf("1/%d", $1) );
+} else {
+ ${ $h->{Emsg} }= "Cannot understand loss per league \`$_'.";
+ return;
+}
+
+</%perl>
+</%method>
color: #000000;
background: #ffffff;
}
-tr.datarow0 { background: #ffffff; }
-tr.datarow1 { background: #e3e3e3; }
+tr.datarow0 { background: #e3e3e3; }
+tr.datarow1 { background: #ffffff; }
</style>
<&| script &>
function register_onload(f) {
foreach my $var (keys %ARGS) {
next unless $var =~
- m/^(?: (?:route|commod)string |
+ m/^(?: (?:route|commod|capacity)string |
+ lossperleague |
commodid |
islandid \d |
archipelago \d |
$thingstring
$emsgstore
$perresult
+$prefix => 'ts';
</%args>
<%perl>
my $stringval= $qa->{$thingstring};
$stringval='' if !defined $stringval;
+
+my $p= $prefix.'_';
</%perl>
<&| script &>
-ts_uri= "qtextstringcheck?format=application/json&ctype=text/xml"
+<%$p%>uri= "qtextstringcheck?format=application/json&ctype=text/xml"
+ "&what=<% $thingstring %>"
+ "&ocean=<% uri_escape($qa->{Ocean}) %>";
-ts_timeout=false;
-ts_request=false;
-ts_done='';
-ts_needed='';
-function ts_Later(){
- window.clearTimeout(ts_timeout);
- ts_timeout = window.setTimeout(ts_Needed, 500);
+<%$p%>timeout=false;
+<%$p%>request=false;
+<%$p%>done='';
+<%$p%>needed='';
+function <%$p%>Later(){
+ window.clearTimeout(<%$p%>timeout);
+ <%$p%>timeout = window.setTimeout(<%$p%>Needed, 500);
}
-function ts_Needed(){
- window.clearTimeout(ts_timeout);
- ts_element= document.getElementById('<% $thingstring %>');
- ts_needed= ts_element.value;
- ts_Request();
+function <%$p%>Needed(){
+ window.clearTimeout(<%$p%>timeout);
+ <%$p%>element= document.getElementById('<% $thingstring %>');
+ <%$p%>needed= <%$p%>element.value;
+ <%$p%>Request();
}
-function ts_Request(){
- if (ts_request || ts_needed==ts_done) return;
- ts_done= ts_needed;
- ts_request= new XMLHttpRequest();
- uri= ts_uri+'&string='+encodeURIComponent(ts_needed);
- ts_request.open('GET', uri);
- ts_request.onreadystatechange= ts_Ready;
- ts_request.send(null);
+function <%$p%>Request(){
+ if (<%$p%>request || <%$p%>needed==<%$p%>done) return;
+ <%$p%>done= <%$p%>needed;
+ <%$p%>request= new XMLHttpRequest();
+ uri= <%$p%>uri+'&string='+encodeURIComponent(<%$p%>needed);
+ <%$p%>request.open('GET', uri);
+ <%$p%>request.onreadystatechange= <%$p%>Ready;
+ <%$p%>request.send(null);
}
-function ts_Ready() {
- if (ts_request.readyState != 4) return;
- if (ts_request.status == 200) {
- response= ts_request.responseText;
- debug('got '+response);
+function <%$p%>Ready() {
+ if (<%$p%>request.readyState != 4) return;
+ if (<%$p%>request.status == 200) {
+ response= <%$p%>request.responseText;
+ debug('<%$p%> got '+response);
eval('results='+response);
- toedit= document.getElementById('ts_results');
+ toedit= document.getElementById('<%$p%>results');
toedit.innerHTML= results.show;
}
- ts_request= false;
- ts_Request();
+ <%$p%>request= false;
+ <%$p%>Request();
}
-register_onload(ts_Needed);
+register_onload(<%$p%>Needed);
</&script>
<input type="text" <% $m->content %>
id="<% $thingstring %>" name="<% $thingstring %>"
- onchange="ts_Needed();" onkeyup="ts_Later();"
+ onchange="<%$p%>Needed();" onkeyup="<%$p%>Later();"
value="<% $stringval |h %>"
>
<br>
-<div id="ts_results"> </div><br>
+<div id="<%$p%>results"> </div><br>
<%perl>
if (length $thingstring) {
string => $stringval,
format => 'return'
);
- $$emsgstore= $emsg;
+ if (defined $emsg and length $emsg) {
+ $$emsgstore='' unless defined $$emsgstore;
+ $$emsgstore .= $emsg. ' ';
+ }
foreach my $entry (@$results) {
+#print STDERR "qts entry perresult \`@$entry'\n";
$perresult->(@$entry);
}
}
my $mydbh;
$dbh ||= ($mydbh= dbw_connect($ocean));
-my $sqlstmt= $chk->scall_method("sqlstmt");
-my $sth= $dbh->prepare($sqlstmt);
-my @sqlstmt_qs= $sqlstmt =~ m/\?/g;
+#print STDERR "qtsc string=\`$string'\n";
-#die "$sqlstmt @sqlstmt_qs";
+my ($sth, @sqlstmt_qs);
+if ($chk->method_exists('sqlstmt')) {
+ my $sqlstmt= $chk->scall_method("sqlstmt");
+ $sth= $dbh->prepare($sqlstmt);
+ @sqlstmt_qs= $sqlstmt =~ m/\?/g;
+}
my $emsg= '';
my @results;
-
-my @specs= $chk->attr('multiple') ? (split m#[/|,]#, $string) : ($string);
+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);
+}
no warnings qw(exiting);
push @results, $results->[0];
};
+if (!defined $canontext) {
+ $canontext= join ' | ', map { $_->[0] } @results;
+}
+if ($chk->method_exists('postquery')) {
+ $chk->call_method('postquery', h => $hooks);
+}
+
$emsg='' if !defined $emsg;
-my $canontext= join ' | ', map { $_->[0] } @results;
+@results=() if length $emsg;
+
+#print STDERR "qtsc emsg=\`$emsg' results=\`@results'\n";
if ($format =~ /json/) {
$r->content_type($ctype or $format);
$dbh
$prselector
$routestring => '';
+$capacitystring => '';
+$lossperleague => '';
$someresults
$emsgokorprint
</%args>
my @archipelagoes;
my @islandids;
my %islandid2;
+my ($max_volume, $max_mass);
+my $lossperleaguepct;
my $qa= \%ARGS;
size=80
</&>
+<strong>Advanced options - you may leave these blank:</strong>
+<p>
+<table>
+<tr>
+<td>
+
+Vessel capacity:
+<&| qtextstring, qa => $qa, dbh => $dbh, prefix => 'cs',
+ thingstring => 'capacitystring', emsgstore => \$emsg,
+ perresult => sub {
+ ($max_volume,$max_mass) = @_;
+ }
+ &>
+ size=30
+</&>
+
+<td>
+
+
+
+<td>
+Estimated loss per league:
+
+<&| qtextstring, qa => $qa, dbh => $dbh, prefix => 'll',
+ thingstring => 'lossperleague', emsgstore => \$emsg,
+ perresult => sub { ($lossperleaguepct)= @_; }
+ &>
+ size=10
+</&>
+
+</table>
+
% } else { #---------- dropdowns, user selects from menus ----------
% $startform->(grep {
% } #---------- end of dropdowns, now common middle of page code ----------
<input type=submit name=submit value="<% $goupdate->() %>">
-% my $ours= sub { $_[0] =~ m/^island|^archipelago|^routestring|^[RT]/; };
+% my $ours= sub { $_[0] =~
+% m/^island|^archipelago|^routestring|^capacitystring|^lossperleague|^[RT]/;
+% };
<& "lookup:formhidden", ours => $ours &>
<%perl>
dbh => $dbh,
islandids => \@islandids,
archipelagoes => \@archipelagoes,
- qa => $qa
+ qa => $qa,
+ max_mass => $max_mass,
+ max_volume => $max_volume,
+ lossperleaguepct => $lossperleaguepct
&>
</form>
% }
@islandids
@archipelagoes
$qa
+$max_mass
+$max_volume
+$lossperleaguepct
</%args>
<&| script &>
da_pageload= Date.now();
</&script>
+% if (defined $max_mass || defined $max_volume) {
+<strong>WARNING - VESSEL CAPACITY LIMIT NOT YET IMPLEMENTED</strong>
+<p>
+% }
+% if (defined $lossperleaguepct) {
+<strong>WARNING - DEFINED LOSS PER LEAGUE NOT YET IMPLEMENTED</strong>
+<% $lossperleaguepct |h %>
+<p>
+% }
+
<%perl>
my $now= time;
qw( Margin
));
$addcols->({ DoReverse => 1 },
- qw( unitprofit dist MaxQty
- MaxCapital MaxProfit
+ qw( unitprofit MaxQty MaxCapital MaxProfit dist
));
+foreach my $v (qw(MaxMass MaxVolume)) {
+ $addcols->({
+ DoReverse => 1, Total => 0, SortColKey => "${v}SortKey" }, $v);
+}
</%perl>
$f->{MaxProfit}= $f->{MaxQty} * $f->{'unitprofit'};
$f->{MaxCapital}= $f->{MaxQty} * $f->{'org_price'};
+ $f->{MaxMassSortKey}= $f->{MaxQty} * $f->{'unitmass'};
+ $f->{MaxVolumeSortKey}= $f->{MaxQty} * $f->{'unitvolume'};
+ foreach my $v (qw(Mass Volume)) {
+ $f->{"Max$v"}= sprintf "%.1f", $f->{"Max${v}SortKey"} * 1e-6;
+ }
+
$f->{MarginSortKey}= sprintf "%d",
$f->{'dst_price'} * 10000 / $f->{'org_price'};
$f->{Margin}= sprintf "%3.1f%%",
<p>
% if (@islandids<=1) {
-Route is trivial.
+Route contains only one location.
% }
% if (!$specific) {
Route contains archipelago(es), not just specific islands.
<colgroup span=2>
<colgroup span=2>
<colgroup span=2>
-<colgroup span=1>
+<colgroup span=3>
<colgroup span=3>
% if ($optimise) {
<colgroup span=3>
<th colspan=2>Collect
<th colspan=2>Deliver
<th colspan=2>Profit
-<th colspan=1>
<th colspan=3>Max
+<th colspan=1>
+<th colspan=2>Max
% if ($optimise) {
<th colspan=3>Planned
% }
<th>Qty
<th>Margin
<th>Unit
-<th>Dist
<th>Qty
<th>Capital
<th>Profit
+<th>Dist
+<th>Mass
+<th>Vol
% if ($optimise) {
<th>Qty
<th>Capital
% foreach my $ci (1..$#cols) {
% my $col= $cols[$ci];
% my $v= $flow->{$col->{Name}};
-% $col->{Total} += $v if defined $col->{Total};
+% $col->{Total} += $v
+% if defined $col->{Total} and not $flow->{Suppress};
% $v='' if !$col->{Text} && !$v;
% my $sortkey= $col->{SortColKey} ?
% $flow->{$col->{SortColKey}} : $v;
<tr><td colspan=3>
% $iquery->execute($islandids[$i]);
% my ($islandname) = $iquery->fetchrow_array();
-% my $this_dist= $distance->($islandids[$i-1],$islandids[$i]);
-% $total_dist += $this_dist;
% if (!$i) {
<strong>Start at <% $islandname |h %></strong>
% } else {
+% my $this_dist= $distance->($islandids[$i-1],$islandids[$i]);
+% $total_dist += $this_dist;
<strong>Sail to <% $islandname |h %></strong>
- <% $this_dist |h %> leagues </td>
% }
~yarrgweb / ypp-sc-tools.db-test.git / commitdiff