From: Ian Jackson Date: Wed, 2 Sep 2009 23:39:36 +0000 (+0100) Subject: Merge branch 'ijackson' X-Git-Tag: 3.4~13 X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~yarrgweb/git?p=ypp-sc-tools.web-live.git;a=commitdiff_plain;h=742ec1631db983f22545c9c7d6d573865bdc85fa;hp=40f5e6b637d854f644916adb0ba863fe2628ab6f Merge branch 'ijackson' --- diff --git a/yarrg/TODO b/yarrg/TODO index a2e2f34..6b227eb 100644 --- a/yarrg/TODO +++ b/yarrg/TODO @@ -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 index 0000000..3d8f7a5 --- /dev/null +++ b/yarrg/web/check_capacitystring @@ -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 + Copyright (C) 2009 Clare Boothby + + YARRG's client code etc. is covered by the ordinary GNU GPL (v3 or later). + The YARRG website is covered by the GNU Affero GPL v3 or later, which + basically means that every installation of the website will let you + download the source. + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU Affero General Public License as + published by the Free Software Foundation, either version 3 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Affero General Public License for more details. + + You should have received a copy of the GNU Affero General Public License + along with this program. If not, see . + + Yohoho and Puzzle Pirates are probably trademarks of Three Rings and + are used without permission. This program is not endorsed or + sponsored by Three Rings. + + + This Mason component simply defines how to interpret capacities. + + + +<%attr> + + +<%method preparse> +<%args> +$h + +<%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; + } +} + + + +<%method postquery> +<%args> +$h + +<%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').'.'; +} + + + diff --git a/yarrg/web/check_lossperleague b/yarrg/web/check_lossperleague new file mode 100644 index 0000000..aaeb5b0 --- /dev/null +++ b/yarrg/web/check_lossperleague @@ -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 + Copyright (C) 2009 Clare Boothby + + YARRG's client code etc. is covered by the ordinary GNU GPL (v3 or later). + The YARRG website is covered by the GNU Affero GPL v3 or later, which + basically means that every installation of the website will let you + download the source. + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU Affero General Public License as + published by the Free Software Foundation, either version 3 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Affero General Public License for more details. + + You should have received a copy of the GNU Affero General Public License + along with this program. If not, see . + + Yohoho and Puzzle Pirates are probably trademarks of Three Rings and + are used without permission. This program is not endorsed or + sponsored by Three Rings. + + + This Mason component simply defines how to interpret capacities. + + + +<%attr> + + +<%method preparse> +<%args> +$h + +<%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; +} + + + diff --git a/yarrg/web/lookup b/yarrg/web/lookup index 8fb3bb1..35b6ce7 100755 --- a/yarrg/web/lookup +++ b/yarrg/web/lookup @@ -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; } <&| 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 | diff --git a/yarrg/web/qtextstring b/yarrg/web/qtextstring index 84564df..639e9ab 100644 --- a/yarrg/web/qtextstring +++ b/yarrg/web/qtextstring @@ -41,62 +41,65 @@ $dbh $thingstring $emsgstore $perresult +$prefix => 'ts'; <%perl> my $stringval= $qa->{$thingstring}; $stringval='' if !defined $stringval; + +my $p= $prefix.'_'; <&| 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); content %> id="<% $thingstring %>" name="<% $thingstring %>" - onchange="ts_Needed();" onkeyup="ts_Later();" + onchange="<%$p%>Needed();" onkeyup="<%$p%>Later();" value="<% $stringval |h %>" >
-
 

+
 

<%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); } } diff --git a/yarrg/web/qtextstringcheck b/yarrg/web/qtextstringcheck index b2c1013..a489d8e 100755 --- a/yarrg/web/qtextstringcheck +++ b/yarrg/web/qtextstringcheck @@ -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); diff --git a/yarrg/web/query_route b/yarrg/web/query_route index 393e7a6..296c012 100644 --- a/yarrg/web/query_route +++ b/yarrg/web/query_route @@ -38,6 +38,8 @@ $quri $dbh $prselector $routestring => ''; +$capacitystring => ''; +$lossperleague => ''; $someresults $emsgokorprint @@ -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 +Advanced options - you may leave these blank: +

+ + +
+ +Vessel capacity: +<&| qtextstring, qa => $qa, dbh => $dbh, prefix => 'cs', + thingstring => 'capacitystring', emsgstore => \$emsg, + perresult => sub { + ($max_volume,$max_mass) = @_; + } + &> + size=30 + + + +  +  + + +Estimated loss per league: + +<&| qtextstring, qa => $qa, dbh => $dbh, prefix => 'll', + thingstring => 'lossperleague', emsgstore => \$emsg, + perresult => sub { ($lossperleaguepct)= @_; } + &> + size=10 + + +
+ % } 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 ---------- -% 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 &> % } diff --git a/yarrg/web/routetrade b/yarrg/web/routetrade index 4885782..9311f1a 100644 --- a/yarrg/web/routetrade +++ b/yarrg/web/routetrade @@ -38,11 +38,24 @@ $dbh @islandids @archipelagoes $qa +$max_mass +$max_volume +$lossperleaguepct <&| script &> da_pageload= Date.now(); +% if (defined $max_mass || defined $max_volume) { +WARNING - VESSEL CAPACITY LIMIT NOT YET IMPLEMENTED +

+% } +% if (defined $lossperleaguepct) { +WARNING - DEFINED LOSS PER LEAGUE NOT YET IMPLEMENTED +<% $lossperleaguepct |h %> +

+% } + <%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); +} @@ -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;

% 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( - + % if ($optimise) { @@ -499,8 +521,9 @@ $addcols->({ Total => 0, DoReverse => 1 }, qw( Collect Deliver Profit - Max + +Max % if ($optimise) { Planned % } @@ -516,10 +539,12 @@ $addcols->({ Total => 0, DoReverse => 1 }, qw( Qty Margin Unit -Dist Qty Capital Profit +Dist +Mass +Vol % if ($optimise) { Qty 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( % $iquery->execute($islandids[$i]); % my ($islandname) = $iquery->fetchrow_array(); -% my $this_dist= $distance->($islandids[$i-1],$islandids[$i]); -% $total_dist += $this_dist; % if (!$i) { Start at <% $islandname |h %> % } else { +% my $this_dist= $distance->($islandids[$i-1],$islandids[$i]); +% $total_dist += $this_dist; Sail to <% $islandname |h %> - <% $this_dist |h %> leagues % }