chiark / gitweb /
Merge branch 'ijackson'
authorIan Jackson <ian@liberator.relativity.greenend.org.uk>
Wed, 2 Sep 2009 23:39:36 +0000 (00:39 +0100)
committerIan Jackson <ian@liberator.relativity.greenend.org.uk>
Wed, 2 Sep 2009 23:39:36 +0000 (00:39 +0100)
yarrg/TODO
yarrg/web/check_capacitystring [new file with mode: 0644]
yarrg/web/check_lossperleague [new file with mode: 0644]
yarrg/web/lookup
yarrg/web/qtextstring
yarrg/web/qtextstringcheck
yarrg/web/query_route
yarrg/web/routetrade

index a2e2f34..6b227eb 100644 (file)
@@ -1,6 +1,8 @@
 UPLOADER
 --------
 
+       sometimes fails to work on Sage - sunshine widget resets or something
+
        detect all unexpected mouse movements
 
        more flexible installation arrangements
diff --git a/yarrg/web/check_capacitystring b/yarrg/web/check_capacitystring
new file mode 100644 (file)
index 0000000..3d8f7a5
--- /dev/null
@@ -0,0 +1,88 @@
+<%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>
diff --git a/yarrg/web/check_lossperleague b/yarrg/web/check_lossperleague
new file mode 100644 (file)
index 0000000..aaeb5b0
--- /dev/null
@@ -0,0 +1,65 @@
+<%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>
index 8fb3bb1..35b6ce7 100755 (executable)
@@ -124,8 +124,8 @@ body {
   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) {
@@ -153,7 +153,8 @@ foreach my $var (@vars) {
 
 foreach my $var (keys %ARGS) {
        next unless $var =~
-               m/^(?: (?:route|commod)string |
+               m/^(?: (?:route|commod|capacity)string |
+                       lossperleague |
                        commodid |
                        islandid \d |
                        archipelago \d |
index 84564df..639e9ab 100644 (file)
@@ -41,62 +41,65 @@ $dbh
 $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">&nbsp;</div><br>
+<div id="<%$p%>results">&nbsp;</div><br>
 
 <%perl>
 if (length $thingstring) {
@@ -106,9 +109,13 @@ 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);
        }
 }
index b2c1013..a489d8e 100755 (executable)
@@ -62,16 +62,29 @@ my $chk= $m->fetch_comp("check_${what}");
 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);
 
@@ -103,8 +116,17 @@ foreach my $each (@specs) {
        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);
index 393e7a6..296c012 100644 (file)
@@ -38,6 +38,8 @@ $quri
 $dbh
 $prselector
 $routestring => '';
+$capacitystring => '';
+$lossperleague => '';
 $someresults
 $emsgokorprint
 </%args>
@@ -47,6 +49,8 @@ my $emsg;
 my @archipelagoes;
 my @islandids;
 my %islandid2;
+my ($max_volume, $max_mass);
+my $lossperleaguepct;
 
 my $qa= \%ARGS;
 
@@ -84,6 +88,38 @@ Enter route (islands, or archipelagoes, separated by |s or commas;
  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>
+&nbsp;
+&nbsp;
+
+<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 {
@@ -181,7 +217,9 @@ function ms_Setarch(dd) {
 % } #---------- 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>
@@ -225,7 +263,10 @@ for my $dd (0..$qa->{Dropdowns}-1) {
    dbh => $dbh,
    islandids => \@islandids,
    archipelagoes => \@archipelagoes,
-   qa => $qa
+   qa => $qa,
+   max_mass => $max_mass,
+   max_volume => $max_volume,
+   lossperleaguepct => $lossperleaguepct
  &>
 </form>
 % }
index 4885782..9311f1a 100644 (file)
@@ -38,11 +38,24 @@ $dbh
 @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;
@@ -205,9 +218,12 @@ $addcols->({ DoReverse => 1, SortColKey => 'MarginSortKey' },
        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>
 
@@ -269,6 +285,12 @@ foreach my $f (@flows) {
        $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%%",
@@ -356,7 +378,7 @@ die "$cmpu $uue ?" if length $cmpu > 20;
 
 <p>
 % if (@islandids<=1) {
-Route is trivial.
+Route contains only one location.
 % }
 % if (!$specific) {
 Route contains archipelago(es), not just specific islands.
@@ -486,7 +508,7 @@ $addcols->({ Total => 0, DoReverse => 1 }, qw(
 <colgroup span=2>
 <colgroup span=2>
 <colgroup span=2>
-<colgroup span=1>
+<colgroup span=3>
 <colgroup span=3>
 %      if ($optimise) {
 <colgroup span=3>
@@ -499,8 +521,9 @@ $addcols->({ Total => 0, DoReverse => 1 }, qw(
 <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
 %      }
@@ -516,10 +539,12 @@ $addcols->({ Total => 0, DoReverse => 1 }, qw(
 <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
@@ -542,7 +567,8 @@ $addcols->({ Total => 0, DoReverse => 1 }, qw(
 %      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;
@@ -584,11 +610,11 @@ $addcols->({ Total => 0, DoReverse => 1 }, qw(
 <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>
 %      }