yarrg/_*.*
yarrg/OCEAN-*.db
yarrg/Writer.lock
+yarrg/DATA
+This licence applies to the general purpose ypp-sc-tools, the
+YARRG client code and code shared with the YARRG website.
+
+It DOES NOT apply to:
+
+ * The code for YARRG website, which is also Free Software
+ but covered by the Affero GPL - see COPYING.WEBSITE.
+
+ * master-info.txt, ocean-*.txt, which contain information about the
+ Yohoho Puzzle Pirates world. Insofar as this information is
+ Copyright by Three Rings (the company behind Puzzle Pirates)
+ I believe that our usage is Fair Dealing.
+
+ * The market data presented through the website. This is
+ a collection of facts and not subject to copyright.
+
+See the individual files' copyright notices for details.
+
+
GNU GENERAL PUBLIC LICENSE
Version 3, 29 June 2007
--- /dev/null
+This licence applies to the YARRG website, whose files can be found in:
+ yarrg/CommodsWeb.pm
+ yarrg/web/
+See the individual files' copyright notices for details.
+
+
+ GNU AFFERO GENERAL PUBLIC LICENSE
+ Version 3, 19 November 2007
+
+ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+ Preamble
+
+ The GNU Affero General Public License is a free, copyleft license for
+software and other kinds of works, specifically designed to ensure
+cooperation with the community in the case of network server software.
+
+ The licenses for most software and other practical works are designed
+to take away your freedom to share and change the works. By contrast,
+our General Public Licenses are intended to guarantee your freedom to
+share and change all versions of a program--to make sure it remains free
+software for all its users.
+
+ When we speak of free software, we are referring to freedom, not
+price. Our General Public Licenses are designed to make sure that you
+have the freedom to distribute copies of free software (and charge for
+them if you wish), that you receive source code or can get it if you
+want it, that you can change the software or use pieces of it in new
+free programs, and that you know you can do these things.
+
+ Developers that use our General Public Licenses protect your rights
+with two steps: (1) assert copyright on the software, and (2) offer
+you this License which gives you legal permission to copy, distribute
+and/or modify the software.
+
+ A secondary benefit of defending all users' freedom is that
+improvements made in alternate versions of the program, if they
+receive widespread use, become available for other developers to
+incorporate. Many developers of free software are heartened and
+encouraged by the resulting cooperation. However, in the case of
+software used on network servers, this result may fail to come about.
+The GNU General Public License permits making a modified version and
+letting the public access it on a server without ever releasing its
+source code to the public.
+
+ The GNU Affero General Public License is designed specifically to
+ensure that, in such cases, the modified source code becomes available
+to the community. It requires the operator of a network server to
+provide the source code of the modified version running there to the
+users of that server. Therefore, public use of a modified version, on
+a publicly accessible server, gives the public access to the source
+code of the modified version.
+
+ An older license, called the Affero General Public License and
+published by Affero, was designed to accomplish similar goals. This is
+a different license, not a version of the Affero GPL, but Affero has
+released a new version of the Affero GPL which permits relicensing under
+this license.
+
+ The precise terms and conditions for copying, distribution and
+modification follow.
+
+ TERMS AND CONDITIONS
+
+ 0. Definitions.
+
+ "This License" refers to version 3 of the GNU Affero General Public License.
+
+ "Copyright" also means copyright-like laws that apply to other kinds of
+works, such as semiconductor masks.
+
+ "The Program" refers to any copyrightable work licensed under this
+License. Each licensee is addressed as "you". "Licensees" and
+"recipients" may be individuals or organizations.
+
+ To "modify" a work means to copy from or adapt all or part of the work
+in a fashion requiring copyright permission, other than the making of an
+exact copy. The resulting work is called a "modified version" of the
+earlier work or a work "based on" the earlier work.
+
+ A "covered work" means either the unmodified Program or a work based
+on the Program.
+
+ To "propagate" a work means to do anything with it that, without
+permission, would make you directly or secondarily liable for
+infringement under applicable copyright law, except executing it on a
+computer or modifying a private copy. Propagation includes copying,
+distribution (with or without modification), making available to the
+public, and in some countries other activities as well.
+
+ To "convey" a work means any kind of propagation that enables other
+parties to make or receive copies. Mere interaction with a user through
+a computer network, with no transfer of a copy, is not conveying.
+
+ An interactive user interface displays "Appropriate Legal Notices"
+to the extent that it includes a convenient and prominently visible
+feature that (1) displays an appropriate copyright notice, and (2)
+tells the user that there is no warranty for the work (except to the
+extent that warranties are provided), that licensees may convey the
+work under this License, and how to view a copy of this License. If
+the interface presents a list of user commands or options, such as a
+menu, a prominent item in the list meets this criterion.
+
+ 1. Source Code.
+
+ The "source code" for a work means the preferred form of the work
+for making modifications to it. "Object code" means any non-source
+form of a work.
+
+ A "Standard Interface" means an interface that either is an official
+standard defined by a recognized standards body, or, in the case of
+interfaces specified for a particular programming language, one that
+is widely used among developers working in that language.
+
+ The "System Libraries" of an executable work include anything, other
+than the work as a whole, that (a) is included in the normal form of
+packaging a Major Component, but which is not part of that Major
+Component, and (b) serves only to enable use of the work with that
+Major Component, or to implement a Standard Interface for which an
+implementation is available to the public in source code form. A
+"Major Component", in this context, means a major essential component
+(kernel, window system, and so on) of the specific operating system
+(if any) on which the executable work runs, or a compiler used to
+produce the work, or an object code interpreter used to run it.
+
+ The "Corresponding Source" for a work in object code form means all
+the source code needed to generate, install, and (for an executable
+work) run the object code and to modify the work, including scripts to
+control those activities. However, it does not include the work's
+System Libraries, or general-purpose tools or generally available free
+programs which are used unmodified in performing those activities but
+which are not part of the work. For example, Corresponding Source
+includes interface definition files associated with source files for
+the work, and the source code for shared libraries and dynamically
+linked subprograms that the work is specifically designed to require,
+such as by intimate data communication or control flow between those
+subprograms and other parts of the work.
+
+ The Corresponding Source need not include anything that users
+can regenerate automatically from other parts of the Corresponding
+Source.
+
+ The Corresponding Source for a work in source code form is that
+same work.
+
+ 2. Basic Permissions.
+
+ All rights granted under this License are granted for the term of
+copyright on the Program, and are irrevocable provided the stated
+conditions are met. This License explicitly affirms your unlimited
+permission to run the unmodified Program. The output from running a
+covered work is covered by this License only if the output, given its
+content, constitutes a covered work. This License acknowledges your
+rights of fair use or other equivalent, as provided by copyright law.
+
+ You may make, run and propagate covered works that you do not
+convey, without conditions so long as your license otherwise remains
+in force. You may convey covered works to others for the sole purpose
+of having them make modifications exclusively for you, or provide you
+with facilities for running those works, provided that you comply with
+the terms of this License in conveying all material for which you do
+not control copyright. Those thus making or running the covered works
+for you must do so exclusively on your behalf, under your direction
+and control, on terms that prohibit them from making any copies of
+your copyrighted material outside their relationship with you.
+
+ Conveying under any other circumstances is permitted solely under
+the conditions stated below. Sublicensing is not allowed; section 10
+makes it unnecessary.
+
+ 3. Protecting Users' Legal Rights From Anti-Circumvention Law.
+
+ No covered work shall be deemed part of an effective technological
+measure under any applicable law fulfilling obligations under article
+11 of the WIPO copyright treaty adopted on 20 December 1996, or
+similar laws prohibiting or restricting circumvention of such
+measures.
+
+ When you convey a covered work, you waive any legal power to forbid
+circumvention of technological measures to the extent such circumvention
+is effected by exercising rights under this License with respect to
+the covered work, and you disclaim any intention to limit operation or
+modification of the work as a means of enforcing, against the work's
+users, your or third parties' legal rights to forbid circumvention of
+technological measures.
+
+ 4. Conveying Verbatim Copies.
+
+ You may convey verbatim copies of the Program's source code as you
+receive it, in any medium, provided that you conspicuously and
+appropriately publish on each copy an appropriate copyright notice;
+keep intact all notices stating that this License and any
+non-permissive terms added in accord with section 7 apply to the code;
+keep intact all notices of the absence of any warranty; and give all
+recipients a copy of this License along with the Program.
+
+ You may charge any price or no price for each copy that you convey,
+and you may offer support or warranty protection for a fee.
+
+ 5. Conveying Modified Source Versions.
+
+ You may convey a work based on the Program, or the modifications to
+produce it from the Program, in the form of source code under the
+terms of section 4, provided that you also meet all of these conditions:
+
+ a) The work must carry prominent notices stating that you modified
+ it, and giving a relevant date.
+
+ b) The work must carry prominent notices stating that it is
+ released under this License and any conditions added under section
+ 7. This requirement modifies the requirement in section 4 to
+ "keep intact all notices".
+
+ c) You must license the entire work, as a whole, under this
+ License to anyone who comes into possession of a copy. This
+ License will therefore apply, along with any applicable section 7
+ additional terms, to the whole of the work, and all its parts,
+ regardless of how they are packaged. This License gives no
+ permission to license the work in any other way, but it does not
+ invalidate such permission if you have separately received it.
+
+ d) If the work has interactive user interfaces, each must display
+ Appropriate Legal Notices; however, if the Program has interactive
+ interfaces that do not display Appropriate Legal Notices, your
+ work need not make them do so.
+
+ A compilation of a covered work with other separate and independent
+works, which are not by their nature extensions of the covered work,
+and which are not combined with it such as to form a larger program,
+in or on a volume of a storage or distribution medium, is called an
+"aggregate" if the compilation and its resulting copyright are not
+used to limit the access or legal rights of the compilation's users
+beyond what the individual works permit. Inclusion of a covered work
+in an aggregate does not cause this License to apply to the other
+parts of the aggregate.
+
+ 6. Conveying Non-Source Forms.
+
+ You may convey a covered work in object code form under the terms
+of sections 4 and 5, provided that you also convey the
+machine-readable Corresponding Source under the terms of this License,
+in one of these ways:
+
+ a) Convey the object code in, or embodied in, a physical product
+ (including a physical distribution medium), accompanied by the
+ Corresponding Source fixed on a durable physical medium
+ customarily used for software interchange.
+
+ b) Convey the object code in, or embodied in, a physical product
+ (including a physical distribution medium), accompanied by a
+ written offer, valid for at least three years and valid for as
+ long as you offer spare parts or customer support for that product
+ model, to give anyone who possesses the object code either (1) a
+ copy of the Corresponding Source for all the software in the
+ product that is covered by this License, on a durable physical
+ medium customarily used for software interchange, for a price no
+ more than your reasonable cost of physically performing this
+ conveying of source, or (2) access to copy the
+ Corresponding Source from a network server at no charge.
+
+ c) Convey individual copies of the object code with a copy of the
+ written offer to provide the Corresponding Source. This
+ alternative is allowed only occasionally and noncommercially, and
+ only if you received the object code with such an offer, in accord
+ with subsection 6b.
+
+ d) Convey the object code by offering access from a designated
+ place (gratis or for a charge), and offer equivalent access to the
+ Corresponding Source in the same way through the same place at no
+ further charge. You need not require recipients to copy the
+ Corresponding Source along with the object code. If the place to
+ copy the object code is a network server, the Corresponding Source
+ may be on a different server (operated by you or a third party)
+ that supports equivalent copying facilities, provided you maintain
+ clear directions next to the object code saying where to find the
+ Corresponding Source. Regardless of what server hosts the
+ Corresponding Source, you remain obligated to ensure that it is
+ available for as long as needed to satisfy these requirements.
+
+ e) Convey the object code using peer-to-peer transmission, provided
+ you inform other peers where the object code and Corresponding
+ Source of the work are being offered to the general public at no
+ charge under subsection 6d.
+
+ A separable portion of the object code, whose source code is excluded
+from the Corresponding Source as a System Library, need not be
+included in conveying the object code work.
+
+ A "User Product" is either (1) a "consumer product", which means any
+tangible personal property which is normally used for personal, family,
+or household purposes, or (2) anything designed or sold for incorporation
+into a dwelling. In determining whether a product is a consumer product,
+doubtful cases shall be resolved in favor of coverage. For a particular
+product received by a particular user, "normally used" refers to a
+typical or common use of that class of product, regardless of the status
+of the particular user or of the way in which the particular user
+actually uses, or expects or is expected to use, the product. A product
+is a consumer product regardless of whether the product has substantial
+commercial, industrial or non-consumer uses, unless such uses represent
+the only significant mode of use of the product.
+
+ "Installation Information" for a User Product means any methods,
+procedures, authorization keys, or other information required to install
+and execute modified versions of a covered work in that User Product from
+a modified version of its Corresponding Source. The information must
+suffice to ensure that the continued functioning of the modified object
+code is in no case prevented or interfered with solely because
+modification has been made.
+
+ If you convey an object code work under this section in, or with, or
+specifically for use in, a User Product, and the conveying occurs as
+part of a transaction in which the right of possession and use of the
+User Product is transferred to the recipient in perpetuity or for a
+fixed term (regardless of how the transaction is characterized), the
+Corresponding Source conveyed under this section must be accompanied
+by the Installation Information. But this requirement does not apply
+if neither you nor any third party retains the ability to install
+modified object code on the User Product (for example, the work has
+been installed in ROM).
+
+ The requirement to provide Installation Information does not include a
+requirement to continue to provide support service, warranty, or updates
+for a work that has been modified or installed by the recipient, or for
+the User Product in which it has been modified or installed. Access to a
+network may be denied when the modification itself materially and
+adversely affects the operation of the network or violates the rules and
+protocols for communication across the network.
+
+ Corresponding Source conveyed, and Installation Information provided,
+in accord with this section must be in a format that is publicly
+documented (and with an implementation available to the public in
+source code form), and must require no special password or key for
+unpacking, reading or copying.
+
+ 7. Additional Terms.
+
+ "Additional permissions" are terms that supplement the terms of this
+License by making exceptions from one or more of its conditions.
+Additional permissions that are applicable to the entire Program shall
+be treated as though they were included in this License, to the extent
+that they are valid under applicable law. If additional permissions
+apply only to part of the Program, that part may be used separately
+under those permissions, but the entire Program remains governed by
+this License without regard to the additional permissions.
+
+ When you convey a copy of a covered work, you may at your option
+remove any additional permissions from that copy, or from any part of
+it. (Additional permissions may be written to require their own
+removal in certain cases when you modify the work.) You may place
+additional permissions on material, added by you to a covered work,
+for which you have or can give appropriate copyright permission.
+
+ Notwithstanding any other provision of this License, for material you
+add to a covered work, you may (if authorized by the copyright holders of
+that material) supplement the terms of this License with terms:
+
+ a) Disclaiming warranty or limiting liability differently from the
+ terms of sections 15 and 16 of this License; or
+
+ b) Requiring preservation of specified reasonable legal notices or
+ author attributions in that material or in the Appropriate Legal
+ Notices displayed by works containing it; or
+
+ c) Prohibiting misrepresentation of the origin of that material, or
+ requiring that modified versions of such material be marked in
+ reasonable ways as different from the original version; or
+
+ d) Limiting the use for publicity purposes of names of licensors or
+ authors of the material; or
+
+ e) Declining to grant rights under trademark law for use of some
+ trade names, trademarks, or service marks; or
+
+ f) Requiring indemnification of licensors and authors of that
+ material by anyone who conveys the material (or modified versions of
+ it) with contractual assumptions of liability to the recipient, for
+ any liability that these contractual assumptions directly impose on
+ those licensors and authors.
+
+ All other non-permissive additional terms are considered "further
+restrictions" within the meaning of section 10. If the Program as you
+received it, or any part of it, contains a notice stating that it is
+governed by this License along with a term that is a further
+restriction, you may remove that term. If a license document contains
+a further restriction but permits relicensing or conveying under this
+License, you may add to a covered work material governed by the terms
+of that license document, provided that the further restriction does
+not survive such relicensing or conveying.
+
+ If you add terms to a covered work in accord with this section, you
+must place, in the relevant source files, a statement of the
+additional terms that apply to those files, or a notice indicating
+where to find the applicable terms.
+
+ Additional terms, permissive or non-permissive, may be stated in the
+form of a separately written license, or stated as exceptions;
+the above requirements apply either way.
+
+ 8. Termination.
+
+ You may not propagate or modify a covered work except as expressly
+provided under this License. Any attempt otherwise to propagate or
+modify it is void, and will automatically terminate your rights under
+this License (including any patent licenses granted under the third
+paragraph of section 11).
+
+ However, if you cease all violation of this License, then your
+license from a particular copyright holder is reinstated (a)
+provisionally, unless and until the copyright holder explicitly and
+finally terminates your license, and (b) permanently, if the copyright
+holder fails to notify you of the violation by some reasonable means
+prior to 60 days after the cessation.
+
+ Moreover, your license from a particular copyright holder is
+reinstated permanently if the copyright holder notifies you of the
+violation by some reasonable means, this is the first time you have
+received notice of violation of this License (for any work) from that
+copyright holder, and you cure the violation prior to 30 days after
+your receipt of the notice.
+
+ Termination of your rights under this section does not terminate the
+licenses of parties who have received copies or rights from you under
+this License. If your rights have been terminated and not permanently
+reinstated, you do not qualify to receive new licenses for the same
+material under section 10.
+
+ 9. Acceptance Not Required for Having Copies.
+
+ You are not required to accept this License in order to receive or
+run a copy of the Program. Ancillary propagation of a covered work
+occurring solely as a consequence of using peer-to-peer transmission
+to receive a copy likewise does not require acceptance. However,
+nothing other than this License grants you permission to propagate or
+modify any covered work. These actions infringe copyright if you do
+not accept this License. Therefore, by modifying or propagating a
+covered work, you indicate your acceptance of this License to do so.
+
+ 10. Automatic Licensing of Downstream Recipients.
+
+ Each time you convey a covered work, the recipient automatically
+receives a license from the original licensors, to run, modify and
+propagate that work, subject to this License. You are not responsible
+for enforcing compliance by third parties with this License.
+
+ An "entity transaction" is a transaction transferring control of an
+organization, or substantially all assets of one, or subdividing an
+organization, or merging organizations. If propagation of a covered
+work results from an entity transaction, each party to that
+transaction who receives a copy of the work also receives whatever
+licenses to the work the party's predecessor in interest had or could
+give under the previous paragraph, plus a right to possession of the
+Corresponding Source of the work from the predecessor in interest, if
+the predecessor has it or can get it with reasonable efforts.
+
+ You may not impose any further restrictions on the exercise of the
+rights granted or affirmed under this License. For example, you may
+not impose a license fee, royalty, or other charge for exercise of
+rights granted under this License, and you may not initiate litigation
+(including a cross-claim or counterclaim in a lawsuit) alleging that
+any patent claim is infringed by making, using, selling, offering for
+sale, or importing the Program or any portion of it.
+
+ 11. Patents.
+
+ A "contributor" is a copyright holder who authorizes use under this
+License of the Program or a work on which the Program is based. The
+work thus licensed is called the contributor's "contributor version".
+
+ A contributor's "essential patent claims" are all patent claims
+owned or controlled by the contributor, whether already acquired or
+hereafter acquired, that would be infringed by some manner, permitted
+by this License, of making, using, or selling its contributor version,
+but do not include claims that would be infringed only as a
+consequence of further modification of the contributor version. For
+purposes of this definition, "control" includes the right to grant
+patent sublicenses in a manner consistent with the requirements of
+this License.
+
+ Each contributor grants you a non-exclusive, worldwide, royalty-free
+patent license under the contributor's essential patent claims, to
+make, use, sell, offer for sale, import and otherwise run, modify and
+propagate the contents of its contributor version.
+
+ In the following three paragraphs, a "patent license" is any express
+agreement or commitment, however denominated, not to enforce a patent
+(such as an express permission to practice a patent or covenant not to
+sue for patent infringement). To "grant" such a patent license to a
+party means to make such an agreement or commitment not to enforce a
+patent against the party.
+
+ If you convey a covered work, knowingly relying on a patent license,
+and the Corresponding Source of the work is not available for anyone
+to copy, free of charge and under the terms of this License, through a
+publicly available network server or other readily accessible means,
+then you must either (1) cause the Corresponding Source to be so
+available, or (2) arrange to deprive yourself of the benefit of the
+patent license for this particular work, or (3) arrange, in a manner
+consistent with the requirements of this License, to extend the patent
+license to downstream recipients. "Knowingly relying" means you have
+actual knowledge that, but for the patent license, your conveying the
+covered work in a country, or your recipient's use of the covered work
+in a country, would infringe one or more identifiable patents in that
+country that you have reason to believe are valid.
+
+ If, pursuant to or in connection with a single transaction or
+arrangement, you convey, or propagate by procuring conveyance of, a
+covered work, and grant a patent license to some of the parties
+receiving the covered work authorizing them to use, propagate, modify
+or convey a specific copy of the covered work, then the patent license
+you grant is automatically extended to all recipients of the covered
+work and works based on it.
+
+ A patent license is "discriminatory" if it does not include within
+the scope of its coverage, prohibits the exercise of, or is
+conditioned on the non-exercise of one or more of the rights that are
+specifically granted under this License. You may not convey a covered
+work if you are a party to an arrangement with a third party that is
+in the business of distributing software, under which you make payment
+to the third party based on the extent of your activity of conveying
+the work, and under which the third party grants, to any of the
+parties who would receive the covered work from you, a discriminatory
+patent license (a) in connection with copies of the covered work
+conveyed by you (or copies made from those copies), or (b) primarily
+for and in connection with specific products or compilations that
+contain the covered work, unless you entered into that arrangement,
+or that patent license was granted, prior to 28 March 2007.
+
+ Nothing in this License shall be construed as excluding or limiting
+any implied license or other defenses to infringement that may
+otherwise be available to you under applicable patent law.
+
+ 12. No Surrender of Others' Freedom.
+
+ If conditions are imposed on you (whether by court order, agreement or
+otherwise) that contradict the conditions of this License, they do not
+excuse you from the conditions of this License. If you cannot convey a
+covered work so as to satisfy simultaneously your obligations under this
+License and any other pertinent obligations, then as a consequence you may
+not convey it at all. For example, if you agree to terms that obligate you
+to collect a royalty for further conveying from those to whom you convey
+the Program, the only way you could satisfy both those terms and this
+License would be to refrain entirely from conveying the Program.
+
+ 13. Remote Network Interaction; Use with the GNU General Public License.
+
+ Notwithstanding any other provision of this License, if you modify the
+Program, your modified version must prominently offer all users
+interacting with it remotely through a computer network (if your version
+supports such interaction) an opportunity to receive the Corresponding
+Source of your version by providing access to the Corresponding Source
+from a network server at no charge, through some standard or customary
+means of facilitating copying of software. This Corresponding Source
+shall include the Corresponding Source for any work covered by version 3
+of the GNU General Public License that is incorporated pursuant to the
+following paragraph.
+
+ Notwithstanding any other provision of this License, you have
+permission to link or combine any covered work with a work licensed
+under version 3 of the GNU General Public License into a single
+combined work, and to convey the resulting work. The terms of this
+License will continue to apply to the part which is the covered work,
+but the work with which it is combined will remain governed by version
+3 of the GNU General Public License.
+
+ 14. Revised Versions of this License.
+
+ The Free Software Foundation may publish revised and/or new versions of
+the GNU Affero General Public License from time to time. Such new versions
+will be similar in spirit to the present version, but may differ in detail to
+address new problems or concerns.
+
+ Each version is given a distinguishing version number. If the
+Program specifies that a certain numbered version of the GNU Affero General
+Public License "or any later version" applies to it, you have the
+option of following the terms and conditions either of that numbered
+version or of any later version published by the Free Software
+Foundation. If the Program does not specify a version number of the
+GNU Affero General Public License, you may choose any version ever published
+by the Free Software Foundation.
+
+ If the Program specifies that a proxy can decide which future
+versions of the GNU Affero General Public License can be used, that proxy's
+public statement of acceptance of a version permanently authorizes you
+to choose that version for the Program.
+
+ Later license versions may give you additional or different
+permissions. However, no additional obligations are imposed on any
+author or copyright holder as a result of your choosing to follow a
+later version.
+
+ 15. Disclaimer of Warranty.
+
+ THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY
+APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT
+HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY
+OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,
+THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM
+IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF
+ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
+
+ 16. Limitation of Liability.
+
+ IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS
+THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY
+GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE
+USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF
+DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD
+PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),
+EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
+SUCH DAMAGES.
+
+ 17. Interpretation of Sections 15 and 16.
+
+ If the disclaimer of warranty and limitation of liability provided
+above cannot be given local legal effect according to their terms,
+reviewing courts shall apply local law that most closely approximates
+an absolute waiver of all civil liability in connection with the
+Program, unless a warranty or assumption of liability accompanies a
+copy of the Program in return for a fee.
+
+ END OF TERMS AND CONDITIONS
+
+ How to Apply These Terms to Your New Programs
+
+ If you develop a new program, and you want it to be of the greatest
+possible use to the public, the best way to achieve this is to make it
+free software which everyone can redistribute and change under these terms.
+
+ To do so, attach the following notices to the program. It is safest
+to attach them to the start of each source file to most effectively
+state the exclusion of warranty; and each file should have at least
+the "copyright" line and a pointer to where the full notice is found.
+
+ <one line to give the program's name and a brief idea of what it does.>
+ Copyright (C) <year> <name of author>
+
+ 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/>.
+
+Also add information on how to contact you by electronic and paper mail.
+
+ If your software can interact with users remotely through a computer
+network, you should also make sure that it provides a way for users to
+get its source. For example, if your program is a web application, its
+interface could display a "Source" link that leads users to an archive
+of the code. There are many ways you could offer source, and different
+solutions will be better for different programs; see section 13 for the
+specific requirements.
+
+ You should also get your employer (if you work as a programmer) or school,
+if any, to sign a "copyright disclaimer" for the program, if necessary.
+For more information on this, and how to apply and follow the GNU AGPL, see
+<http://www.gnu.org/licenses/>.
&pipethrough_prep &pipethrough_run
&pipethrough_run_along &pipethrough_run_finish
&pipethrough_run_gzip
- &cgipostform &yarrgpostform &cgi_get_caller);
+ &cgipostform &yarrgpostform &cgi_get_caller
+ &set_ctype_utf8 $masterinfoversion);
%EXPORT_TAGS = ( );
@EXPORT_OK = qw();
}
+our $masterinfoversion= 2; # version we understand
+
our %oceans; # eg $oceans{'Midnight'}{'Ruby'}{'Eta Island'}= $sources;
-our %commods; # eg $commods{'Fine black cloth'}= $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
# $sources = 's[l]b';
# 's' = Special Circumstances; 'l' = local ; B = with Bleach
+our %commods;
+# eg $commods{'Fine black cloth'}{Srcs}= $sources;
+# eg $commods{'Fine black cloth'}{Mass}= 700 [g]
+# eg $commods{'Fine black cloth'}{Volume}= 1000 [ml]
+
our (%pctb_commodmap,@pctb_commodmap);
my %colours; # eg $colours{'c'}{'black'}= $sources
-my @rawcm; # eg $rawcm[0]='fine rum'; $rawcm[1]='fine %c cloth'
+my (@rawcm, @nocm); # eg $rawcm[0]='fine rum'; $rawcm[1]='fine %c cloth'
+
+# IMPORTANT
+# when extending the format of source-info in a non-backward
+# compatible way, be sure to update update-master-info too.
sub parse_info1 ($$) {
my ($mmfn,$src)= @_;
@ctx= (sub { $colours{$colourkind}{lc $_} .= $src; });
} elsif (m/^commods$/) {
@ctx= (sub { push @rawcm, lc $_; });
+ } elsif (m/^nocommods$/) {
+ @ctx= (sub { push @nocm, lc $_; });
} elsif (m/^ocean (\w+)$/) {
my $ocean= $1;
+ keys %{ $oceans{$ocean} };
@ctx= (sub {
$ocean or die; # ref to $ocean needed to work
# around a perl bug
my $arch= $_;
+ keys %{ $oceans{$ocean}{$arch} };
$ctx[1]= sub {
$oceans{$ocean}{$arch}{$_} .= $src;
};
$ca= sub {
my ($s,$ss) = @_;
#print "ca($s)\n";
- if ($s !~ m/\%(\w+)/) { $commods{ucfirst $s} .= $ss; return; }
+ if ($s !~ m/\%(\w+)/) {
+ my ($name, $props) = $s =~
+ /^(\S[^\t]*\S)(?:\t+(\S[^\t]*\S))?$/
+ or die "bad commodspec $s";
+ return if grep { $name eq $_ } @nocm;
+ my $ucname= ucfirst $name;
+ $commods{$ucname}{Srcs} .= $ss;
+ my $c= $commods{$ucname};
+ $c->{Volume}= 1000;
+ foreach my $prop (defined $props ? split /\s+/, $props : ()) {
+ if ($prop =~ m/^([1-9]\d*)(k?)g$/) {
+ $c->{Mass}= $1 * ($2 ? 1000 : 1);
+ } elsif ($prop =~m/^([1-9]\d*)l$/) {
+ $c->{Volume}= $1 * 1000;
+ } else {
+ die "unknown property $prop for $ucname";
+ }
+ }
+ return;
+ }
die "unknown $&" unless defined $colours{$1};
- foreach my $c (keys %{ $colours{$1} }) {
- &$ca($`.$c.$', $ss .'%'. $colours{$1}{$c});
+ my ($lhs,$pctlet,$rhs)= ($`,$1,$');
+ foreach my $c (keys %{ $colours{$pctlet} }) {
+ &$ca($lhs.$c.$rhs, $ss .'%'. $colours{$pctlet}{$c});
}
};
foreach (@rawcm) { &$ca($_,$src); }
sub parse_info_clientside () {
my $yarrg= $ENV{'YPPSC_YARRG_DICT_UPDATE'};
return unless $yarrg;
- my $master= fetch_with_rsync('info');
+ my $master= fetch_with_rsync("info-$masterinfoversion");
parse_info1($master,'s');
my $local= '_local-info.txt';
if (stat $local) {
}
sub parse_info_serverside () {
- parse_info1('master-info.txt','s');
+ parse_info1('source-info.txt','s');
}
sub parse_info_serverside_ocean ($) {
my ($oceanname) = @_;
die "unknown ocean $oceanname ?" unless exists $oceans{$oceanname};
- parse_info1("ocean-".(lc $oceanname).".txt",'s');
+ parse_info1("_ocean-".(lc $oceanname).".txt",'s');
}
sub parse_pctb_commodmap () {
undef %pctb_commodmap;
- foreach my $commod (keys %commods) { $commods{$commod} =~ s/b//; }
+ foreach my $commod (keys %commods) { $commods{$commod}{Srcs} =~ s/b//; }
- my $c= new IO::File '_commodmap.tsv' or die $!;
+ my $c= new IO::File '_commodmap.tsv';
if (!$c) { $!==&ENOENT or die $!; return 0; }
while (<$c>) {
m/^(\S.*\S)\t(\d+)\n$/ or die "$_";
die if defined $pctb_commodmap{$1}; $pctb_commodmap{$1}= $2;
die if defined $pctb_commodmap[$2]; $pctb_commodmap[$2]= $1;
- $commods{$1} .= 'b';
+ $commods{$1}{Srcs} .= 'b';
}
$c->error and die $!;
close $c or die $!;
sub get_our_version ($$) {
my ($aref,$prefix) = @_;
$aref->{"${prefix}name"}= 'ypp-sc-tools yarrg';
- $aref->{"${prefix}fixes"}= 'lastpage';
+ $aref->{"${prefix}fixes"}= 'lastpage checkpager';
- my $version= `git-describe --tags HEAD`; $? and die $?;
+ my $version= `git-describe --tags HEAD || echo 0unknown`; $? and die $?;
chomp($version);
$aref->{"${prefix}version"}= $version;
return $aref;
sub pipethrough_run_along ($$$@) {
my ($tf, $childprep, $cmd, @a) = @_;
+ $tf->error and die $!;
$tf->flush or die $!;
$tf->seek(0,0) or die $!;
my $fh= new IO::File;
return $';
} else {
my $resp= $ua->request($req);
- die $resp->status_line unless $resp->is_success;
+ die $resp->status_line."\n".$resp->content."\n "
+ unless $resp->is_success;
return $resp->content();
}
}
return $caller;
}
+sub set_ctype_utf8 () {
+ setlocale(LC_CTYPE, "en.UTF-8");
+}
+
1;
$VERSION = 1.00;
@ISA = qw(Exporter);
@EXPORT = qw(&db_setocean &db_writer &db_connect $dbh
- &db_filename &db_doall &db_onconflict);
+ &db_filename &db_doall &db_onconflict
+ &dbr_filename &dbr_connect);
%EXPORT_TAGS = ( );
@EXPORT_OK = qw();
}
+sub dbr_filename ($$) {
+ my ($datadir,$oceanname) = @_;
+ return "$datadir/OCEAN-$oceanname.db";
+}
+sub dbr_connect ($$) {
+ my ($datadir,$ocean) = @_;
+ return connect_core(dbr_filename($datadir,$ocean));
+}
+
+sub connect_core ($) {
+ my ($fn)= @_;
+ my $h= DBI->connect("dbi:SQLite:$fn",'','',
+ { AutoCommit=>0,
+ RaiseError=>1, ShowErrorStatement=>1,
+ unicode=>1 })
+ or die "$fn $DBI::errstr ?";
+ return $h;
+ # default timeout is 30s which is plenty
+}
+
our $dbfn;
our $dbh;
sub db_setocean ($) {
my ($oceanname) = @_;
- $dbfn= "OCEAN-$oceanname.db";
+ $dbfn= dbr_filename('.',$oceanname);
}
sub db_filename () {
return $dbfn;
}
sub db_connect () {
- $dbh= DBI->connect("dbi:SQLite:$dbfn",'','',
- { AutoCommit=>0,
- RaiseError=>1, ShowErrorStatement=>1,
- unicode=>1 })
- or die "$dbfn $DBI::errstr ?";
- # default timeout is 30s which is plenty
+ $dbh= connect_core($dbfn);
}
sub db_doall ($) {
--- /dev/null
+# 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 Perl module is used by the Mason scripts in yarrg/web/.
+# We look for a symlink DATA to the actual data to use, so that
+# the data uploader and website displayer can use different code.
+
+package CommodsWeb;
+
+use strict;
+use warnings;
+
+use DBI;
+use POSIX;
+use JSON;
+
+use Commods;
+use CommodsDatabase;
+
+BEGIN {
+ use Exporter ();
+ our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
+ $VERSION = 1.00;
+ @ISA = qw(Exporter);
+ @EXPORT = qw(&dbw_connect &ocean_list &sourcebasedir
+ &to_json_shim &to_json_protecttags
+ &set_ctype_utf8
+ &prettyprint_age &meta_prettyprint_age);
+ %EXPORT_TAGS = ( );
+
+ @EXPORT_OK = qw();
+}
+
+sub dotperllibdir () {
+ my $dir;
+
+ for my $dir (@INC) {
+ if ($dir =~ m/\.perl-lib$/) {
+ return $dir;
+ }
+ }
+ die "no appropriate dotperllib dir in @INC";
+}
+
+sub sourcebasedir () {
+ return dotperllibdir().'/..';
+}
+
+sub datadir () {
+ my $edir= $ENV{'YARRG_DATA_DIR'};
+ return $edir if defined $edir;
+ my $dir= dotperllibdir();
+ if (stat "$dir/DATA") {
+ return "$dir/DATA";
+ } elsif ($!==&ENOENT) {
+ return "$dir";
+ } else {
+ die "stat $dir/DATA $!";
+ }
+ return '.';
+}
+
+my @ocean_list;
+
+sub ocean_list () {
+ my $datadir= datadir();
+ if (!@ocean_list) {
+ my $fn= "$datadir/source-info.txt";
+ my $f= new IO::File $fn or die "$fn $!";
+ my @r;
+ while (<$f>) {
+ next unless m/^ocean\s+(\S.*\S)\s*$/;
+ push @r, $1;
+ }
+ $f->error and die $!;
+ close $fn;
+ @ocean_list= @r;
+ }
+ return @ocean_list;
+}
+
+sub dbw_connect ($) {
+ my ($ocean) = @_;
+ die "unknown ocean $ocean ?"
+ unless grep { $_ eq $ocean } ocean_list();
+ return dbr_connect(datadir(), $ocean);
+}
+
+sub to_json_shim ($) {
+ my ($obj) = @_;
+ # In JSON.pm 2.x, jsonToObj prints a warning to stderr which
+ # our callers don't like at all.
+ if ($JSON::VERSION >= 2.0) {
+ return to_json($obj);
+ } else {
+ return objToJson($obj);
+ }
+}
+
+sub to_json_protecttags ($) {
+ my ($v) = @_;
+ my $j= to_json_shim($v);
+ $j =~ s,/,\\/,g;
+ return $j;
+}
+
+sub meta_prettyprint_age ($$$) {
+ my ($age,$floor,$plus) = @_;
+ return <<END;
+ $age < 60 ? 'less than a minute' :
+ $age < 60*2 ? '1 minute' :
+ $age < 3600*2 ? $floor ($age/60) $plus' minutes' :
+ $age < 86400*2 ? $floor ($age/3600) $plus ' hours' :
+ $floor ($age/86400) $plus ' days';
+END
+};
+
+BEGIN { eval '
+ sub prettyprint_age ($) {
+ my ($age) = @_;
+ '.meta_prettyprint_age('$age','floor','.').'
+ };
+ 1;
+' or die "$@";
+}
+
+
+1;
See README.privacy for full details.
-Authorship and copyright
-------------------------
+Disclaimers, authorship and copyright
+-------------------------------------
The PCTB server is a project of Joel Lord and various others.
Special Circumstances (on the Midnight Ocean) and of the Sinister
Greenend Organisation.
+PCTB and YARRG are both completely unofficial and Three Rings, the
+operators of Yohoho Puzzle Pirates, have nothing to do with either of
+them. Please refer queries to us, not to Three Rings. If you want to
+reuse the code here to do substantially novel things, you should ask
+Three Rings for permission (for example, by petitioning an Ocean
+Master).
+
This yarrg screenscraper and upload client was written entirely from
-scratch by me, Ian Jackson, with assistance from Stephen Early. It is
-part of ypp-sc-tools, a set of third-party tools for assisting players
-of Yohoho Puzzle Pirates.
+scratch by me, Ian Jackson, with assistance from Stephen Early and
+Clare Boothby. It is part of ypp-sc-tools, a set of third-party tools
+for assisting players of Yohoho Puzzle Pirates.
-ypp-sc-tools is
+ypp-sc-tools and YARRG are
Copyright (C) 2009 Ian Jackson <ijackson@chiark.greenend.org.uk>
-Copyright (C) 2009 Stephen Early
+Copyright (C) 2009 Clare Boothby
This program is free software: you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation, either version 3 of the License, or
-(at your option) any later version.
+it under the terms of
+ (a) for the website code, the GNU Affero General Public License and
+ (b) for the rest of the code, GNU General Public License
+as published by the Free Software Foundation, either version 3 of
+each applicable 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 General Public License for more details.
-You should have received a copy of the GNU General Public License
-along with this program. If not, see <http://www.gnu.org/licenses/>.
+You should have received a copy of the GNU General Public License and
+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.
+are used without permission. Once again, this program is not endorsed
+or sponsored by Three Rings.
The character and UI images copied from the YPP client, and submitted
double-check what you're doing before overriding the uploader by
telling it to ignore an unrecognised commodity.
+ * _master-info*.txt _local-info.txt
+
+ Database of valid commodities and islands/oceans for use when
+ uploading to YARRG.
+
* _master-reject.txt _local-reject.txt
Dictionary of regexps which, when the OCR appears to match, we
-more flexible installation arrangements
+UPLOADER
+--------
+
+ detect all unexpected mouse movements
+
+ more flexible installation arrangements
+
+ W windows uploader
+
+DATABASE/DICTIONARY MANAGER
+---------------------------
+
+ commodity mass/volume in live database
+ eliminate black dye from live database
+
+ when update rejected print better error message including
+ broken commodity name
+
+ notice commodities deleted from source-info and warn about them
+
+ support Opal and Jade (currently there are some unicode problems)
+
+WEBSITE
+-------
+
+ multi-visit routes / circular routes
+
+ adjustable potential cost of losses (rather than fixed
+ 1e-BIG per league)
+ use power formula (compound interest)
+ suggest 0.5%
+
+ 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
use Commods;
use CommodsDatabase;
-setlocale(LC_CTYPE, "en_GB.UTF-8");
+set_ctype_utf8();
my $parser= new MIME::Parser;
our $entity;
$islandid, $mid,
map { $md{$_} } (qw(timestamp clientspec serverspec)));
- my (%sth, %sub_cs, %cache_cs, %sth_insert);
+ my (%sth, %sub_cs, %cache_cs, %sth_insert, %sth_lookup);
$sth_insert{'stall'}= $dbh->prepare(
"INSERT OR IGNORE
INTO stalls
(islandid, stallname) VALUES ($islandid, ?)
");
- $sth_insert{'commods'}= $dbh->prepare(
+ $sth_lookup{'stall'}= $dbh->prepare(
+ "SELECT stallid FROM stalls
+ WHERE islandid == $islandid AND stallname == ?
+ ");
+ $sth_insert{'commod'}= $dbh->prepare(
"INSERT OR IGNORE
INTO commods
(commodname) VALUES (?)
");
+ $sth_lookup{'commod'}= $dbh->prepare(
+ "SELECT commodid FROM commods
+ WHERE commodname == ?
+ ");
foreach my $cs (qw(stall commod)) {
- my $sth_lookup= $dbh->prepare(
- "SELECT ${cs}id FROM ${cs}s WHERE ${cs}name == ?;
- ");
$sub_cs{$cs}= sub {
my ($name)= @_;
my $r= $cache_cs{$cs}{$name};
return $r if defined $r;
- $sth_lookup->execute($name) or die;
- ($r)= $sth_lookup->fetchrow_array();
+ $sth_lookup{$cs}->execute($name) or die;
+ ($r)= $sth_lookup{$cs}->fetchrow_array();
if (!defined $r) {
$sth_insert{$cs}->execute($name);
- $sth_lookup->execute($name) or die;
- ($r)= $sth_lookup->fetchrow_array();
+ $sth_lookup{$cs}->execute($name) or die;
+ ($r)= $sth_lookup{$cs}->fetchrow_array();
die unless defined $r;
}
$cache_cs{$cs}{$name}= $r;
use CGI qw/:standard -private_tempfiles/;
-setlocale(LC_CTYPE, "en_GB.UTF-8");
+set_ctype_utf8();
our $now= time; defined $now or die $!;
print header(-status=>'400 Bad commodity update',
-type=>'text/plain',
-charset=>'us-ascii');
- print "Error: $msg\n";
+ print "\nError: $msg\n";
exit 0;
}
const char *gziplevel /* 0 for read; may be 0, or "-1" etc. */) {
int zfd= open(zpath, oflags, 0666);
- if (!zfd) return errno;
+ if (zfd<0) return errno;
int pipefds[2];
sysassert(! pipe(pipefds) );
else if (IS("--dict-read-only")) o_flags &= (~ffs_dict | ff_dict_fetch);
else if (IS("--dict-anon")) o_flags &= ~ff_dict_pirate;
else if (IS("--dict-submit")) o_flags |= ff_dict_fetch|ff_dict_submit;
+ else if (IS("--dict-no-update")) o_flags &= ~ff_dict_fetch; // testing
else if (IS("--raw-tsv")) outputmode(omk_raw,0);
else if (IS("--upload")) outputmode_uploads();
else if (IS("--upload-yarrg")) outputmode(omk_upload_yarrg,arg+2);
void adjust_colours(CanonImage *ci, const RgbImage *rgb);
void select_page(int page);
+void check_pager_motion(int first, int stop);
Rect find_sunshine_widget(void);
sub { });
for_commods(sub {
my ($commod)= @_;
- my $srcs= $commods{$commod};
+ my $srcs= $commods{$commod}{Srcs};
compare_sources_one($srcs, "commodity $commod");
});
}
#!/usr/bin/perl -w
#
+# Normally run from
+# update-master-info
+#
# usage: ./db-idempotent-populate <Oceanname>
# creates or updates OCEAN-Oceanname.db
# from master-master.txt
#---------- setup ----------
parse_info_serverside();
-parse_info_serverside_ocean($oceanname);
-our $ocean= $oceans{$oceanname};
db_setocean($oceanname);
db_writer();
dist INTEGER NOT NULL,
PRIMARY KEY (aiid, biid)
);
+ CREATE TABLE IF NOT EXISTS routes (
+ aiid INTEGER NOT NULL,
+ biid INTEGER NOT NULL,
+ dist INTEGER NOT NULL,
+ PRIMARY KEY (aiid, biid)
+ );
END
;
#---------- commodity list ----------
{
- my $sth= $dbh->prepare(<<'END')
- INSERT OR IGNORE INTO commods (commodname) VALUES (?);
+ my $insert= $dbh->prepare(<<'END')
+ INSERT OR IGNORE INTO commods
+ (unitmass,
+ unitvolume,
+ commodname)
+ VALUES (?,?,?);
END
;
- foreach my $commod (sort keys %commods) {
- $sth->execute($commod);
- }
- $dbh->commit;
-}
-
-#---------- island list ----------
-
-{
- my $sth= $dbh->prepare(<<'END')
- INSERT OR IGNORE INTO islands (islandname, archipelago) VALUES (?, ?);
+ my $update= $dbh->prepare(<<'END')
+ UPDATE commods
+ SET unitmass = ?,
+ unitvolume = ?
+ WHERE commodname = ?
END
;
- foreach my $archname (sort keys %$ocean) {
- my $arch= $ocean->{$archname};
- foreach my $islandname (sort keys %$arch) {
- $sth->execute($islandname, $archname);
- }
+ foreach my $commod (sort keys %commods) {
+ my $c= $commods{$commod};
+ die "no mass for $commod" unless defined $c->{Mass};
+ die "no colume for $commod" unless defined $c->{Volume};
+ my @qa= ($c->{Mass}, $c->{Volume}, $commod);
+ $insert->execute(@qa);
+ $update->execute(@qa);
}
$dbh->commit;
}
+#---------- island list ----------
#---------- routes ----------
-
-{
- foreach my $islandname (sort keys %{ $route_mysteries{$oceanname} }) {
- warn "$route_mysteries{$oceanname}{$islandname} routes".
- " for unknown island $islandname\n";
- }
-
- my $allroutes= $routes{$oceanname};
-
- my @propqueue= ();
-
- sub distance_set_propagate ($$$$) {
- my ($lev, $start, $upto, $start2upto) = @_;
- $allroutes->{$start}{$upto}= $start2upto;
- push @propqueue, [ $lev, $start, $upto ];
- }
-
- sub distance_propagate_now {
- my ($lev, $start, $upto) = @_;
- my $startref= $allroutes->{$start};
- my $start2upto= $startref->{$upto};
- my $uptoref= $allroutes->{$upto};
-
- for my $next (keys %$uptoref) {
- next if $next eq $upto;
- my $unext= $uptoref->{$next};
- next unless defined $unext;
- distance_update("${lev}p", $start, $next, $start2upto + $unext);
- }
- }
-
- sub distance_update ($$$$) {
- my ($lev, $x, $y, $newdist) = @_;
- distance_update_one("${lev}x",$x,$y,$newdist);
- distance_update_one("${lev}y",$y,$x,$newdist);
- }
-
- sub distance_update_one ($$$$) {
- my ($lev, $x, $y, $newdist) = @_;
- my $xref= $allroutes->{$x};
- my $currently= $xref->{$y};
- return if defined($currently) and $currently <= $newdist;
- distance_set_propagate("${lev}o",$x,$y,$newdist);
- }
-
- foreach my $xn (keys %$allroutes) {
- my $routes= $allroutes->{$xn};
- distance_set_propagate('0', $xn, $xn, 0);
- foreach my $yn (keys %$routes) {
- distance_set_propagate('0', $yn, $yn, 0);
- distance_set_propagate('X', $xn, $yn, $routes->{$yn});
- distance_set_propagate('Y', $yn, $xn, $routes->{$yn});
- }
- }
- my $ref;
- while ($ref= shift @propqueue) {
- distance_propagate_now(@$ref);
- }
-
- db_doall(<<END)
- DELETE FROM dists;
-END
- ;
- my $sth= $dbh->prepare(<<'END')
- INSERT INTO dists VALUES
- ((SELECT islandid FROM islands WHERE islandname == ?),
- (SELECT islandid FROM islands WHERE islandname == ?),
- ?);
-END
- ;
- foreach my $xn (keys %$allroutes) {
- my $routes= $allroutes->{$xn};
- foreach my $yn (keys %$routes) {
- $sth->execute($xn, $yn, $routes->{$yn});
- }
- }
- $dbh->commit();
-
- # select ia.islandname, ib.islandname,dists.dist from dists, islands as ia on dists.aiid = ia.islandid, islands as ib on dists.biid = ib.islandid order by ia.islandname, ib.islandname;
-}
+# now done by yppedia-chart-parser
__DATA__
--- /dev/null
+
+removing an obsolete commodity:
+
+ select * from (select * from sell union select * from buy) left outer join commods using (commodid) where commods.commodname = 'Black dye' limit 10;
+
+if that produces no output then:
+
+ begin;
+ delete from commods where commodname like 'Black dye';
+ select * from (select * from sell union select * from buy) left outer join commods using (commodid) where commods.commodname is null limit 10;
+
+and if that produces no output then:
+ commit;
+otherwise
+ rollback;
+
+=======================================
+
+ceb's example route:
+ alpha,byrne,papaya,turtle,jorvik,luthien
+
+example mixed arbitrage/trade
+ xi,heph
+
+========================================
+
+To remedy bug fixed in 01c14767c024ac56686dbbfcd88d9f3a0b4b1574,
+did this:
+
+sqlite> begin;
+sqlite> insert or ignore into stalls select null, buy.islandid, stalls.stallname from buy, stalls using (stallid);
+sqlite> insert or ignore into stalls select null, sell.islandid, stalls.stallname from sell, stalls using (stallid);
+sqlite> update buy set stallid = (select stallid from stalls where stalls.islandid == buy.islandid and stalls.stallname == (select stallname from stalls as bad where buy.stallid == bad.stallid));
+sqlite> update sell set stallid = (select stallid from stalls where stalls.islandid == sell.islandid and stalls.stallname == (select stallname from stalls as bad where sell.stallid == bad.stallid));
+sqlite> commit;
+
+And to check that it worked:
+
+sqlite> select * from buy offers, stalls using (stallid) where offers.islandid != stalls.islandid group by offers.islandid;
+sqlite> select * from sell offers, stalls using (stallid) where offers.islandid != stalls.islandid group by offers.islandid;
+sqlite>
# sponsored by Three Rings.
-# ./dictionary-manager --approve-updates ijackson@login.chiark.greenend.org.uk /home/ijackson/things/ypp-sc-tools.pctb-dict/pctb /home/ftp/users/ijackson/pctb
+# ./dictionary-manager --approve-updates ijackson@login.chiark.greenend.org.uk /home/ijackson/things/ypp-sc-tools.pctb-dict/yarrg /home/ftp/users/ijackson/yarrg
-# ./dictionary-manager --approve-updates ijackson@login.chiark.greenend.org.uk /home/ijackson/things/ypp-sc-tools.pctb-dict-test/pctb /home/ftp/users/ijackson/pctb/test
+# ./dictionary-manager --approve-updates ijackson@login.chiark.greenend.org.uk /home/ijackson/things/ypp-sc-tools.pctb-dict-test/yarrg /home/ftp/users/ijackson/yarrg/test
# ./dictionary-manager --approve-updates '' . .
+++ /dev/null
-
-commods
- %c dye
- %c enamel
- %c paint
-
- %c cloth
- fine %c cloth
-
- %g gems
-
-%c
- aqua
- black
- blue
- brown
- gold
- green
- grey
- lavender
- lemon
- light blue
- light green
- lime
- magenta
- maroon
- mint
- navy
- orange
- peach
- persimmon
- pink
- purple
- red
- rose
- tan
- violet
- white
- yellow
-
-%g
- amber
- amethyst
- beryl
- coral
- jade
- jasper
- jet
- lapis lazuli
- quartz
- tigereye
-
-commods
- bananas
- broom flower
- butterfly weed
- carambolas
- chalcocite
- coconuts
- cowslip
- cubanite
- diamonds
- durians
- elderberries
- emeralds
- fine rum
- gold nuggets
- gold ore
- grog
- hemp
- hemp oil
- indigo
- iris root
- iron
- kraken's blood
- lacquer
- large cannon balls
- leushite
- lily of the valley
- limes
- lobelia
- lorandite
- madder
- mangos
- masuyite
- medium cannon balls
- moonstones
- nettle
- old man's beard
- opals
- papagoite
- passion fruit
- pearls
- pineapples
- pokeweed berries
- pomegranates
- rambutan
- rubies
- sail cloth
- sapphires
- sassafras
- serandite
- sincosite
- small cannon balls
- stone
- sugar cane
- swill
- tellurium
- thorianite
- topazes
- varnish
- weld
- wood
- yarrow
-
-ocean Midnight
- Coral
- Angelfish Island
- Delta Island
- Meke Island
- Park Island
- Diamond
- Alpha Island
- Byrne Island
- Cnossos Island
- Oyster Island
- Papaya Island
- Turtle Island
- Winter Solstice
- Emerald
- Emperor Island
- Epsilon Island
- Gaea Island
- Guava Island
- Spring Island
- Tinga Island
- Wrasse Island
- Jet
- Chaparral Island
- Eclipse Island
- Hephaestus' Forge
- Lagniappe Island
- Namath Island
- Xi Island
- Opal
- Endurance Island
- Nu Island
- Orca Island
- Waterberry
- Pearl
- Cleopatra's Pearls
- Frond Island
- Ostreum Island
- Zeta Island
- Ruby
- Eta Island
- Cranberry Island
- Islay of Luthien
- Jorvik Island
- Midsummer
- Sapphire
- Beta Island
- Iris Island
- Remora Island
- Vernal Equinox
-
-client ypp-sc-tools yarrg
- lastpage
--- /dev/null
+use glpk's standalone solver with cplex input, see
+ glpk refman.ps.gz p84 for example
+don't use it own modelling language which is very complex
+
+Math::LP would be nice but depends on Math::LP::Solve which is not in
+ Debian.
+
+++ /dev/null
-routes Midnight
- # Try to include "shortcut" routes (those where you can chart a
- # league that isn't actually on any inter-island charts), but if you
- # don't it won't affect things too much.
-
- # Ruby internal
- Olivia, Midsummer, 3
- Midsummer, Cranberry, 2
- Olivia, Lynx, 5
- Olivia, Eta, 7
- Cranberry, Eta, 3
- Lynx, Eta, 3
- Lynx, Islay of Luthien, 5
- Eta, Islay of Luthien, 4
- Islay of Luthien, Jorvik, 5
- Eta, Jorvik, 5
-
- # Pearl internal and interarch
- Cleopatra, O'Reilly, 3
- Cleopatra, Zeta, 4
- Cleopatra, Nuptial, 6
- O'Reilly, Nuptial, 4
- O'Reilly, Zeta, 6
- Nuptial, Zeta, 4
- Nuptial, Ostreum, 6
- Zeta, Tadpole, 4
- Tadpole, Ostreum, 6
- Tadpole, Frond, 4
- Frond, Ostreum, 4
- Frond, Zeta, 6
- Nuptial, Islay of Luthien, 10
- Ostreum, Wrasse, 6
- Ostreum, Gaea, 10
- Frond, Wrasse, 9
- Frond, Gaea, 13
-
- # Diamond internal and interarch - this has lots of shortcut routes
- Turtle, Jorvik, 6
- Turtle, Papaya, 3
- Turtle, Cnossos, 8
- Turtle, Alpha, 7
- Papaya, Byrne, 3
- Papaya, Alpha, 6
- Papaya, Oyster, 8
- Papaya, Winter Solstice, 11
- Cnossos, Alpha, 3
- Cnossos, Winter Solstice, 4
- Cnossos, Guava, 6
- Winter Solstice, Guava, 9
- Winter Solstice, Alpha, 6
- Winter Solstice, Oyster, 5
- Winter Solstice, Park, 11
- Winter Solstice, Delta, 16
- Winter Solstice, Byrne, 9
- Alpha, Oyster, 3
- Oyster, Park, 7
- Oyster, Delta, 12
- Alpha, Byrne, 4
- Byrne, Remora, 10
- Papaya, Remora, 8
-
- # Emerald internal and interarch to Jet and Opal
- Wrasse, Guava, 5
- Wrasse, Gaea, 5
- Wrasse, Epsilon, 11
- Guava, Epsilon, 7
- Gaea, Epsilon, 4
- Gaea, Tinga, 8
- Epsilon, Emperor, 3
- Epsilon, Spring, 6
- Emperor, Spring, 4
- Epsilon, Tinga, 5
- Tinga, Spring, 4
- Tinga, Hephaestus, 11
- Spring, Hephaestus, 8
- Tinga, Orca, 8
-
- # Opal internal
- Orca, Endurance, 3
- Orca, Norse, 5
- Orca, Nu, 4
- Nu, Norse, 3
- Nu, Endurance, 3
- Nu, Oseberg, 4
- Norse, Oseberg, 6
- Norse, Waterberry, 4
- Waterberry, Boyle, 3
- Boyle, Flow, 3
- Flow, Oseberg, 3
-
- # Jet internal
- Hephaestus, Namath, 6
- Hephaestus, Xi, 4
- Hephaestus, Lagniappe, 8
- Hephaestus, Dugong, 10
- Namath, Rhinoceros Ridge, 3
- Rhinoceros Ridge, Lagniappe, 2
- Xi, Lagniappe, 5
- Xi, Chaparral, 4
- Xi, Eclipse, 6
- Chaparral, Eclipse, 4
- Lagniappe, Dugong, 3
- Lagniappe, Eclipse, 5
-
- # Coral internal and interarch to Jet
- Park, Angelfish, 5
- Angelfish, Meke, 4
- Park, Delta, 6
- Delta, Angelfish, 3
- Delta, Macaw, 5
- Macaw, Monsoon, 3
- Monsoon, Chaparral, 6
- Monsoon, Turongo, 4
- Monsoon, Durian, 6
- Turongo, Durian, 3
- Turongo, Angelfish, 7
- Turongo, Delta, 8
- Turongo, Park, 11
-
- # Sapphire internal
- Remora, The Horseshoe Crabs, 3
- Remora, Beta, 3
- The Horseshoe Crabs, Verdant Atoll, 3
- The Horseshoe Crabs, Beta, 5
- Beta, Iris, 4
- Verdant Atoll, Uxmal, 3
- Verdant Atoll, Iris, 6
- Uxmal, Iris, 4
- Iris, Vernal Equinox, 3
static void send_key(KeySym sym) {
check_not_disturbed();
- XTestFakeKeyEvent(disp, keycode(sym),1, 10);
- XTestFakeKeyEvent(disp, keycode(sym),0, 10);
+ XTestFakeKeyEvent(disp, keycode(sym),1, 0);
+ XTestFakeKeyEvent(disp, keycode(sym),0, 0);
}
-static void mouse_1_updown_here(void) {
+static void send_mouse_1_updown_here(void) {
check_not_disturbed();
- XTestFakeButtonEvent(disp,1,1, 10);
- XTestFakeButtonEvent(disp,1,0, 10);
+ XTestFakeButtonEvent(disp,1,1, 0);
+ XTestFakeButtonEvent(disp,1,0, 0);
}
-static void mouse_1_updown(int x, int y) {
+static void send_mouse_1_updown(int x, int y) {
check_not_disturbed();
int screen= XScreenNumberOfScreen(attr.screen);
int xpos, ypos;
translate_coords_toroot(x,y, &xpos,&ypos);
XTestFakeMotionEvent(disp, screen, xpos,ypos, 0);
- mouse_1_updown_here();
+ send_mouse_1_updown_here();
}
static void pgdown_by_mouse(void) {
check_not_disturbed();
debugf("PAGING Mouse\n");
- mouse_1_updown_here();
+ send_mouse_1_updown_here();
sync_after_input();
}
" last_input=%f previously=%p `%s'\n",
last_input, previously, doing);
- double min_interval= 0.025;
+ double max_interval= 5.000;
+ double min_interval= 0.100;
for (;;) {
progress_spinner("%s",doing);
double since_last_input= timestamp() - last_input;
double this_interval= min_interval - since_last_input;
+ if (this_interval > max_interval) this_interval= max_interval;
if (this_interval >= 0)
delay(this_interval);
debugf("PAGING set_focus\n");
- mouse_1_updown(commod_focus_point.x, commod_focus_point.y);
+ send_mouse_1_updown(commod_focus_point.x, commod_focus_point.y);
sync_after_input();
delay(0.5);
Rect sunshine= find_sunshine_widget();
progress("poking client...");
- mouse_1_updown((sunshine.tl.x + sunshine.br.x) / 2,
- (sunshine.tl.y*9 + sunshine.br.y) / 10);
+ send_mouse_1_updown((sunshine.tl.x + sunshine.br.x) / 2,
+ (sunshine.tl.y*9 + sunshine.br.y) / 10);
+ sync_after_input();
free(test);
wait_for_stability(¤t,0,0, "checking basic YPP client screen...");
- mouse_1_updown(250, wheight-10);
- mouse_1_updown_here();
- mouse_1_updown_here();
- XSync(disp,False);
+ send_mouse_1_updown(250, wheight-10);
+ send_mouse_1_updown_here();
+ send_mouse_1_updown_here();
+ sync_after_input();
check_not_disturbed();
send_key(XK_slash);
send_key(XK_w);
for (;;) {
debugf("page %d paging\n",npages);
+ pgdown_by_mouse();
+
if (!(npages < MAX_PAGES))
fatal("Paging down seems to generate too many pages - max is %d.",
MAX_PAGES);
convert_store_page(current);
free_snapshot(&last); last=current; current=0;
-
debugf("PAGING page %d converted\n",npages);
+ npages++;
wait_for_stability(¤t,last, 0,
"page %d collecting ...",
- npages+1);
-
- if (npages && /* first pagedown doesn't do much */
- identical(current,last)) {
- npages++;
+ npages);
+ if (identical(current,last)) {
free_snapshot(¤t);
break;
}
-
- pgdown_by_mouse();
- npages++;
}
progress("finishing with the YPP client...");
- mouse_1_updown(commod_focuslast_point.x, commod_focuslast_point.y);
+ send_mouse_1_updown(commod_focuslast_point.x, commod_focuslast_point.y);
sync_after_input();
send_pgdown_torestore();
sync_after_input();
debugf("PAGING all done.\n");
progress_log("collected %d screenshots.",npages);
+ check_pager_motion(0,npages);
}
void take_one_screenshot(void) {
--- /dev/null
+
+commods
+ kraken's blood 1kg
+ %c dye 1kg
+ %c enamel 5kg
+ %c paint 1200g 1l
+
+ %c cloth 700g
+ fine %c cloth 700g
+ sail cloth 700g
+
+nocommods
+ black dye
+
+%c
+ aqua
+ black
+ blue
+ brown
+ gold
+ green
+ grey
+ lavender
+ lemon
+ light blue
+ light green
+ lime
+ magenta
+ maroon
+ mint
+ navy
+ orange
+ peach
+ persimmon
+ pink
+ purple
+ red
+ rose
+ tan
+ violet
+ white
+ yellow
+
+commods
+ %g gems 10kg
+ diamonds 10kg
+ emeralds 10kg
+ moonstones 10kg
+ opals 10kg
+ pearls 10kg
+ rubies 10kg
+ sapphires 10kg
+ topazes 10kg
+
+%g
+ amber
+ amethyst
+ beryl
+ coral
+ jade
+ jasper
+ jet
+ lapis lazuli
+ quartz
+ tigereye
+
+commods
+ swill 1kg
+ grog 1kg
+ fine rum 1kg
+
+ broom flower 200g
+ butterfly weed 100g
+ cowslip 700g
+ elderberries 700g
+ indigo 700g
+ iris root 300g
+ lily of the valley 300g
+ lobelia 200g
+ madder 400g
+ nettle 300g
+ old man's beard 800g
+ pokeweed berries 300g
+ sassafras 500g
+ weld 300g
+ yarrow 200g
+
+ bananas 125kg 100l
+ coconuts 125kg 100l
+ limes 125kg 100l
+ mangos 125kg 100l
+ pineapples 125kg 100l
+
+ carambolas 125kg 100l
+ durians 125kg 100l
+ passion fruit 125kg 100l
+ pomegranates 125kg 100l
+ rambutan 125kg 100l
+
+ chalcocite 5700g
+ cubanite 4700g
+ gold nuggets 400g
+ leushite 4400g
+ lorandite 5500g
+ masuyite 5100g
+ papagoite 3300g
+ serandite 3400g
+ sincosite 3000g
+ tellurium 6200g
+ thorianite 100g
+
+ small cannon balls 7100g
+ medium cannon balls 14200g 2l
+ large cannon balls 21300g 3l
+
+ hemp 125kg 250l
+ hemp oil 1kg
+ iron 7800g
+ lacquer 1kg
+ stone 2600g
+ sugar cane 50kg 100l
+ varnish 1kg
+ wood 175kg 250l
+
+
+client ypp-sc-tools yarrg
+ lastpage
+
+
+#---------- OCEANS ----------
+# subscriber oceans
+
+ocean Midnight
+
+ocean Cobalt
+ Garnet
+ Jubilee Island
+
+ocean Ice
+ Vilya
+ Winking Wall Island
+
+# doubloon oceans
+
+ocean Hunter
+ Eagle
+ Ix Chel
+
+ocean Malachite
+ Draco
+ Cetus Island
+ Threewood Island
+
+ocean Sage
+ Osprey
+ Scurvy Reef
+ Gauntlet Island
+
+ocean Viridian
+
+# family oceans
+
+ocean Crimson
+
+# International oceans (doubloon oceans)
+
+#ocean Jade
+# Cigüeña
+# Isla Scrimshaw
+# Ibis
+# Isla Kiwara
+# Águila
+# Cayo Escorbuto
+
+#ocean Opal
+# Canis
+# Atchafalaya-Insel
+
struct PageStruct {
Rect mr;
- int commbasey, comminty;
+ int commbasey, comminty, pagerheight;
int colrightx[INTERESTING_COLUMNS];
};
#define CHECK_STRIP_BORDER(tlbr,xy,increm) \
do { \
- Point csb_p; \
+ Point csb_p, csb_p2; \
Rect csb_r; \
csb_p= s.mr.tl; \
csb_p.x++; csb_p.y++; \
+ csb_p2= csb_p; \
+ csb_p2.x++; csb_p2.y++; \
csb_p.xy= s.mr.tlbr.xy; \
- if (get_p(csb_p)=='+') { \
+ csb_p2.xy= s.mr.tlbr.xy; \
+ if (get_p(csb_p)=='+' && \
+ get_p(csb_p2)=='+') { \
csb_r= s.mr; \
csb_r.tl.xy= csb_p.xy; \
csb_r.br.xy= csb_p.xy; \
ADJUST_BOX(pager, "o",>=,RECT_W(pager)-2, s.mr.tl.y,LIMIT_QUITEQ, tl,y,-1);
debug_rect("pager",__LINE__,pager);
+ pager.br.y= pager.tl.y;
+ pager.tl.y= pager.tl.y-1;
+ if (pager.tl.y > s.mr.tl.y)
+ ADJUST_BOX(pager, "+",>,1, s.mr.tl.y,LIMIT_QUITEQ, tl,y,-1);
+ debug_rect("pager",__LINE__,pager);
+ s.pagerheight= pager.br.y - pager.tl.y;
+
#define SET_ONCE(var,val) do{ \
int v= (val); \
if ((var)==-1) (var)= v; \
}
if (commod_page_point_r) {
commod_page_point_r->x= (pager.tl.x + pager.br.x) / 2;
- commod_page_point_r->y= pager.tl.y - 1;
+ commod_page_point_r->y= pager.br.y - 1;
}
MUST( text_h <= OCR_MAX_H, MI(text_h) );
"??____X_____?_X_?X__?X_______________________",
"???__?_______?__?___?_______________________?",
};
+ static const char *all_fuzzy[]= {
+ "???___________________________________???",
+ "??_______???___X__X____________________??",
+ "?_______????__?X_?X_____XXXXXXXXXXX_____?",
+ "________?????_?X_?X______XXXXXXXXX_______",
+ "________?????_?X_?X_______XXXXXXX________",
+ "_______??????_?X_?X________XXXXX_________",
+ "_______??_?????X_?X_________XXX__________",
+ "______??XXXXX??X_?X__________X___________",
+ "?_____?????????X_?X______________________",
+ "??___???____???X_?X______________________",
+ "???__??_____???__?______________________?",
+ };
#define COMMOD_SELECTOR_MATCHES(all) \
commod_selector_matches(search, all, \
strlen((all)[0]))
if (!(COMMOD_SELECTOR_MATCHES(all_small) ||
- COMMOD_SELECTOR_MATCHES(all_big)))
+ COMMOD_SELECTOR_MATCHES(all_big) ||
+ COMMOD_SELECTOR_MATCHES(all_fuzzy)))
fatal("Commodities selector not set to `All'.");
}
else free(rgb);
page_images[npages]= cim;
page_structs[npages]= *pstruct;
+ debugf("STORED page %d pagerheight=%d\n", npages, pstruct->pagerheight);
free(pstruct);
}
}
sysassert(!ferror(screenshot_file));
progress_log("read %d screenshots.",npages);
+
+ check_pager_motion(1,npages);
+ /* When we are reading screenshots, the pages file contains the
+ * `determine where we're to click' page as well as the first
+ * actual data page, which we have to skip.
+ */
}
#define FIXPT_SHIFT 15
island= masprintf("%s", delim+3);
}
+
+void check_pager_motion(int first, int stop) {
+ /* We check that the pager moved by an appropriate amount.
+ * The last gap can be smaller but not bigger.
+ */
+ int count= stop-first;
+
+#define PH(p) (page_structs[(p)].pagerheight)
+
+ debugf("CHECK_PAGER_MOTION %d..%d count=%d\n", first,stop,count);
+
+ if (count <= 1) return; /* only one page */
+
+ double firstheight= PH(first);
+ double max= count>2 ? firstheight / (count-2) : 0;
+ double min= firstheight / (count-1);
+ max *= 1.1;
+ min /= 1.1;
+ max += 1.0;
+ min -= 1.0;
+ debugf("CHECK_PAGER_MOTION min=%g max=%g\n", min,max);
+ assert(max>min);
+
+ int skips=0, firstskip=1;
+ int stops=0, firststop=1;
+
+#define REPORT(skipstop,msg) do{ \
+ skipstop##s++; \
+ if (first##skipstop<0) first##skipstop= page; \
+ if (skipstop##s<5) \
+ fprintf(stderr,msg " (page %d)\n",page); \
+ }while(0)
+
+ int page;
+ for (page=first+1; page<stop; page++) {
+ int gap= PH(page-1) - PH(page);
+ debugf("CHECK_PAGER_MOTION page=%2d gap=%2d\n", page, gap);
+ if (gap>max)
+ REPORT(skip, "scrollbar motion probable page skip detected!");
+ if (gap<min && page<stop-1)
+ REPORT(stop, "scrollbar short motion gives lie to our ideas!");
+ }
+ MUST(!skips && !stops,
+ MI(skips);MI(firstskip);MF(max);MI(PH(firstskip));MI(PH(firstskip-1));
+ MI(stops);MI(firststop);MF(min);MI(PH(firststop));MI(PH(firststop-1));
+ MF(firstheight);MI(PH(stop-2));MI(PH(stop-1));
+ MSB(
+"\n\n"
+"Your YPP client seems to be paging irregularly. Perhaps your computer\n"
+"is too slow or overloaded or perhaps you are messing with the mouse ?\n"
+ ));
+}
#!/usr/bin/perl -w
+#
+# MAIN ADMINISTRATIVE DATABASE UPDATE TOOL
+#
+# Usage:
+# ./update-master-info [-d RSYNCDESTDIR] [-O OCEAN ... | -a]
+#
+# Usual usages:
+#
+# After editing source-info.txt to add commodities, or
+# changing db-idempotent-update (eg to change the schema):
+# ./update-master-info -d ~ftp/users/ijackson/yarrg/
+# This will update everything except the ocean topologies.
+#
+# To take account of new islands, or to fix a mistake in
+# assigning island(s) to archipelago(es), or to add support
+# for a new ocean:
+# ./update-master-info -d ~ftp/users/ijackson/yarrg/ -O Midnight
+#
+# After a fix to a mistake on a YPPedia chart page, correcting
+# only inter-island-distances:
+# ./update-master-info -O Midnight
+#
+# After changing the algorithms for topology determination
+# or YPPedia scraping:
+# ./update-master-info -a
+# and check that nothing unexpected changes.
+#
-use strict (qw(vars));
+# This is part of ypp-sc-tools, a set of third-party tools for assisting
+# players of Yohoho Puzzle Pirates.
+#
+# Copyright (C) 2009 Ian Jackson <ijackson@chiark.greenend.org.uk>
+#
+# This program is free software: you can redistribute it and/or modify
+# it under the terms of the GNU 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 General Public License for more details.
+#
+# You should have received a copy of the GNU 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.
+use strict (qw(vars));
use DBI;
-
use Commods;
-@ARGV==1 or die;
-my ($rsyncdir) = @ARGV;
+$ENV{'LC_CTYPE'}= 'en_GB.UTF-8';
+
+sub full ($) {
+ my ($ocean) = @_;
+ quick($ocean);
+ print "## updating topology of $ocean\n";
+ system('./yppedia-chart-parser',$ocean); die "$ocean $?" if $?;
+ print "\n";
+}
+
+sub quick ($) {
+ my ($ocean) = @_;
+ print STDERR "## updating schema and commodities for $ocean\n";
+ system('./db-idempotent-populate',$ocean); die $? if $?;
+}
+
+my $rsyncdir;
+
+sub process_some_info ($$$) {
+ my ($v,$df,$sfn) = @_;
+ my $sf= new IO::File $sfn or die "$sfn $!";
+
+ my $h;
+ while (<$sf>) {
+ chomp; s/\s+$//;
+ next if m/^\s*\#/ || !m/\S/;
+ if (m/^\S.*/) {
+ $h= $&;
+ }
+ die "$_ ?" unless defined $h;
+ if ($h =~ m/^commods|^\%[a-z]\b/) {
+ s/\t.*//;
+ }
+ if ($v<2) {
+ next if $h =~ m/^nocommods/;
+ }
+ next if $sfn =~ m/source-info/ && $h =~ m/^ocean\b/;
+ next if $h =~ m/^client\b/;
+
+ print $df $_, "\n" or die $!;
+ }
+
+ $sf->error and die $!;
+}
+
+sub update_master_info () {
+ foreach my $v (1..$masterinfoversion) {
+ my $dfnl= sprintf "master-info%s.txt", ($v>1 ? "-v$v" : '');
+ print STDERR "installing new $dfnl...\n";
+
+ my $dfn= "$rsyncdir/$dfnl";
+ my $df= new IO::File "$dfn.tmp", 'w' or die "$dfn.tmp $!";
+
+ process_some_info($v,$df, 'source-info.txt');
+ foreach my $ocean (sort keys %oceans) {
+ process_some_info($v,$df, '_ocean-'.(lc $ocean).'.txt');
+ }
+
+ close $df or die $!;
+ rename "$dfn.tmp", "$dfn" or die $!;
+ }
+}
+
+
+my @specoceans;
+my $alloceans;
+
+sub optarg () {
+ return $_ if length;
+ die unless @ARGV;
+ return scalar shift @ARGV;
+}
+
+while (@ARGV && $ARGV[0] =~ m/^-/) {
+ $_= shift @ARGV;
+ last if m/^--?$/;
+ while (m/^-./) {
+ if (s/^-d//) {
+ die if defined $rsyncdir;
+ $rsyncdir= optarg();
+ } elsif (s/^-O//) {
+ push @specoceans, optarg();
+ } elsif (s/^-a//) {
+ die if $alloceans;
+ $alloceans=1;
+ } else {
+ die "$_ ?";
+ }
+ }
+}
+die if @ARGV;
+
+die if @specoceans && $alloceans;
parse_info_serverside();
-foreach my $oceanname (sort keys %oceans) {
- print STDERR "updating ocean $oceanname...\n";
- system('./db-idempotent-populate',$oceanname); die $? if $?;
+if (@specoceans) {
+ print "### full update of specified oceans ...\n";
+ foreach my $ocean (@specoceans) {
+ die "$ocean ?" unless defined $oceans{$ocean};
+ full($ocean);
+ }
+} elsif ($alloceans) {
+ print "### full (inc.topology) update of all oceans ...\n";
+ foreach my $ocean (sort keys %oceans) {
+ full($ocean);
+ }
+} else {
+ print "### quick (no topology) update only (of all oceans) ...\n";
+ foreach my $ocean (sort keys %oceans) {
+ quick($ocean);
+ }
}
-print STDERR "installing new master-info...\n";
-my $df= "$rsyncdir/master-info.txt";
-system('cp','--','master-info.txt',"$df.tmp"); die $? if $?;
-system('mv','--',"$df.tmp",$df); die $? if $?
+if (defined $rsyncdir) {
+ print "### master-info update ...\n";
+ update_master_info();
+}
--- /dev/null
+..
\ No newline at end of file
--- /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 autohandler contains the doctype, charset and
+ copyright message.
+
+
+</%doc><!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">
+<!--
+ This HTML is generated by the YARRG website, which is
+ <& copyrightdate &>.
+
+ The YARRG website is Free Software and licenced according to the
+ GNU Affero General Public Licence (v3 or later). See the link at
+ the bottom of this page for full licence and copyright
+ information.
+
+ Many YARRG web pages also display data from the YARRG database,
+ which contains mostly contributions from YARRG users and is not
+ covered by the AGPL.
+-->
+
+% $m->call_next;
+
+<%init>
+use CommodsWeb;
+set_ctype_utf8();
+$r->content_type('text/html; charset=UTF-8');
+</%init>
--- /dev/null
+<html><head><title>Stuff</title></head>
+<body><pre>
+@INC = <% join ':', @INC |h %>
+% foreach my $e (sort keys %ENV) {
+<% $e |h%>=<% $ENV{$e} |h%>
+% }
+</body>
--- /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 look up commodities.
+ It is called by qtextstring.
+
+</%doc>
+
+<%attr>
+multiple => 0
+maxambig => 4
+</%attr>
+
+<%method sqlstmt>
+SELECT commodname,commodid
+ FROM commods WHERE commodname LIKE ?
+</%method>
+
+<%method nomatch>
+ no commodity matches "<% $ARGS{spec} |h %>"
+</%method>
+
+<%method ambiguous>
+ ambiguous commodity "<% $ARGS{spec} |h %>",
+ could be <% $ARGS{couldbe} |h %>
+</%method>
+
+<%method manyambig>
+ Many matching commodities.
+</%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 look up route entries.
+ It is called by qtextstring.
+
+</%doc>
+
+<%attr>
+multiple => 1
+maxambig => 5
+</%attr>
+
+<%method sqlstmt>
+ SELECT islandname,islandid,archipelago
+ FROM islands WHERE islandname LIKE ?
+UNION ALL SELECT DISTINCT archipelago,NULL,archipelago
+ FROM islands WHERE archipelago LIKE ?
+</%method>
+
+<%method nomatch>
+ no island or arch matches "<% $ARGS{spec} |h %>"
+</%method>
+
+<%method ambiguous>
+ ambiguous island or arch "<% $ARGS{spec} |h %>",
+ could be <% $ARGS{couldbe} |h %>
+</%method>
+
+<%method manyambig>
+
+</%method>
--- /dev/null
+Copyright 2009 Ian Jackson, Clare Boothby
\ No newline at end of file
--- /dev/null
+<%perl>
+my $arg= $m->dhandler_arg;
+if ($arg =~ m,^/?$,) {
+ $m->redirect('lookup');
+} else {
+ $r->header_out('Status','404 Not found');
+</%perl>
+<html><head><title>Page not found - YARRG</title></head><body>
+<h1>404 YARRG component not found</h1>
+<% $arg |h %>
+<%perl>
+}
+</%perl>
--- /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 documentation.
+
+
+</%doc>
+<html><head><title>YARRG (Yet Another Revenue Research Gatherer)</title>
+</head><body>
+
+<h1>Introduction to YARRG</h1>
+
+YARRG (Yet Another Revenue Research Gatherer) is a third-party tool
+for helping find profitable trades and trade routes in Yohoho Puzzle
+Pirates. It was inspired by
+<a href="http://pctb.crabdance.com/">PCTB</a>.
+
+<p>
+
+The system has two main parts: this website which maintains a
+searchable database of commodity prices, and an upload client, which
+screenscrapes the commodity data from the Puzzle Pirates game client
+and uploads it to the database.
+
+<h2><a href="lookup">Market prices database</a></h2>
+
+The <a href="lookup">lookup page</a> gives access to the uploaded data.
+
+<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>.
+
+<p>
+
+The current official version of YARRG for use as an upload
+client can browsed here:
+ <a href="/~ijackson/ypp-sc-tools/master/">http://www.chiark.greenend.org.uk/~ijackson/ypp-sc-tools/master/</a>
+See particularly the
+<a href="/~ijackson/ypp-sc-tools/master/yarrg/README">YARRG README</a>.
+
+<p>
+To install the client, install the `git' version control system
+and the other dependencies listed in the `Installation requirements'
+section of the README and then run:
+<pre>
+git-clone http://www.chiark.greenend.org.uk/~ijackson/ypp-sc-tools/master/.git ypp-sc-tools
+cd ypp-sc-tools
+cd yarrg
+make
+</pre>
+this will download the code into the directory <code>ypp-sc-tools</code>,
+and build the software.
+
+<p>
+
+When new versions of the upload client are released, you can:
+<pre>
+cd .../ypp-sc-tools
+git-pull
+cd yarrg
+make
+</pre>
+to fetch the new version.
+
+<h2>Uploading from Windows</h2>
+
+There is not currently an upload client for Windows which feeds data
+into YARRG. It would probably be straightforward to modify the
+Windows PCTB v5 upload client to upload to YARRG as well. The
+mechanism and format for uploading is documented in
+<a href="/~ijackson/ypp-sc-tools/master/yarrg/README.devel">README.devel</a>.
+
+<h1>YARRG development, contribution and troubleshooting</h1>
+
+<h2>Free Software (aka Open Source)</h2>
+
+YARRG is Free Software - you may share and modify it. See the
+licences for details.
+
+<p>
+
+Not only the client but also the webserver code is Free. The website
+code can be found in the same tree as above, in the <code>web</code>
+directory.
+
+<p>
+
+But in case we have made changes but not yet pushed them
+(perhaps because we haven't done a release), and to make it easy for
+anyone else who runs a copy of the website to provide everyone with
+the source for their version, the website code itself lets you download
+an up-to-date <a href="source.tar.gz">tarball</a> of its
+actually-running source code.
+
+<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 code you'll be running. Please just ask
+us.
+
+<h2>Contacting the YARRG developers</h2>
+
+Email Ian Jackson ijackson (at) chiark.greenend.org.uk. Or talk to
+any Fleet Officer or above of the crew Special Circumstances on the
+Midnight Ocean.
+
+<& footer, isdocs => 1 &>
--- /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 is helpful for debugging and developing. It
+ outputs plain HTML tables eg for SQL query results. You can either:
+ <& 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
+ <& dumptable:start, cols => [ 'column',... ], [ qa => $qa ] &>
+ % my $row;
+ % while ($row= $sth->fetchrow_hashref) {
+ <& dumptable:row, sth|cols => ..., row => $row, [ qa => $qa ] &>
+ % do something else with $row
+ % }
+ <& dumptable:end, [ qa => $qa ] &>
+ where if you pass $qa, dumptable will check whether debug
+ is enabled and produce no output if it isn't. NB you don't want
+ this approach if your loop body produces output because it'll be
+ interleaved with dumptable's table.
+
+</%doc>
+<%args>
+$sth
+</%args>
+
+<%method start>
+<%args>
+$sth => undef
+$cols => $sth->{NAME}
+$qa => undef
+</%args>
+% if (!$qa || $qa->{'debug'}) {
+<table frame=box rules=all>
+<tr>
+% foreach my $field (@$cols) {
+<th><% $field |h %>
+% }
+</tr>
+% }
+</%method>
+
+<%method row>
+<%args>
+$sth => undef
+$cols => $sth->{NAME}
+$row
+$qa => undef
+</%args>
+% if (!$qa || $qa->{'debug'}) {
+<tr>
+% foreach my $field (@$cols) {
+% my $cell= $row->{$field};
+<td>
+<% $cell |h %>
+</td>
+% }
+</tr>
+% }
+</%method>
+
+<%method end>
+<%args>
+$qa => undef
+</%args>
+% if (!$qa || $qa->{'debug'}) {
+</table>
+% }
+</%method>
+
+<%method literal>
+<%args>
+$cols
+$rows
+$qa => undef
+</%args>
+<& SELF:start, cols => $cols &>
+% foreach my $row (@$rows) {
+<& SELF:row, cols => $cols, row => $row &>
+% }
+<& SELF:end &>
+</%method>
+
+<& SELF:start, sth => $sth &>
+% my $row;
+% while ($row= $sth->fetchrow_hashref) {
+<& SELF:row, sth => $sth, row => $row &>
+% }
+<& SELF:end &>
--- /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 is simply the page footer.
+
+
+</%doc>
+<%args>
+$isdocs => 0
+</%args>
+<hr>
+<address>
+YARRG is Yet Another Revenue Research Gatherer, a project of the
+crew Special Circumstances on the Midnight Ocean
+and of the Sinister Greenend Organisation.
+<p>
+
+YARRG is Free Software.
+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).
+% if (!$isdocs) {
+Please see the <a href="docs">YARRG documentation webpage</a> for
+details of how to obtain the client and server code and full details
+of the licences.
+% }
+
+<p>
+YARRG is <& copyrightdate &>.
+Yohoho and Puzzle Pirates are trademarks of Three Rings and are used
+without permission. YARRG is not endorsed or sponsored by Three
+Rings.
+
+</address>
--- /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 main `lookup' page, including
+ all the entry boxes etc. for every query.
+
+
+</%doc>
+<%perl>
+my %ahtml;
+my @vars;
+my %styles;
+
+#---------- "mode" argument parsing and mode menu at top of page ----------
+
+# for debugging, invoke as
+# http://www.chiark.greenend.org.uk/ucgi/~clareb/mason/pirates/pirate-route?debug=1
+
+@vars= ({ Name => 'Ocean',
+ Before => 'Ocean: ',
+ CmpCanon => sub { ucfirst lc $_[0] },
+ Values => [ ocean_list() ]
+ }, { Name => 'Dropdowns',
+ Before => 'Interface: ',
+ CmpCanon => sub { !!$_[0] },
+ Values => [ [ 0, 'Type in names' ],
+ [ 4, 'Select from menus' ] ]
+ }, { Name => 'Query',
+ Before => 'Query: ',
+ Values => [ [ 'route', 'Trades for route' ],
+ [ 'commod', 'Prices for commodity' ],
+ [ 'age', 'Data age' ] ]
+ }, { Name => 'BuySell',
+ Before => '',
+ Values => [ [ 'buy_sell', 'Buy and sell' ],
+ [ 'sell_buy', 'Sell and buy' ],
+ [ 'buy', 'Buy offers only' ],
+ [ 'sell', 'Sell offers only' ],
+ ],
+ QuerySpecific => 1,
+ }, { Name => 'ShowBlank',
+ Before => '',
+ Values => [ [ 0, 'Omit islands with no offers' ],
+ [ 'show', 'Show all islands' ],
+ ],
+ QuerySpecific => 1,
+ }, { Name => 'ShowStalls',
+ Before => '',
+ Values => [ [ 0, 'Show total quantity at each price' ],
+ [ 1, 'Show individual stalls' ],
+ ],
+ QuerySpecific => 1,
+ });
+
+foreach my $var (@vars) {
+ my $name= $var->{Name};
+ my $lname= lc $name;
+ $var->{Before}= '' unless exists $var->{Before};
+ $var->{CmpCanon}= sub { $_[0]; } unless exists $var->{CmpCanon};
+ foreach my $val (@{ $var->{Values} }) {
+ next if ref $val;
+ $val= [ $val, encode_entities($val) ];
+ }
+ if (exists $ARGS{$lname}) {
+ $styles{$name}= $ARGS{$lname};
+ my @html= grep { $_->[0] eq $styles{$name} }
+ @{ $var->{Values} };
+ $ahtml{$name}= @html==1 ? $html[0][1] : '???';
+ } else {
+ $styles{$name}= $var->{Values}[0][0];
+ $ahtml{$name}= $var->{Values}[0][1];
+ }
+}
+
+</%perl>
+
+<%shared>
+my %baseqf;
+my %queryqf;
+</%shared>
+
+<%method formhidden>
+<%args>
+$ours
+</%args>
+% foreach my $n (keys %baseqf, keys %queryqf) {
+% next if $ours->($n);
+% my $v= exists $baseqf{$n} ? $baseqf{$n} : $queryqf{$n};
+<input type=hidden name=<% $n %> value="<% $v |h %>">
+% }
+</%method>
+
+<html><head><title><% ucfirst $ahtml{Query} %> - YARRG</title>
+<style type="text/css">
+body {
+ color: #000000;
+ background: #ffffff;
+}
+tr.datarow0 { background: #ffffff; }
+tr.datarow1 { background: #e3e3e3; }
+</style>
+<&| script &>
+ function register_onload(f) {
+ var previous_onload= window.onload;
+ window.onload= function() {
+ if (previous_onload) previous_onload();
+ f();
+ };
+ }
+</&script>
+</head><body>
+
+<a href="<% $m->current_comp()->name() |u %>">YARRG</a> -
+ Yet Another Revenue Research Gatherer
+|
+<a href="docs">documentation</a>
+<p>
+<%perl>
+
+foreach my $var (@vars) {
+ my $lname= lc $var->{Name};
+ next unless exists $ARGS{$lname};
+ $baseqf{$lname}= $ARGS{$lname};
+}
+
+foreach my $var (keys %ARGS) {
+ next unless $var =~
+ m/^(?: (?:route|commod)string |
+ commodid |
+ islandid \d |
+ archipelago \d |
+ debug |
+ [RT]\w+
+ )$/x;
+ my $val= $ARGS{$var};
+ next if $val eq 'none';
+ $queryqf{$var}= $val;
+}
+
+my $quri= sub {
+ my $uri= URI->new('lookup');
+ $uri->query_form(@_);
+ $uri->path_query();
+};
+
+my $prselector_core= sub {
+ my ($var)= @_;
+ my $name= $var->{Name};
+ my $lname= lc $var->{Name};
+ my $delim= $var->{Before};
+ my $canon= &{$var->{CmpCanon}}($styles{$name});
+ my $cvalix= 0;
+ foreach my $valr (@{ $var->{Values} }) {
+ print $delim; $delim= "\n|\n";
+ my ($value,$html) = @$valr;
+ my $iscurrent= &{$var->{CmpCanon}}($value) eq $canon;
+ my $after;
+ if ($iscurrent) {
+ print '<b>';
+ $after= '</b>';
+ } else {
+ my %qf= (%baseqf,%queryqf);
+ delete $qf{$lname};
+ $qf{$lname}= $value if $cvalix;
+</%perl>
+<a href="<% $quri->(%qf) |h %>">
+<%perl>
+ $after= '</a>';
+ }
+ print $html, $after;
+ $cvalix++;
+ }
+ print "<p>\n\n";
+};
+
+my $prselector= sub {
+ my ($name)= @_;
+ foreach my $var (@vars) {
+ if ($var->{Name} eq $name) {
+ $prselector_core->($var);
+ return;
+ }
+ }
+ die $name;
+};
+
+foreach my $var (@vars) {
+ next if $var->{QuerySpecific};
+ $prselector_core->($var);
+}
+
+#---------- initial checks, startup, main entry form ----------
+
+die if $styles{Query} =~ m/[^a-z]/;
+
+my $mydbh;
+my $dbh= ($mydbh= dbw_connect($styles{Ocean}));
+
+my $results_head_done=0;
+my $someresults= sub {
+ return if $results_head_done;
+ $results_head_done=1;
+ my ($h)= @_;
+ $h= 'Results' if !$h;
+ print "\n<h1>$h</h1>\n";
+};
+
+</%perl>
+<%args>
+$debug => 0
+</%args>
+
+<hr>
+
+<& "query_$styles{Query}", %baseqf, %queryqf, %styles,
+ quri => $quri, dbh => $dbh,
+ prselector => $prselector,
+ someresults => $someresults,
+ emsgokorprint => sub {
+ my ($emsg) = @_;
+ return 1 unless defined $emsg and length $emsg;
+ $someresults->();
+ print $emsg;
+ return 0;
+ }
+ &>
+
+<p>
+
+%#---------- debugging and epilogue ----------
+
+% if ($debug) {
+<p>
+<pre id="debug_log">
+Debug log:
+</pre>
+% }
+
+<&| script &>
+function debug (m) {
+% if ($debug) {
+ var node= document.getElementById('debug_log');
+ node.innerHTML += "\n" + m + "\n";
+% }
+}
+</&script>
+
+<& footer &>
+
+<%init>
+use CommodsWeb;
+use HTML::Entities;
+use URI::Escape;
+
+</%init>
+<%cleanup>
+
+$mydbh->rollback() if $mydbh;
+
+</%cleanup>
--- /dev/null
+<html><head><title>Select island</title></head><body>
+<form action="/ucgi/~clareb/mason/something" method="get">
+<select name="islandid">
+<%perl>
+my $sth=$dbh->prepare("SELECT islandid,archipelago,islandname
+ FROM islands
+ ORDER BY archipelago,islandname;");
+$sth->execute();
+</%perl>
+% my $row;
+% while ($row=$sth->fetchrow_hashref) {
+<option value="<% $row->{'islandid'} |h %>"><% $row->{'archipelago'} |h %> -
+<% $row->{'islandname'} |h %>
+% }
+<input type=submit name=submit value="Go">
+</form>
+
+<%init>
+use CommodsWeb;
+db_setocean('Midnight');
+db_connect();
+</%init>
--- /dev/null
+<HTML>
+<HEAD>
+<TITLE>test pirate page</TITLE>
+</HEAD>
+<BODY>
+
+<html><head><title>Profitable trades</title></head><body>
+<%perl>
+my $sth=$dbh->prepare(
+ "SELECT commods.commodname,
+ sell_islands.islandname,sell_stalls.stallname,sell.price,sell.qty,
+ buy_islands.islandname,buy_stalls.stallname,buy.price,buy.qty
+ FROM commods
+ JOIN buy on commods.commodid=buy.commodid
+ JOIN sell on commods.commodid=sell.commodid
+ JOIN islands as buy_islands on buy.islandid = buy_islands.islandid
+ JOIN stalls as buy_stalls on buy.stallid = buy_stalls.stallid
+ JOIN islands as sell_islands on sell.islandid = sell_islands.islandid
+ JOIN stalls as sell_stalls on sell.stallid = sell_stalls.stallid
+ WHERE buy.islandid like '36' and sell.islandid like '5'
+ and buy.price > sell.price
+ ");
+
+$sth->execute();
+</%perl>
+<& dumptable, sth => $sth &>
+
+</BODY>
+</HTML>
+
+<%init>
+use CommodsWeb;
+my $dbh= dbw_connect('Midnight');
+</%init>
--- /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 handles analysis of text string entries, including
+ both the AJAX calls from web page javascript and the entry validation
+ and processing calls from other components.
+
+
+</%doc>
+<%args>
+$qa => $m->caller_args(1)->{'qa'}
+$dbh
+$thingstring
+$emsgstore
+$perresult
+</%args>
+<%perl>
+my $stringval= $qa->{$thingstring};
+$stringval='' if !defined $stringval;
+</%perl>
+
+<&| script &>
+ts_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);
+}
+function ts_Needed(){
+ window.clearTimeout(ts_timeout);
+ ts_element= document.getElementById('<% $thingstring %>');
+ ts_needed= ts_element.value;
+ ts_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 ts_Ready() {
+ if (ts_request.readyState != 4) return;
+ if (ts_request.status == 200) {
+ response= ts_request.responseText;
+ debug('got '+response);
+ eval('results='+response);
+ toedit= document.getElementById('ts_results');
+ toedit.innerHTML= results.show;
+ }
+ ts_request= false;
+ ts_Request();
+}
+register_onload(ts_Needed);
+</&script>
+
+<input type="text" <% $m->content %>
+ id="<% $thingstring %>" name="<% $thingstring %>"
+ onchange="ts_Needed();" onkeyup="ts_Later();"
+ value="<% $stringval |h %>"
+ >
+<br>
+<div id="ts_results"> </div><br>
+
+<%perl>
+if (length $thingstring) {
+ my ($emsg,$canonstring,$results)= $m->comp('qtextstringcheck',
+ what => $thingstring,
+ ocean => $qa->{Ocean},
+ string => $stringval,
+ format => 'return'
+ );
+ $$emsgstore= $emsg;
+
+ foreach my $entry (@$results) {
+ $perresult->(@$entry);
+ }
+}
+</%perl>
--- /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 handles the generic output format options for
+ text string parsers/checkers like check_routestring.
+
+# typical url for this script:
+# http://www.chiark.greenend.org.uk/ucgi/~clareb/mason/pirates/qtextstring?what=routestring?format=json&ocean=Midnight&string=d
+
+</%doc>
+
+<%args>
+$ocean
+$format
+$ctype => undef
+$string
+$what
+$dbh => undef
+</%args>
+
+<%flags>
+inherit => undef
+</%flags>
+<%perl>
+
+use JSON;
+use Data::Dumper;
+use HTML::Entities;
+use CommodsWeb;
+
+die if $what =~ m/[^a-z]/;
+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;
+
+#die "$sqlstmt @sqlstmt_qs";
+
+my $emsg= '';
+my @results;
+
+my @specs= $chk->attr('multiple') ? (split m#[/|,]#, $string) : ($string);
+
+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 (!$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)));
+ }
+ }
+ push @results, $results->[0];
+};
+
+$emsg='' if !defined $emsg;
+my $canontext= join ' | ', map { $_->[0] } @results;
+
+if ($format =~ /json/) {
+ $r->content_type($ctype or $format);
+ my $jobj= {
+ success => 1*!length $emsg,
+ show => (length $emsg ? $emsg :
+ length $canontext ? encode_entities($canontext) :
+ ' '),
+ };
+ print to_json_shim($jobj);
+}
+if ($format =~ /dump/) {
+ $r->content_type('text/plain');
+ print Dumper($emsg, $canontext, \@results);
+}
+
+$mydbh->rollback() if $mydbh;
+
+return $emsg,
+ $canontext,
+ [ @results ];
+
+</%perl>
--- /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 `data age' query.
+
+
+</%doc>
+
+<%args>
+$quri
+$dbh
+</%args>
+
+<%once>
+
+</%once>
+
+<%perl>
+my $now= time;
+
+my $row;
+my $sth= $dbh->prepare("SELECT archipelago, islandid, islandname, timestamp
+ FROM uploads NATURAL JOIN islands
+ ORDER BY archipelago, islandid");
+$sth->execute();
+
+</%perl>
+
+<&| script &>
+ da_pageload= Date.now();
+</&script>
+
+<h1>Market data age</h1>
+
+<table id="ts_table">
+<tr>
+<th>Archipelago
+<th>Island
+<th>Age
+</tr>
+% my %da_ages;
+% my %ts_sortkeys;
+% $da_ages{'id_loaded'}= 0;
+% my $rowix= 0;
+% while ($row=$sth->fetchrow_hashref) {
+% my $rowid= "id_$row->{'islandid'}";
+% my $cellid= "c$rowid";
+% my $age= $now - $row->{'timestamp'};
+% $ts_sortkeys{'0'}{$rowid}= $row->{'archipelago'};
+% $ts_sortkeys{'1'}{$rowid}= $row->{'islandname'};
+% $da_ages{$rowid}= $age;
+<tr id=<% $rowid %> class="<% 'datarow'.($rowix & 1) %>"
+ > <td><% $row->{'archipelago'} |h
+ %> <td><% $row->{'islandname'} |h
+ %> <td id="<% $cellid %>"><% prettyprint_age($age) %> </tr>
+% $rowix++;
+% }
+</table>
+
+<& SELF:dataages, id2age => \%da_ages, elemidprefix => "'c'+" &>
+<%method dataages>
+<%args>
+ $id2age
+ $elemidprefix => ''
+</%args>
+<&| script &>
+ function da_Refresh() {
+ var now= Date.now();
+ debug('updating now='+now);
+ for (var ageid in da_ages) {
+ var oldage= da_ages[ageid];
+ var el= document.getElementById(<% $elemidprefix %>ageid);
+ var age= oldage + (now - da_pageload) / 1000;
+ var newhtml= <% meta_prettyprint_age('age','Math.floor','+') %>;
+ el.innerHTML= newhtml;
+ }
+ }
+ da_ages= <% to_json_protecttags($id2age) %>;
+ window.setInterval(da_Refresh, 10000);
+ register_onload(da_Refresh);
+</&>
+</%method>
+
+<&| tabsort, table => 'ts_table', rowclass => 'datarow', cols => [
+ {}, {},
+ { DoReverse => 1,
+ Numeric => 1,
+ SortKey => "da_ages[rowid]" }]
+ &>
+ ts_sortkeys= <% to_json_protecttags(\%ts_sortkeys) %>;
+</&tabsort>
+
+<p>
+Time since this page loaded:
+<span id="cid_loaded">(not known; times above not updating)</span>
+
+<form action="lookup" method="get">
+<input type=submit name=submit value="Reload">
+<& "lookup:formhidden", ours => sub { 0; } &>
+</form>
+
+<%init>
+use POSIX;
+use CommodsWeb;
+</%init>
--- /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 `commodity' query.
+
+
+</%doc>
+<%args>
+$quri
+$dbh
+$commodid => undef;
+$commodstring => '';
+$prselector
+$someresults
+$emsgokorprint
+</%args>
+
+<%perl>
+my $emsg;
+my ($commodname,$cmid);
+
+my $qa= \%ARGS;
+</%perl>
+
+<h1>Commodity enquiry</h1>
+
+% $prselector->('BuySell');
+% $prselector->('ShowBlank');
+
+<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)= @_; }
+ &>
+ 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/; };
+<& "lookup:formhidden", ours => $ours &>
+
+</form>
+
+%#========== results ==========
+<%perl>
+
+$emsgokorprint->($emsg) or $cmid=undef;
+return unless defined $cmid;
+$someresults->();
+
+#---------- actually compute the results and print them ----------
+
+foreach my $bs (split /_/, $ARGS{BuySell}) {
+ $bs =~ m/^(buy|sell)$/ or die;
+ $bs= $1;
+ my ($ascdesc) = ($bs eq 'buy')
+ ? ('DESC')
+ : ('ASC');
+ my $joinkind= $ARGS{ShowBlank} ? 'LEFT OUTER JOIN' : 'INNER JOIN';
+ my $islands= $dbh->prepare(
+ "SELECT islands.islandid AS islandid, archipelago, islandname,
+ sum(qty) as tqty
+ FROM islands $joinkind $bs offers
+ ON islands.islandid == offers.islandid AND commodid == ?
+ GROUP BY islands.islandid
+ ORDER BY archipelago, islandname"
+ );
+
+ my $offers= $dbh->prepare(
+ "SELECT stallname, price, qty
+ FROM $bs NATURAL JOIN stalls
+ WHERE commodid = ? AND islandid = ?
+ ORDER BY price $ascdesc"
+ );
+
+</%perl>
+
+<h2>Offers to <% uc $bs |h %> <% $commodname |h %></h2>
+% $islands->execute($cmid);
+% my $island;
+% my %ts_sortkeys;
+% my $rowix= 0;
+% while ($island= $islands->fetchrow_hashref) {
+% if (!$rowix) {
+<table id="<% $bs %>_table">
+<tr>
+<th colspan=3>
+<th colspan=2>Prices
+<th colspan=3>Quantity at price
+<tr id="<% $bs %>_table_thr">
+<th>Archipelago
+<th>Island
+<th>Stall(s)
+<th>Best
+<th>Median
+<th>Best
+<th>+/-10%
+<th>Any
+</tr>
+% }
+% my $islandid= $island->{'islandid'};
+% $offers->execute($cmid, $islandid);
+% my ($offer, $bestprice, $marginal, @beststalls);
+% my $tqty= $island->{'tqty'};
+% my $cqty= '';
+% my $bestqty= '';
+% my $approxqty= '';
+% my $median= '-';
+% while ($offer= $offers->fetchrow_hashref) {
+% my $price= $offer->{'price'};
+% my $qty= $offer->{'qty'};
+% length $bestqty or $bestprice= $price;
+% if ($price == $bestprice) {
+% $bestqty += $qty;
+% push @beststalls, $offer->{'stallname'};
+% }
+% $cqty += $qty;
+% if ($cqty*2 >= $tqty && $median eq '-') {
+% $median= $price;
+% }
+% if ($bestprice*9 <= $price*10 and
+% $price*10 <= $bestprice*11) {
+% $approxqty += $qty;
+% }
+% }
+% my $stallname;
+%
+% my $rowid= "id_${bs}_$islandid";
+% my $s= [ ];
+%
+% $s->[2]= sprintf "%06d", scalar @beststalls;
+% if (!@beststalls) {
+% $stallname= '-';
+% } elsif (@beststalls==1) {
+% $stallname= $beststalls[0];
+% $s->[2] .= " $stallname";
+% } else {
+% $stallname= sprintf "%d offers", scalar @beststalls;
+% }
+%
+% $cqty == $tqty or die "$bs $cqty $tqty $cmid $islandid ";
+<tr id=<% $rowid %> class="<% 'datarow'.($rowix & 1) %>">
+ <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 %>
+</tr>
+% for my $cix (0..$#$s) {
+% $ts_sortkeys{$cix}{$rowid}= $s->[$cix];
+% }
+% $rowix++;
+% }
+% if ($rowix) {
+</table>
+
+<&| tabsort, table => "${bs}_table", sortkeys => "${bs}_sortkeys",
+ throw => "${bs}_table_thr", rowclass => 'datarow', cols => [
+ {}, {},
+ { DoReverse => 1 },
+ { DoReverse => 1, Numeric => 1, MapFn => "ts_Pricemap_${bs}" },
+ { DoReverse => 1, Numeric => 1, MapFn => "ts_Pricemap_${bs}" },
+ { DoReverse => 1, Numeric => 1 },
+ { DoReverse => 1, Numeric => 1 },
+ { DoReverse => 1, Numeric => 1 },
+ ] &>
+ <% $bs %>_sortkeys= <% to_json_protecttags(\%ts_sortkeys) %>;
+ function ts_Pricemap_<% $bs %>(price) {
+ if (price=='-') { return <% $bs eq 'buy' ? '-1' : '99999999' %>; }
+ return price;
+ }
+</&tabsort>
+% } else {
+No offers.
+% }
+
+<%perl>
+}
+</%perl>
--- /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 `trade route' query.
+
+
+</%doc>
+<%args>
+$quri
+$dbh
+$prselector
+$routestring => '';
+$someresults
+$emsgokorprint
+</%args>
+
+<%perl>
+my $emsg;
+my @archipelagoes;
+my @islandids;
+my %islandid2;
+
+my $qa= \%ARGS;
+
+my $be_post;
+my $startform= sub {
+ ($be_post)= @_;
+</%perl>
+<form action="<% $quri->() |h %>" method="<% $be_post ? 'post' : 'get' %>">
+<%perl>
+};
+my $goupdate= sub { $be_post ? 'Update' : 'Go' };
+
+</%perl>
+
+<h1>Specify route</h1>
+
+% $prselector->('ShowStalls');
+
+%#---------- textbox, user enters route as string ----------
+% if (!$qa->{Dropdowns}) {
+
+Enter route (islands, or archipelagoes, separated by |s or commas;
+ abbreviations are OK):<br>
+
+% $startform->($routestring =~ m/\S/);
+
+<&| qtextstring, qa => $qa, dbh => $dbh,
+ thingstring => 'routestring', emsgstore => \$emsg,
+ perresult => sub {
+ my ($canonname, $island, $arch) = @_;
+ push @islandids, $island;
+ push @archipelagoes, defined $island ? undef : $arch;
+ }
+ &>
+ size=80
+</&>
+
+% } 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();
+
+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>
+
+</table>
+
+% } #---------- 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]/; };
+<& "lookup:formhidden", ours => $ours &>
+
+<%perl>
+#========== results ==========
+
+$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;
+}
+
+</%perl>
+
+% if (@islandids) {
+% $someresults->('Relevant trades');
+<& routetrade,
+ dbh => $dbh,
+ islandids => \@islandids,
+ archipelagoes => \@archipelagoes,
+ qa => $qa
+ &>
+</form>
+% }
--- /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 is the core trade planner for a specific route.
+
+
+</%doc>
+<%args>
+$dbh
+@islandids
+@archipelagoes
+$qa
+</%args>
+<&| script &>
+ da_pageload= Date.now();
+</&script>
+
+<%perl>
+
+my $now= time;
+my $loss_per_league= 1e-7;
+
+my @flow_conds;
+my @query_params;
+my %dists;
+
+my $sd_condition= sub {
+ my ($bs, $ix) = @_;
+ my $islandid= $islandids[$ix];
+ if (defined $islandid) {
+ return "${bs}.islandid = $islandid";
+ } else {
+ push @query_params, $archipelagoes[$ix];
+ return "${bs}_islands.archipelago = ?";
+ }
+};
+
+my %islandpair;
+# $islandpair{$a,$b}= [ $start_island_ix, $end_island_ix ]
+
+my $specific= !grep { !defined $_ } @islandids;
+my $confusing= 0;
+
+foreach my $src_i (0..$#islandids) {
+ my $src_isle= $islandids[$src_i];
+ my $src_cond= $sd_condition->('sell',$src_i);
+ my @dst_conds;
+ foreach my $dst_i ($src_i..$#islandids) {
+ my $dst_isle= $islandids[$dst_i];
+ my $dst_cond= $sd_condition->('buy',$dst_i);
+ if ($dst_i==$src_i and !defined $src_isle) {
+ # we always want arbitrage, but mentioning an arch
+ # once shouldn't produce intra-arch trades
+ $dst_cond=
+ "($dst_cond AND sell.islandid = buy.islandid)";
+ }
+ push @dst_conds, $dst_cond;
+
+ if ($specific && !$confusing &&
+ # With a circular route, do not carry goods round the loop
+ !(($src_i==0 || $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 ];
+ }
+ }
+ }
+ push @flow_conds, "$src_cond AND (
+ ".join("
+ OR ",@dst_conds)."
+ )";
+}
+
+my $stmt= "
+ SELECT sell_islands.islandname org_name,
+ sell_islands.islandid org_id,
+ sell.price org_price,
+ sell.qty org_qty_stall,
+ sell_stalls.stallname org_stallname,
+ sell.stallid org_stallid,
+ sell_uploads.timestamp org_timestamp,
+ buy_islands.islandname dst_name,
+ buy_islands.islandid dst_id,
+ buy.price dst_price,
+ buy.qty dst_qty_stall,
+ buy_stalls.stallname dst_stallname,
+ buy.stallid dst_stallid,
+ buy_uploads.timestamp dst_timestamp,
+".($qa->{ShowStalls} ? "
+ sell.qty org_qty_agg,
+ buy.qty dst_qty_agg,
+" : "
+ (SELECT sum(qty) FROM sell AS sell_agg
+ WHERE sell_agg.commodid = commods.commodid
+ AND sell_agg.islandid = sell.islandid
+ AND sell_agg.price = sell.price) org_qty_agg,
+ (SELECT sum(qty) FROM buy AS buy_agg
+ WHERE buy_agg.commodid = commods.commodid
+ AND buy_agg.islandid = buy.islandid
+ AND buy_agg.price = buy.price) dst_qty_agg,
+")."
+ commods.commodname commodname,
+ commods.commodid commodid,
+ commods.unitmass unitmass,
+ commods.unitvolume unitvolume,
+ dist dist,
+ buy.price - sell.price unitprofit
+ FROM commods
+ JOIN sell ON commods.commodid = sell.commodid
+ JOIN buy ON commods.commodid = buy.commodid
+ JOIN islands AS sell_islands ON sell.islandid = sell_islands.islandid
+ JOIN islands AS buy_islands ON buy.islandid = buy_islands.islandid
+ JOIN uploads AS sell_uploads ON sell.islandid = sell_uploads.islandid
+ JOIN uploads AS buy_uploads ON buy.islandid = buy_uploads.islandid
+ JOIN stalls AS sell_stalls ON sell.stallid = sell_stalls.stallid
+ JOIN stalls AS buy_stalls ON buy.stallid = buy_stalls.stallid
+ JOIN dists ON aiid = sell.islandid AND biid = buy.islandid
+ WHERE (
+ ".join("
+ OR ", @flow_conds)."
+ )
+ AND buy.price > sell.price
+ ORDER BY org_name, dst_name, commodname, unitprofit DESC,
+ org_price, dst_price DESC,
+ org_stallname, dst_stallname
+ ";
+
+my $sth= $dbh->prepare($stmt);
+$sth->execute(@query_params);
+my @flows;
+
+my $distquery= $dbh->prepare("
+ SELECT dist FROM dists WHERE aiid = ? AND biid = ?
+ ");
+my $distance= sub {
+ my ($from,$to)= @_;
+ my $d= $dists{$from}{$to};
+ return $d if defined $d;
+ $distquery->execute($from,$to);
+ $d = $distquery->fetchrow_array();
+ defined $d or die "$from $to ?";
+ $dists{$from}{$to}= $d;
+ return $d;
+};
+
+my @cols= ({ NoSort => 1 });
+
+my $addcols= sub {
+ my $base= shift @_;
+ foreach my $name (@_) {
+ my $col= { Name => $name, %$base };
+ $col->{Numeric}=1 if !$col->{Text};
+ push @cols, $col;
+ }
+};
+
+if ($qa->{ShowStalls}) {
+ $addcols->({ Text => 1 }, qw(
+ org_name org_stallname
+ dst_name dst_stallname
+ ));
+} else {
+ $addcols->({Text => 1 }, qw(
+ org_name dst_name
+ ));
+}
+$addcols->({ Text => 1 }, qw(commodname));
+$addcols->({ DoReverse => 1 },
+ qw( org_price org_qty_agg dst_price dst_qty_agg
+ ));
+$addcols->({ DoReverse => 1, SortColKey => 'MarginSortKey' },
+ qw( Margin
+ ));
+$addcols->({ DoReverse => 1 },
+ qw( unitprofit dist MaxQty
+ MaxCapital MaxProfit
+ ));
+
+</%perl>
+
+% if ($qa->{'debug'}) {
+<pre>
+<% $stmt |h %>
+<% join(' | ',@query_params) |h %>
+</pre>
+% }
+
+<& dumptable:start, qa => $qa, sth => $sth &>
+% {
+% my $got;
+% while ($got= $sth->fetchrow_hashref()) {
+<%perl>
+
+ my $f= $flows[$#flows];
+ if ( !$f ||
+ $qa->{ShowStalls} ||
+ grep { $f->{$_} ne $got->{$_} }
+ qw(org_id org_price dst_id dst_price commodid)
+ ) {
+ # Make a new flow rather than adding to the existing one
+
+ $f= {
+ Ix => scalar(@flows),
+ Var => "f".@flows,
+ %$got
+ };
+ $f->{"org_stallid"}= $f->{"dst_stallid"}= 'all'
+ if !$qa->{ShowStalls};
+ push @flows, $f;
+ }
+ foreach my $od (qw(org dst)) {
+ $f->{"${od}Stalls"}{
+ $got->{"${od}_stallname"}
+ } =
+ $got->{"${od}_qty_stall"}
+ ;
+ }
+
+</%perl>
+<& dumptable:row, qa => $qa, sth => $sth, row => $f &>
+% }
+<& dumptable:end, qa => $qa &>
+% }
+
+<%perl>
+
+if (!@flows) {
+ print 'No profitable trading opportunities were found.';
+ return;
+}
+
+foreach my $f (@flows) {
+
+ $f->{MaxQty}= $f->{'org_qty_agg'} < $f->{'dst_qty_agg'}
+ ? $f->{'org_qty_agg'} : $f->{'dst_qty_agg'};
+ $f->{MaxProfit}= $f->{MaxQty} * $f->{'unitprofit'};
+ $f->{MaxCapital}= $f->{MaxQty} * $f->{'org_price'};
+
+ $f->{MarginSortKey}= sprintf "%d",
+ $f->{'dst_price'} * 10000 / $f->{'org_price'};
+ $f->{Margin}= sprintf "%3.1f%%",
+ $f->{'dst_price'} * 100.0 / $f->{'org_price'} - 100.0;
+
+ $f->{ExpectedUnitProfit}=
+ $f->{'dst_price'} * (1.0 - $loss_per_league) ** $f->{'dist'}
+ - $f->{'org_price'};
+
+ $dists{'org_id'}{'dst_id'}= $f->{'dist'};
+
+ my @uid= $f->{commodid};
+ foreach my $od (qw(org dst)) {
+ push @uid,
+ $f->{"${od}_id"},
+ $f->{"${od}_price"};
+ push @uid,
+ $f->{"${od}_stallid"}
+ if $qa->{ShowStalls};
+ }
+ $f->{UidLong}= join '_', @uid;
+
+ my $base= 31;
+ my $cmpu= '';
+ map {
+ my $uue= $_;
+ my $first= $base;
+ do {
+ my $this= $uue % $base;
+print STDERR "uue=$uue this=$this ";
+ $uue -= $this;
+ $uue /= $base;
+ $this += $first;
+ $first= 0;
+ $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;
+ } while ($uue);
+ $cmpu;
+ } @uid;
+ $f->{UidShort}= $cmpu;
+
+ if ($qa->{'debug'}) {
+ my @outuid;
+ $_= $f->{UidShort};
+ my $mul;
+ while (m/./) {
+ my $v= m/^[a-z]/ ? ord($&)-ord('a') :
+ m/^[A-Z]/ ? ord($&)-ord('A')+26 :
+ m/^[0-9]/ ? ord($&)-ord('0')+52 :
+ die "$_ ?";
+ if ($v >= $base) {
+ push @outuid, 0;
+ $v -= $base;
+ $mul= 1;
+#print STDERR "(next)\n";
+ }
+ die "$f->{UidShort} $_ ?" unless defined $mul;
+ $outuid[$#outuid] += $v * $mul;
+
+#print STDERR "$f->{UidShort} $_ $& v=$v mul=$mul ord()=".ord($&).
+# "[vs.".ord('a').",".ord('A').",".ord('0')."]".
+# " outuid=@outuid\n";
+
+ $mul *= $base;
+ s/^.//;
+ }
+ my $recons_long= join '_', @outuid;
+ $f->{UidLong} eq $recons_long or
+ die "$f->{UidLong} = $f->{UidShort} = $recons_long ?";
+ }
+
+ if (defined $qa->{"R$f->{UidShort}"} &&
+ !defined $qa->{"T$f->{UidShort}"}) {
+ $f->{Suppress}= 1;
+ }
+
+}
+</%perl>
+
+% my $optimise= $specific && !$confusing && @islandids>1;
+% if (!$optimise) {
+
+<p>
+% if (@islandids<=1) {
+Route is trivial.
+% }
+% if (!$specific) {
+Route contains archipelago(es), not just specific islands.
+% }
+% if ($confusing) {
+Route is complex - it visits the same island several times
+and isn't a simple loop.
+% }
+Therefore, optimal voyage trade plan not calculated.
+
+% } else { # ========== OPTMISATION ==========
+<%perl>
+
+my $cplex= "
+Maximize
+
+ totalprofit:
+ ".(join " +
+ ", map {
+ sprintf "%.20f %s", $_->{ExpectedUnitProfit}, $_->{Var}
+ } @flows)."
+
+Subject To
+";
+
+my %avail_csts;
+foreach my $flow (@flows) {
+ if ($flow->{Suppress}) {
+ $cplex .= "
+ $flow->{Var} = 0
+";
+ next;
+ }
+ foreach my $od (qw(org dst)) {
+ my $cstname= join '_', (
+ 'avail',
+ $flow->{'commodid'},
+ $od,
+ $flow->{"${od}_id"},
+ $flow->{"${od}_price"},
+ $flow->{"${od}_stallid"},
+ );
+
+ push @{ $avail_csts{$cstname}{Flows} }, $flow->{Var};
+ $avail_csts{$cstname}{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";
+}
+
+$cplex.= "
+Bounds
+ ".(join "
+ ", map { "$_->{Var} >= 0" } @flows)."
+
+End
+";
+
+if ($qa->{'debug'}) {
+</%perl>
+<pre>
+<% $cplex |h %>
+</pre>
+<%perl>
+}
+
+{
+ my $input= pipethrough_prep();
+ print $input $cplex or die $!;
+ my $output= pipethrough_run_along($input, undef, 'glpsol',
+ qw(glpsol --cpxlp /dev/stdin -o /dev/stdout));
+ print "<pre>\n" if $qa->{'debug'};
+ my $found_section= 0;
+ my $glpsol_out= '';
+ 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;
+ $found_section= 1;
+ next;
+ }
+ next unless $found_section==1;
+ next if m/^[- ]+$/;
+ if (!/\S/) {
+ $found_section= 2;
+ next;
+ }
+ my ($ix, $qty) =
+ m/^\s*\d+\s+f(\d+)\s+\S+\s+(\d+)\s/ or die "$_ ?";
+ my $flow= $flows[$ix] or die;
+ $flow->{OptQty}= $qty;
+ $flow->{OptProfit}= $flow->{'unitprofit'} * $qty;
+ $flow->{OptCapital}= $flow->{OptQty} * $flow->{'org_price'};
+ }
+ print "</pre>\n" if $qa->{'debug'};
+ my $prerr= "\n=====\n$cplex\n=====\n$glpsol_out\n=====\n ";
+ pipethrough_run_finish($output,$prerr);
+ die $prerr unless $found_section;
+};
+
+$addcols->({ DoReverse => 1 }, qw(
+ OptQty
+ ));
+$addcols->({ Total => 0, DoReverse => 1 }, qw(
+ OptCapital OptProfit
+ ));
+
+</%perl>
+
+% } # ========== OPTIMISATION ==========
+
+% my %ts_sortkeys;
+% {
+% my $cdspan= $qa->{ShowStalls} ? ' colspan=2' : '';
+% my $cdstall= $qa->{ShowStalls} ? '<th>Stall</th>' : '';
+<table id="trades" rules=groups>
+<colgroup span=1>
+<colgroup span=2>
+<% $qa->{ShowStalls} ? '<colgroup span=2>' : '' %>
+<colgroup span=1>
+<colgroup span=2>
+<colgroup span=2>
+<colgroup span=2>
+<colgroup span=1>
+<colgroup span=3>
+% if ($optimise) {
+<colgroup span=3>
+% }
+<tr class="spong">
+<th>
+<th<% $cdspan %>>Collect
+<th<% $cdspan %>>Deliver
+<th>
+<th colspan=2>Collect
+<th colspan=2>Deliver
+<th colspan=2>Profit
+<th colspan=1>
+<th colspan=3>Max
+% if ($optimise) {
+<th colspan=3>Planned
+% }
+
+<tr>
+<th>
+<th>Island <% $cdstall %>
+<th>Island <% $cdstall %>
+<th>Commodity
+<th>Price
+<th>Qty
+<th>Price
+<th>Qty
+<th>Margin
+<th>Unit
+<th>Dist
+<th>Qty
+<th>Capital
+<th>Profit
+% if ($optimise) {
+<th>Qty
+<th>Capital
+<th>Profit
+% }
+% }
+
+<tr id="trades_sort">
+% foreach my $col (@cols) {
+<th>
+% }
+
+% foreach my $flowix (0..$#flows) {
+% my $flow= $flows[$flowix];
+% my $rowid= "id_row_$flow->{UidShort}";
+<tr id="<% $rowid %>" class="datarow<% $flowix & 1 %>">
+<td><input type=hidden name=R<% $flow->{UidShort} %> value="">
+ <input type=checkbox name=T<% $flow->{UidShort} %> value=""
+ <% $flow->{Suppress} ? '' : 'checked' %> >
+% foreach my $ci (1..$#cols) {
+% my $col= $cols[$ci];
+% my $v= $flow->{$col->{Name}};
+% $col->{Total} += $v if defined $col->{Total};
+% $v='' if !$col->{Text} && !$v;
+% my $sortkey= $col->{SortColKey} ?
+% $flow->{$col->{SortColKey}} : $v;
+% $ts_sortkeys{$ci}{$rowid}= $sortkey;
+<td <% $col->{Text} ? '' : 'align=right' %>><% $v |h %>
+% }
+% }
+<tr id="trades_total">
+<th>
+<th colspan=2>Total
+% foreach my $ci (3..$#cols) {
+% my $col= $cols[$ci];
+<td align=right>
+% if (defined $col->{Total}) {
+<% $col->{Total} |h %>
+% }
+% }
+</table>
+
+<&| tabsort, cols => \@cols, table => 'trades', rowclass => 'datarow',
+ throw => 'trades_sort', tbrow => 'trades_total' &>
+ ts_sortkeys= <% to_json_protecttags(\%ts_sortkeys) %>;
+</&tabsort>
+
+<input type=submit name=update value="Update">
+
+% if ($optimise) { # ========== TRADING PLAN ==========
+%
+% my $iquery= $dbh->prepare('SELECT islandname FROM islands
+% WHERE islandid = ?');
+% my %da_ages;
+% my $total_total= 0;
+% my $total_dist= 0;
+%
+<h1>Voyage trading plan</h1>
+<table rules=groups>
+% foreach my $i (0..$#islandids) {
+<tbody>
+<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 {
+<strong>Sail to <% $islandname |h %></strong>
+- <% $this_dist |h %> leagues </td>
+% }
+<%perl>
+ my $age_reported= 0;
+ my %flowlists;
+ foreach my $od (qw(org dst)) {
+ foreach my $f (@flows) {
+ next if $f->{Suppress};
+ next unless $f->{"${od}_id"} == $islandids[$i];
+ next unless $f->{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'));
+ my $price= $f->{"${od}_price"};
+ my $stallname= $f->{"${od}_stallname"};
+ my $todo= \$flowlists{$od}{
+ $f->{'commodname'},
+ (sprintf "%07d", ($od eq 'dst' ?
+ 9999999-$price : $price)),
+ $stallname
+ };
+ $$todo= {
+ Qty => 0,
+ orgArbitrage => 0,
+ dstArbitrage => 0,
+ } unless $$todo;
+ $$todo->{'commodname'}= $f->{'commodname'};
+ $$todo->{'stallname'}= $stallname;
+ $$todo->{Price}= $price;
+ $$todo->{Timestamp}= $f->{"${od}_timestamp"};
+ $$todo->{Qty} += $f->{OptQty};
+ $$todo->{Total}= $$todo->{Price} * $$todo->{Qty};
+ $$todo->{Stalls}= $f->{"${od}Stalls"};
+ $$todo->{"${od}Arbitrage"}= 1 if $arbitrage;
+ }
+ }
+
+ my $total;
+ my $dline= 0;
+ my $show_flows= sub {
+ my ($od,$arbitrage,$collectdeliver) = @_;
+</%perl>
+%
+% my $todo= $flowlists{$od};
+% return unless $todo;
+% foreach my $tkey (sort keys %$todo) {
+% my $t= $todo->{$tkey};
+% next if $t->{"${od}Arbitrage"} != $arbitrage;
+% if (!$age_reported++) {
+% my $age= $now - $t->{Timestamp};
+% my $cellid= "da_${i}";
+% $da_ages{$cellid}= $age;
+<td colspan=3>\
+(Data age: <span id="<% $cellid %>"><% prettyprint_age($age) %></span>)
+% } elsif (!defined $total) {
+% $total= 0;
+<tbody>
+% }
+% $total += $t->{Total};
+% my $span= 0 + keys %{ $t->{Stalls} };
+% my $td= "td rowspan=$span";
+<tr class="datarow<% $dline %>">
+<<% $td %>><% $collectdeliver %>
+<<% $td %>><% $t->{'commodname'} |h %>
+%
+% my @stalls= sort keys %{ $t->{Stalls} };
+% my $pstall= sub {
+% my $name= $stalls[$_[0]];
+<td><% $name |h %>
+% };
+%
+% $pstall->(0);
+<<% $td %> align=right><% $t->{Price} |h %> poe ea.
+<<% $td %> align=right><% $t->{Qty} |h %> unit(s)
+<<% $td %> align=right><% $t->{Total} |h %> total
+%
+% foreach my $stallix (1..$#stalls) {
+<tr class="datarow<% $dline %>">
+% $pstall->($stallix);
+% }
+%
+% $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);
+
+}
+</%perl>
+<tbody><tr>
+<td colspan=2>Total distance: <% $total_dist %> leagues.
+<td colspan=3 align=right>Overall net cash flow
+<td align=right><strong><%
+ $total_total < 0 ? -$total_total." loss" : $total_total." gain"
+ %></strong>
+</table>
+<& query_age:dataages, id2age => \%da_ages &>
+%
+% } # ========== TRADING PLAN ==========
+
+<%init>
+use CommodsWeb;
+use Commods;
+</%init>
--- /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 wraps Javascript which is to be embedded in HTML
+ pages to deal with some of the bizarre quoting problems and behaviours
+ in Javascript <script> tags. See also:
+ http://javascript.about.com/library/blxhtml.htm
+ http://www.htmlhelp.com/tools/validator/problems.html#script
+
+</%doc>
+<script type="text/javascript">
+<!--
+<% $ct %>
+// -->
+</script>
+<%init>
+my $ct= $m->content;
+
+die "bad script content $&"
+ if $ct =~ m,\<\/|--\>,;
+</%init>
--- /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 allows visitors to the YARRG website to download
+ the YARRG website's source code.
+
+
+</%doc><%flags>
+inherit => undef
+</%flags><%perl>
+use IO::Pipe;
+use CommodsWeb;
+
+$r->content_type('application/octet-stream');
+$m->flush_buffer();
+
+$ENV{'YPPSC_YARRG_SRCBASE'}= sourcebasedir();
+my $pipe= new IO::Pipe or die $!;
+my $pid= fork(); defined $pid or die $!;
+if (!$pid) {
+ $pipe->writer();
+ exec '/bin/sh','-c','
+ cd -P "$YPPSC_YARRG_SRCBASE"
+ (
+ git-ls-files -z;
+ git-ls-files -z --others --exclude-from=.gitignore;
+ if test -d .git; then find .git -print0; fi
+ ) | (
+ cpio -Hustar -o --quiet -0 -R 1000:1000 || \
+ cpio -Hustar -o --quiet -0
+ ) | gzip
+ ';
+ die $!;
+}
+$pipe->reader();
+
+my ($d, $l);
+while ($l= read $pipe, $d, 65536) {
+ print $d;
+ $m->flush_buffer();
+}
+waitpid $pid,0;
+defined $l or die "read pipe $!";
+$pipe->error and die "pipe error $!";
+close $pipe;
+# deliberately ignore errors
+
+</%perl>
--- /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 Javascript for sorting tables in
+ DHTML.
+
+
+</%doc>
+
+<%args>
+$table => 'ts_table'
+$sortkeys => 'ts_sortkeys'
+$throw => undef
+$tbrow => undef
+$rowclass => undef
+$cols
+</%args>
+
+<%doc>
+ Numeric
+ SortKey
+ MapFn
+ NoSort
+ DoReverse
+</%doc>
+
+<&| script &>
+
+% print $m->content();
+
+% my $sortfn= "ts_sort__$table";
+function <% $sortfn %>(compar) {
+ debug('sorting compar='+compar);
+ var table= document.getElementById('<% $table %>');
+ var firstrow= table.getElementsByTagName('tr').item(0);
+ var tbody= firstrow.parentNode
+ var rows= tbody.childNodes
+ var newrows= new Array;
+ var finalrows= new Array;
+ var rowix= 0;
+% if (defined $throw) {
+ for (; rowix < rows.length; rowix++) {
+ var row= rows.item(rowix);
+ if (row.id == '<% $throw %>') break;
+ debug('skip row '+rowix+' [[ '+row+' ]] id='+row.id);
+ }
+ rowix++;
+% }
+ for (; rowix < rows.length; rowix++) {
+ var row= rows.item(rowix);
+% if (defined $tbrow) {
+ if (row.id == '<% $tbrow %>') break;
+% }
+ if (!row.id) { debug('noid row '+rowix+' [[ '+row+' ]]'); continue; }
+ if (row.tagName != 'TR') {
+ debug('no-tr row '+rowix+' tagName='+row.tagName+' [[ '+row+' ]]');
+ continue;
+ }
+ debug('process row '+rowix+' [[ '+row+' ]] id='+row.id);
+ newrows.push(row);
+ }
+ for (; rowix < rows.length; rowix++) {
+ var row= rows.item(rowix);
+ finalrows.push(row);
+ debug('final row '+rowix+' [[ '+row+' ]]');
+ }
+ newrows.sort(compar);
+% if (defined $rowclass) {
+ for (var rowix=0; rowix < newrows.length; rowix++) {
+ var row= newrows[rowix];
+ var classname= '<% $rowclass %>'+(rowix % 2);
+ debug('fix row '+rowix+' class '+classname);
+ row.className= classname;
+ }
+% }
+ newrows= newrows.concat(finalrows);
+ for (var rowix=0; rowix < newrows.length; rowix++) {
+ var row= newrows[rowix];
+ debug('add row '+rowix+' [[ '+row+' ]]');
+ tbody.appendChild(row);
+ }
+}
+
+% my %add_heads;
+% foreach my $cix (0..$#$cols) {
+% my $col= $cols->[$cix];
+% my $thhtml= '';
+% next if $col->{NoSort};
+
+% my $mapfn= "ts_compar${cix}_map__$table";
+function <% $mapfn %>(rowelement) {
+ var rowid = rowelement.id;
+% if ($col->{SortKey}) {
+ return <% $col->{SortKey} %>;
+% } else {
+% my $sk= "$sortkeys"."[$cix][rowid]";
+% if ($col->{MapFn}) {
+ return <% $col->{MapFn} %>(<% $sk %>);
+% } else {
+ return <% $sk %>;
+% }
+% }
+}
+
+% my $comparefn= "ts_compar${cix}_cmp0__$table";
+function <% $comparefn %>(a,b) {
+ var a_key = <% $mapfn %>(a);
+ var b_key = <% $mapfn %>(b);
+% if ($col->{Numeric}) {
+ return a_key - b_key
+% } else {
+ if (a_key < b_key) return -1;
+ if (a_key > b_key) return +1;
+ return 0;
+% }
+}
+
+% foreach my $reverse (qw(1 0)) {
+% my $tcomparefn= "ts_compar${cix}_cmp${reverse}__$table";
+% if ($reverse) {
+% next unless $col->{DoReverse};
+function <% $tcomparefn %>(a,b) { return -<% $comparefn %>(a,b); }
+% }
+% $thhtml .= "<a href=\"javascript:$sortfn($tcomparefn)\">".
+% ($reverse ? '∨' : '∧'). '</a>';
+% }
+% if (length $thhtml) {
+% $add_heads{$cix}= $thhtml;
+% }
+% }
+
+function ts_onload__<% $table %>() {
+ var ts_add_heads= <% to_json_protecttags(\%add_heads) %>;
+ var ctr= document.getElementById('<% defined($throw) ? $throw : $table %>');
+ var firstth= ctr.getElementsByTagName('th').item(0);
+ var thlist= firstth.parentNode.getElementsByTagName('th');
+ debug('thlist='+thlist);
+ debug('thlist.item(2)=' + thlist.item(2));
+ for (var cix in ts_add_heads) {
+ var ah = ts_add_heads[cix];
+ debug('appending to cix='+cix+' ah='+ah);
+ thlist.item(cix).innerHTML += ah;
+ }
+}
+
+register_onload(ts_onload__<% $table %>);
+</&>
--- /dev/null
+#!/usr/bin/perl
+#
+# Normally run from
+# update-master-info
+#
+# usage: ./yppedia-chart-parser <Oceanname>
+# updates OCEAN-Oceanname.db and _ocean-<oceanname>.txt
+# from YPPedia (chart and ocean page) and source-info.txt
+
+# This is part of ypp-sc-tools, a set of third-party tools for assisting
+# players of Yohoho Puzzle Pirates.
+#
+# Copyright (C) 2009 Ian Jackson <ijackson@chiark.greenend.org.uk>
+#
+# This program is free software: you can redistribute it and/or modify
+# it under the terms of the GNU 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 General Public License for more details.
+#
+# You should have received a copy of the GNU 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.
+
+use strict (qw(vars));
+use warnings;
+
+use Graph::Undirected;
+use Commods;
+use CommodsDatabase;
+
+my $widists= Graph::Undirected->new();
+my $wiarchs= Graph::Undirected->new();
+my $wispr;
+my $dbspr;
+my @wiarchlabels;
+my %wiisland2node;
+my %winode2island;
+my %winode2lines;
+my %wiccix2arch;
+my $wialldists;
+my %wtisland2arch;
+
+my $dbdists;
+my %dbisland2arch;
+
+my @msgkinds= qw(change warning error);
+my %msgs;
+my %msgprinted;
+my %msgkindprinted;
+sub pmsg ($$) {
+ my $m= "$_[0]: $_[1]\n";
+ print DEBUG "D $m";
+ push @{ $msgs{$_[0]} }, $m;
+}
+sub warning ($) { pmsg("warning",$_[0]); }
+sub error ($) { pmsg("error", $_[0]); }
+sub change ($) { pmsg("change", $_[0]); }
+sub print_messages () {
+ foreach my $k (@msgkinds) {
+ my $ms= $msgs{$k};
+ next unless $ms;
+ foreach my $m (sort @$ms) {
+ next if $msgprinted{$m};
+ print $m or die $!;
+ $msgprinted{$m}++;
+ $msgkindprinted{$k}++;
+ }
+ }
+}
+sub progress ($) { print "($_[0])\n"; }
+
+my $stdin_chart=0;
+
+open DEBUG, ">/dev/null" or die $!;
+
+while (@ARGV) {
+ last unless $ARGV[0] =~ m/^-/;
+ $_= shift @ARGV;
+ last if m/^--$/;
+ if ($_ eq '--debug') {
+ open DEBUG, ">&STDOUT" or die $!;
+ select(DEBUG); $|=1; select(STDOUT);
+ } elsif ($_ eq '--stdin-chart') {
+ $stdin_chart=1;
+ } else {
+ die;
+ }
+}
+$|=1;
+
+@ARGV==1 or die;
+my $ocean= shift @ARGV;
+
+
+my $parity;
+sub nn_xy ($$) {
+ my ($x,$y) = @_;
+ my $tp= (0+$x ^ 0+$y) & 1;
+ defined $parity or $parity=$tp;
+ $tp==$parity or warning("line $.: parity error $x,$y is $tp not $parity");
+ my $n= "$_[0],$_[1]";
+ $winode2lines{$n}{$.}++;
+ return $n;
+}
+
+sub yppedia_chart_parse () {
+ # We don't even bother with tag soup; instead we do line-oriented parsing.
+
+ while (<OCEAN>) {
+ s/\<--.*--\>//g;
+ s/^\s*//; chomp; s/\s+$//; s/\s+/ /g;
+ s/\<\/?(?:b|em)\>//g;
+ s/\{\{chart\ style\|[^{}]*\}\}//gi;
+ next unless m/\{\{/; # only interested in chart template stuff
+
+ my ($x,$y, $arch,$island,$solid,$dirn);
+ my $nn= sub { return nn_xy($x,$y) };
+
+ if (($x,$y,$arch) =
+ m/^\{\{ chart\ label \|(\d+)\|(\d+)\| .*
+ (?: \<(?: big|center )\>)* \'+
+ (?: \[\[ | \{\{ )
+ [^][\']* \| ([^][\'|]+)\ archipelago
+ (?: \]\] | \}\} )
+ \'+ (?: \<\/(?: big|center )\>)* \}\}$/xi) {
+ printf DEBUG "%2d,%-2d arch %s\n", $x,$y,$arch;
+ push @wiarchlabels, [ $x,$y,$arch ];
+ } elsif (m/^\{\{ chart\ label \|\d+\|\d+\|
+ \<big\> \'+ \[\[ .* \b ocean \]\]/xi) {
+ } elsif (($x,$y,$island) =
+ m/^\{\{ chart\ island\ icon \|(\d+)\|(\d+)\|
+ ([^| ][^|]*[^| ]) \| .*\}\}$/xi) {
+ my $n= $nn->();
+ $wiisland2node{$island}= $n;
+ $winode2island{$n}= $island;
+ $widists->add_vertex($n);
+ $wiarchs->add_vertex($n);
+ printf DEBUG "%2d,%-2d island %s\n", $x,$y,$island;
+ } elsif (($solid,$x,$y,$dirn) =
+ m/^\{\{ chart\ league((?:\ solid)?) \|(\d+)\|(\d+)\|
+ ([-\/\\o]) \| .*\}\}$/xi) {
+ next if $dirn eq 'o';
+
+ my ($bx,$by) = ($x,$y);
+ if ($dirn eq '-') { $bx+=2; }
+ elsif ($dirn eq '\\') { $bx++; $by++; }
+ elsif ($dirn eq '/') { $x++; $by++; }
+ else { die; }
+
+ my $nb= nn_xy($bx,$by);
+ $widists->add_weighted_edge($nn->(), $nb, 1);
+ $wiarchs->add_edge($nn->(), $nb) if $solid;
+ $wiarchs->add_edge($nn->(), $nb) if $solid;
+
+ printf DEBUG "%2d,%-2d league %-6s %s %s\n", $x,$y,
+ $solid?'solid':'dotted', $dirn, $nb;
+ } elsif (
+ m/^\{\{ chart\ head \}\}$/xi
+ ) {
+ next;
+ } else {
+ warning("line $.: ignoring incomprehensible: $_");
+ }
+ }
+}
+
+sub yppedia_graphs_add_shortcuts () {
+ # We add edges between LPs we know about, as you can chart
+ # between them. Yppedia often lacks these edges.
+ #
+ foreach my $p ($widists->vertices) {
+ my ($ax,$ay) = $p =~ m/^(\d+)\,(\d+)$/ or die;
+ my $add_shortcut= sub {
+ my $q= sprintf "%d,%d", $ax+$_[0], $ay+$_[1];
+ return unless $widists->has_vertex($q);
+ return if $widists->has_edge($p,$q);
+ printf DEBUG "%-5s league-shortcut %-5s\n", $p, $q;
+ $widists->add_weighted_edge($p,$q,1);
+ };
+ $add_shortcut->( 2,0);
+ $add_shortcut->(+1,1);
+ $add_shortcut->(-1,1);
+ }
+}
+
+sub yppedia_graphs_prune_boring () {
+ # Prune the LP database by eliminating boring intermediate vertices
+ foreach my $delete ($widists->vertices()) {
+ next if exists $winode2island{$delete};
+ my @neigh= $widists->neighbours($delete);
+ next unless @neigh==2;
+ my $weight= 0;
+ map { $weight += $widists->get_edge_weight($delete, $_) } @neigh;
+ $widists->add_weighted_edge(@neigh, $weight);
+ $widists->delete_vertex($delete);
+ printf DEBUG "%-5s elide %5s %-5s %2d\n", $delete, @neigh, $weight;
+ }
+}
+
+sub yppedia_graphs_check () {
+ # Check that it's connected.
+ foreach my $cc ($widists->connected_components()) {
+ next if 2*@$cc > $widists->vertices();
+ my $m= "disconnected league point(s):";
+ foreach my $n (@$cc) {
+ $m .= "\n LP $n, def. yppedia line(s): ".
+ join(',', sort keys %{ $winode2lines{$n} });
+ }
+ warning($m);
+ }
+}
+
+sub yppedia_archs_sourceinfo () {
+ # Assign archipelagoes according to the source-info file
+ foreach my $arch (sort keys %{ $oceans{$ocean} }) {
+ foreach my $islename (sort keys %{ $oceans{$ocean}{$arch} }) {
+ my $islenode= $wiisland2node{$islename};
+ if (!defined $islenode) {
+ error("island $islename in source-info but not in WP map");
+ next;
+ }
+ my $ccix= $wiarchs->connected_component_by_vertex($islenode);
+ my $oldarch= $wiccix2arch{$ccix};
+ error("island in $arch in source-info".
+ " connected to $oldarch as well: $islename")
+ if defined $oldarch && $oldarch ne $arch;
+ printf DEBUG "%-5s force-island-arch cc%-2d %-10s %s\n",
+ $islenode, $ccix, $arch, $islename;
+ $wiccix2arch{$ccix}= $arch;
+ }
+ }
+}
+
+sub yppedia_archs_chart_labels () {
+ # Assign archipelago labels to groups of islands
+ #
+ foreach my $label (@wiarchlabels) {
+ my ($ax,$ay,$arch) = @$label;
+ my $best_d2= 9999999;
+ my $best_n;
+# print DEBUG "$ax,$ay arch-island-search $arch\n";
+ $ay += 1; $ax += 2; # coords are rather to the top left of label
+ foreach my $vertex ($wiarchs->vertices()) {
+ next unless exists $winode2island{$vertex};
+ my $ccix= $wiarchs->connected_component_by_vertex($vertex);
+ my @cc= $wiarchs->connected_component_by_index($ccix);
+ my ($vx,$vy) = split /,/, $vertex;
+ my $d2= ($vx-$ax)*($vx-$ax) + ($vy-$ay)*($vy-$ay);
+ my $cmp= $best_d2 <=> $d2;
+ printf DEBUG "%2d,%-2d arch-island-search %5s d2=%4d cc%-2d".
+ " #cc=%2d cmp=%2d %s\n",
+ $ax,$ay, $vertex, $d2, $ccix, scalar(@cc), $cmp,
+ $winode2island{$vertex};
+ next unless $cmp > 0;
+ $best_n= $vertex;
+ $best_d2= $d2;
+ }
+ die 'no island vertices?!' unless defined $best_n;
+ my $ccix= $wiarchs->connected_component_by_vertex($best_n);
+ printf DEBUG
+ "%2d,%-2d arch-island-select %-5s d2=%4d cc%-2d %-10s %s\n",
+ $ax,$ay, $best_n, $ccix, $best_d2, $arch, $winode2island{$best_n};
+ my $desc= join "\n", map {
+ my $in= $winode2island{$_};
+ " LP $_". (defined $in ? ", $in" : "");
+ } sort $wiarchs->connected_component_by_index($ccix);
+
+ if (exists $wiccix2arch{$ccix} and $wiccix2arch{$ccix} ne $arch) {
+ error("archipelago determination failed, wrongly merged:\n".
+ " archipelago $arch\n".
+ " archipelago $wiccix2arch{$ccix}\n".
+ $desc);
+ next;
+ }
+ $wiccix2arch{$ccix}= $arch;
+# print "$ccix $arch ::\n$desc\n";
+ }
+}
+
+sub yppedia_archs_fillbynearest() {
+ # Assign islands not labelled above to archipelagoes.
+ #
+ # We do this by, for each connected component (set of islands
+ # linked by purchaseable charts), searching for the nearest other
+ # connected component which has already been assigned an arch.
+ # `Nearest' means shortest distance of unpurchaseable charts, in
+ # leagues.
+ #
+ # we need only consider vertices which weren't `boring intermediate
+ # vertices' (removed during optimisation as being of order 2)
+ my @ccs_useful= map {
+ [ grep { $widists->has_vertex($_) } @$_ ]
+ } $wiarchs->connected_components();
+
+ my @assignments;
+
+ foreach my $sourceccix (0..$#ccs_useful) {
+ next if defined $wiccix2arch{$sourceccix};
+ next unless $ccs_useful[$sourceccix];
+
+ my @sourcecc= $wiarchs->connected_component_by_index($sourceccix);
+ my @islandnodes= grep { $winode2island{$_} } @sourcecc;
+ next unless @islandnodes; # don't care, then
+
+ foreach my $islandnode (@islandnodes) {
+ printf DEBUG "%-5s arch-join-need cc%-2d %s\n",
+ $islandnode, $sourceccix, $winode2island{$islandnode};
+ }
+ my $best_dist= 9999999;
+ my ($best_target, $best_targetccix, $best_source);
+ foreach my $targetccix (0..$#ccs_useful) {
+ next unless defined $wiccix2arch{$targetccix}; # not helpful
+ next unless $ccs_useful[$targetccix];
+ foreach my $target ($wiarchs->
+ connected_component_by_index($targetccix)) {
+ next unless $widists->has_vertex($target);
+ foreach my $source (@sourcecc) {
+ my $target_dist= widist($target,$source);
+ next unless defined $target_dist;
+ next if $target_dist >= $best_dist;
+ $best_dist= $target_dist;
+ $best_source= $source;
+ $best_target= $target;
+ $best_targetccix= $targetccix;
+ }
+ }
+ }
+ die "no possible target ?!" unless defined $best_target;
+
+ my $arch= $wiccix2arch{$best_targetccix};
+ my $best_island= $winode2island{$best_target};
+ printf DEBUG "%-5s arch-join-to %-5s dist=%2d cc%-2d %-10s %s\n",
+ $best_source, $best_target, $best_dist,
+ $best_targetccix, $arch,
+ defined($best_island) ? $best_island : "-";
+
+ push @assignments, [ $sourceccix, $arch ];
+ }
+ foreach my $assign (@assignments) {
+ $wiccix2arch{$assign->[0]}= $assign->[1];
+ }
+}
+
+sub yppedia_graph_shortest_paths () {
+ $wialldists= $widists->APSP_Floyd_Warshall();
+}
+
+sub widist ($$) {
+ my ($p,$q) = @_;
+ my $pl= $wialldists->path_length($p,$q);
+# die "$p $q" unless defined $pl;
+# my @pv= $wialldists->path_vertices($p,$q);
+# if (@pv == $pl) { return $pl; }
+# printf DEBUG "%-5s PATHLENGTH %-5s pl=%s pv=%s\n", $p,$q,$pl,join('|',@pv);
+ return $pl;
+}
+
+sub winode2arch ($) {
+ my ($node) = @_;
+ my $ccix= $wiarchs->connected_component_by_vertex($node);
+ return $wiccix2arch{$ccix};
+}
+sub wiisland2arch ($) {
+ my ($island) = @_;
+ my $node= $wiisland2node{$island};
+ die "$island ?" unless defined $node;
+ return winode2arch($node);
+}
+
+sub compare_island_lists () {
+ foreach my $island (sort keys %dbisland2arch) {
+ my $node= $wiisland2node{$island};
+ if (!defined $node) {
+ error("would delete island: $island");
+ next;
+ }
+ my $wiarch= winode2arch($node);
+ if (!defined $wiarch) {
+ error("island has no arch: $island");
+ next;
+ }
+ my $dbarch= $dbisland2arch{$island};
+ if ($wiarch ne $dbarch) {
+ change("archipelago change from $dbarch to $wiarch".
+ " for island $island");
+ }
+ }
+ foreach my $island (sort keys %wiisland2node) {
+ my $wtarch= $wtisland2arch{$island};
+ my $wiarch= wiisland2arch($island);
+ if (!$stdin_chart) {
+ if (!defined $wtarch) {
+ error("island from chart not found on ocean page: $island");
+ } elsif (defined $wiarch and $wtarch ne $wiarch) {
+ error("island in $wtarch on ocean page but".
+ " concluded $wiarch from chart: $island");
+ }
+ }
+
+ my $dbarch= $dbisland2arch{$island};
+ if (!defined $dbarch) {
+ my $wiarch= wiisland2arch($island);
+ if (!defined $wiarch) {
+ error("new island has no arch: $island");
+ next;
+ # We check arches of non-new islands above
+ }
+ change("island new in $wiarch: $island");
+ }
+ }
+ if (!$stdin_chart) {
+ foreach my $island (sort keys %wtisland2arch) {
+ my $node= $wiisland2node{$island};
+ next if defined $node;
+ error("island on ocean page but not in chart: $island");
+ }
+ }
+}
+
+sub shortest_path_reduction ($$) {
+ my ($what,$g) = @_;
+ #
+ # Takes a graph $g (and a string for messages $what) and returns
+ # a new graph which is the miminal shortest path transient reduction
+ # of $g.
+ #
+ # We also check that the shortest path closure of the intended result
+ # is the same graph as the input. Thus the input must itself be
+ # a shortest path closure; if it isn't, we die.
+
+ my $proof=<<'END'; # way to make a big comment
+
+ Premises and definitions:
+
+ 1. F is an undirected weighted graph with positive edge weights.
+
+ 2. All graphs we will consider have the same vertices as F
+ and none have self-edges.
+
+ 3. G = Closure(F) is the graph of cliques whose edge weights
+ are the shortest paths in F, one clique for each connected
+ component in F.
+
+ 3a. |XY| for vertices X, Y is the weight of the edge XY in G.
+ If XY is not in G, |XY| is infinite.
+
+ 4. A `reduction' of G is a subgraph K of G such that Closure(K) = G.
+ The reduction is `minimal' if there is no strict subgraph K'
+ of K such that Closure(K') = G.
+
+ 5. Now each edge of G may be:
+ - `unnecessary': included in no minimal reductions of G.
+ - `essential': included in all minimal reductions of G.
+ - `contingent': included in some but not all.
+
+ 6. Consider for any edge AC between the vertices A and C,
+ whether there is any B such that |AB|+|BC| = |AC| ?
+ (There can be no B such that the sum < |AC| since that would
+ mean that |AC| wasn't equal to the shortest path length.)
+
+ 6a. No such B: AC is therefore the only shortest path from A to C
+ (since G is not a multigraph). AC is thus an essential edge.
+
+ 6b. Some such B: Call all such edges AC `questionable'.
+
+ 6c. Thus all edges are essential or questionable.
+
+ 7. Suppose AC is a shortest contingent edge. AC must be
+ questionable since it is not essential. Suppose it is
+ made questionable by the existence of B such that |AB|+|BC| =
+ |AC|. Consider AB and BC. Since |AB| and |BC| are positive,
+ |BC| and |AB| must be < |AC| ie AB and BC are shorter than AC.
+ Since AC is a shortest contingent edge, there must be shortest
+ paths in G for AB and BC consisting entirely of essential edges.
+
+ 8. Therefore it is always safe to remove AC since the paths
+ A..B and B..C will definitely still remain and provide a path
+ A..B..C with length |AB|+|BC| = |AC|.
+
+ 9. Thus AC is unnecessary, contradicting the assumption in 7.
+ There are therefore no shortest contingent edges, and
+ thus no contingent edges.
+
+ 10. We can construct a minimal reduction directly: for each edge
+ AC in G, search for a vertex B such that |AB|+|BC| = |AC|.
+ If we find none, AC is essential. If we find one then AC is
+ not essential and is therefore unnecessary.
+
+END
+
+ printf DEBUG "spr %s before %d\n", $what, scalar($g->edges());
+
+ my $result= Graph::Undirected->new();
+ foreach my $edge_ac ($g->edges()) {
+ $result->add_vertex($edge_ac->[0]); # just in case
+ next if $edge_ac->[0] eq $edge_ac->[1];
+ my $edgename_ac= join ' .. ', @$edge_ac;
+ printf DEBUG "spr %s edge %s\n", $what, $edgename_ac;
+ my $w_ac= $g->get_edge_weight(@$edge_ac);
+ my $needed= 1;
+ foreach my $vertex_b ($g->vertices()) {
+ next if grep { $_ eq $vertex_b } @$edge_ac;
+ my $w_ab= $g->get_edge_weight($edge_ac->[0], $vertex_b);
+ next unless defined $w_ab;
+ next if $w_ab >= $w_ac;
+ my $w_bc= $g->get_edge_weight($vertex_b, $edge_ac->[1]);
+ next unless defined $w_ac;
+ next if $w_ab + $w_bc > $w_ac;
+ # found path
+ printf DEBUG "spr %s edge %s unnecessary %s\n",
+ $what, $edgename_ac, $vertex_b;
+ $needed= 0;
+ last;
+ }
+ if ($needed) {
+ printf DEBUG "spr %s edge %s essential\n", $what, $edgename_ac;
+ $result->add_weighted_edge(@$edge_ac,$w_ac);
+ }
+ }
+ printf DEBUG "spr %s result %d\n", $what, scalar($result->edges());
+
+ my $apsp= $result->APSP_Floyd_Warshall();
+ foreach my $ia (sort $g->vertices()) {
+ foreach my $ib (sort $g->vertices()) {
+ my $din= $g->get_edge_weight($ia,$ib);
+ my $dout= $apsp->path_length($ia,$ib);
+ $din= defined($din) ? $din : 'infinity';
+ $dout= defined($dout) ? $dout : 'infinity';
+ error("$what spr apsp discrepancy in=$din out=$dout".
+ " for $ia .. $ib")
+ if $din != $dout;
+ }
+ }
+ return $result;
+}
+
+sub yppedia_graph_spr () {
+ my $base= Graph::Undirected->new();
+ foreach my $na (sort keys %winode2island) {
+ my $ia= $winode2island{$na};
+ foreach my $nb (sort keys %winode2island) {
+ my $ib= $winode2island{$nb};
+ $base->add_weighted_edge($ia,$ib, widist($na,$nb));
+ }
+ }
+ $wispr= shortest_path_reduction('wi',$base);
+}
+
+sub yppedia_ocean_fetch_start ($) {
+ my ($chart) = @_;
+ my @args= ();
+ push @args, '--chart' if $chart;
+ push @args, $ocean;
+ open OCEAN, '-|', "./yppedia-ocean-scraper", @args or die $!;
+}
+sub yppedia_ocean_fetch_done () {
+ $?=0; $!=0; close OCEAN; $? and die $?; $! and die $!;
+}
+
+sub yppedia_ocean_fetch_chart () {
+ if ($stdin_chart) {
+ open OCEAN, "<& STDIN" or die $!;
+ yppedia_chart_parse();
+ } else {
+ yppedia_ocean_fetch_start(1);
+ yppedia_chart_parse();
+ yppedia_ocean_fetch_done();
+ }
+}
+
+sub yppedia_ocean_fetch_text () {
+ yppedia_ocean_fetch_start(0);
+ my $arch;
+ while (<OCEAN>) {
+ chomp;
+ if (m/^ocean /) {
+ $' eq $ocean or die;
+ } elsif (m/^ /) {
+ die unless defined $arch;
+ $wtisland2arch{$'}= $arch;
+ } elsif (m/^ /) {
+ $arch= $';
+ } else {
+ die;
+ }
+ }
+ yppedia_ocean_fetch_done();
+}
+
+sub compare_distances () {
+ foreach my $ia (sort keys %dbisland2arch) {
+ my $na= $wiisland2node{$ia};
+ next unless defined $na;
+ foreach my $ib (sort keys %dbisland2arch) {
+ next unless $ia le $ib; # do every pair only once
+ my $dbdist= $dbspr->get_edge_weight($ia,$ib);
+ my $widist= $wispr->get_edge_weight($ia,$ib);
+ next unless defined $dbdist || defined $widist;
+
+ if (!defined $widist) {
+ warning(sprintf "route delete %2d for %s .. %s",
+ $dbdist, $ia,$ib);
+ } elsif (!defined $dbdist) {
+ change(sprintf "route new %2d for %s .. %s",
+ $widist, $ia,$ib);
+ } elsif ($dbdist != $widist) {
+ change(sprintf "route change %2d to %2d for %s .. %s",
+ $dbdist, $widist, $ia,$ib);
+ }
+ }
+ }
+}
+
+#========== database handling ==========
+
+sub database_fetch_ocean () {
+ my ($row,$sth);
+ $sth= $dbh->prepare('SELECT islandname, archipelago FROM islands');
+ $sth->execute();
+ undef %dbisland2arch;
+ $dbdists= Graph::Undirected->new();
+ while ($row= $sth->fetchrow_hashref) {
+ print DEBUG "database-island $row->{'islandname'}".
+ " $row->{'archipelago'}\n";
+ $dbisland2arch{$row->{'islandname'}}= $row->{'archipelago'};
+ }
+ $sth= $dbh->prepare('SELECT dist, a.islandname a, b.islandname b
+ FROM dists
+ JOIN islands AS a ON dists.aiid==a.islandid
+ JOIN islands AS b ON dists.biid==b.islandid');
+ $sth->execute();
+ while ($row= $sth->fetchrow_hashref) {
+ $dbdists->add_weighted_edge($row->{'a'}, $row->{'b'}, $row->{'dist'});
+ }
+}
+
+sub database_graph_spr () {
+ $dbspr= shortest_path_reduction('db',$dbdists);
+}
+
+sub database_do_updates () {
+ my $addisland= $dbh->prepare(<<'END')
+ INSERT OR IGNORE INTO islands (islandname, archipelago) VALUES (?, ?);
+END
+ ;
+ foreach my $island (sort keys %wiisland2node) {
+ my $wiarch= wiisland2arch($island);
+ $addisland->execute($island, $wiarch);
+ }
+
+ db_doall(<<END)
+ DELETE FROM dists;
+ DELETE FROM routes;
+END
+ ;
+ my $adddist= $dbh->prepare(<<'END')
+ INSERT INTO dists VALUES
+ ((SELECT islandid FROM islands WHERE islandname == ?),
+ (SELECT islandid FROM islands WHERE islandname == ?),
+ ?);
+END
+ ;
+ my $addroute= $dbh->prepare(<<'END')
+ INSERT INTO routes VALUES
+ ((SELECT islandid FROM islands WHERE islandname == ?),
+ (SELECT islandid FROM islands WHERE islandname == ?),
+ ?);
+END
+ ;
+ foreach my $ia (sort keys %wiisland2node) {
+ my $na= $wiisland2node{$ia};
+ foreach my $ib (sort keys %wiisland2node) {
+ my $nb= $wiisland2node{$ib};
+ my $apdist= $ia eq $ib ? 0 : widist($na,$nb);
+ die "$ia $ib" unless defined $apdist;
+ my $sprdist= $wispr->get_edge_weight($ia,$ib);
+ die "$ia $ib $apdist $sprdist" if
+ defined($sprdist) && $sprdist != $apdist;
+
+ $adddist->execute($ia,$ib,$apdist);
+ $addroute->execute($ia,$ib,$sprdist) if defined $sprdist;
+ }
+ }
+
+ # select ia.islandname, ib.islandname, d.dist from dists as d, islands as ia on d.aiid = ia.islandid, islands as ib on d.biid = ib.islandid order by ia.islandname, ib.islandname;
+
+}
+
+#========== update _ocean-*.txt ==========
+
+our $localtopo_path;
+
+sub localtopo_rewrite () {
+ $localtopo_path= '_ocean-'.(lc $ocean).'.txt';
+ my $fh= new IO::File "$localtopo_path.tmp", 'w';
+ print $fh "# autogenerated - do not edit\n" or die $!;
+ print $fh "ocean $ocean\n" or die $!;
+ my %arches;
+ foreach my $isle (sort keys %wtisland2arch) {
+ my $arch= $wtisland2arch{$isle};
+ push @{ $arches{$arch} }, $isle;
+ }
+ foreach my $arch (sort keys %arches) {
+ print $fh " $arch\n" or die $!;
+ foreach my $isle (@{ $arches{$arch} }) {
+ print $fh " $isle\n" or die $!;
+ }
+ }
+ print $fh "\n" or die $!;
+ close $fh or die $!;
+}
+
+sub localtopo_commit () {
+ rename "$localtopo_path.tmp", $localtopo_path or die $!;
+}
+
+#========== main program ==========
+
+parse_info_serverside();
+
+progress("fetching yppedia chart"); yppedia_ocean_fetch_chart();
+progress("adding shortcuts"); yppedia_graphs_add_shortcuts();
+progress("pruning boring vertices"); yppedia_graphs_prune_boring();
+progress("checking yppedia graphs"); yppedia_graphs_check();
+progress("setting archs from source-info"); yppedia_archs_sourceinfo();
+progress("computing shortest paths"); yppedia_graph_shortest_paths();
+progress("setting archs from labels"); yppedia_archs_chart_labels();
+progress("setting archs from nearby"); yppedia_archs_fillbynearest();
+progress("computing yppedia spr"); yppedia_graph_spr();
+
+if (!$stdin_chart) {
+ progress("fetching yppedia ocean text"); yppedia_ocean_fetch_text();
+}
+
+db_setocean($ocean);
+db_connect();
+my $iteration=0;
+for (;;) {
+ progress("reading database");
+ database_fetch_ocean();
+ progress("computing database spr"); database_graph_spr();
+
+ progress("comparing islands"); compare_island_lists();
+ progress("comparing distances"); compare_distances();
+
+ print "\n";
+ print_messages();
+
+ foreach my $k (@msgkinds) {
+ my $n= $msgkindprinted{$k};
+ next unless $n;
+ printf STDERR "*** %d%s %ss\n", $n, $iteration?' additional':'', $k;
+ }
+
+ if ($msgs{'error'}) {
+ print STDERR "*** errors, aborting update\n";
+ exit 1;
+ }
+
+ if (!%msgkindprinted) {
+ progress("updating database"); database_do_updates();
+ progress("updating _ocean-*.txt"); localtopo_rewrite();
+ if ($stdin_chart) {
+ print STDERR "*** --stdin-chart, aborting!\n";
+ exit 1;
+ }
+ progress("committing database"); $dbh->commit();
+ progress("committing _ocean-*.txt"); localtopo_commit();
+ exit 0;
+ }
+ $dbh->rollback();
+
+ my $default= !$msgkindprinted{'warning'};
+ printf STDERR "*** confirm update %s ? ", $default?'(y/n)':'(n/y)';
+
+ if ($stdin_chart) {
+ printf STDERR "[--stdin-chart]\n";
+ exit 1;
+ }
+
+ $!=0; my $result= <STDIN>; defined $result or die $!;
+ $result =~ s/\s//g;
+ $result= $default?'y':'n' if !length $result;
+ $result= $result =~ m/^y/i;
+
+ if (!$result) {
+ printf STDERR "*** updated abandoned at your request\n";
+ exit 1;
+ }
+
+ print "\n";
+ undef %msgkindprinted;
+ $iteration++;
+}
+
+print_messages();
--- /dev/null
+#!/usr/bin/python
+
+# helper program for getting information from yppedia
+
+# This is part of ypp-sc-tools, a set of third-party tools for assisting
+# players of Yohoho Puzzle Pirates.
+#
+# Copyright (C) 2009 Ian Jackson <ijackson@chiark.greenend.org.uk>
+#
+# This program is free software: you can redistribute it and/or modify
+# it under the terms of the GNU 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 General Public License for more details.
+#
+# You should have received a copy of the GNU 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.
+
+copyright_info = '''
+yppedia-ocean-scraper is part of ypp-sc-tools Copyright (C) 2009 Ian Jackson
+This program comes with ABSOLUTELY NO WARRANTY; this is free software,
+and you are welcome to redistribute it under certain conditions. For
+details, read the top of the yppedia-ocean-scraper file.
+'''
+
+import signal
+signal.signal(signal.SIGINT, signal.SIG_DFL)
+
+import sys
+import os
+import urllib
+import urllib2
+import re as regexp
+from optparse import OptionParser
+from BeautifulSoup import BeautifulSoup
+
+
+# For fuck's sake!
+import codecs
+import locale
+def fix_stdout():
+ sys.stdout = codecs.EncodedFile(sys.stdout, locale.getpreferredencoding())
+ def null_decode(input, errors='strict'):
+ return input, len(input)
+ sys.stdout.decode = null_decode
+# From
+# http://ewx.livejournal.com/457086.html?thread=3016574
+# http://ewx.livejournal.com/457086.html?thread=3016574
+# lightly modified.
+# See also Debian #415968.
+fix_stdout()
+
+
+ocean = None
+soup = None
+opts = None
+arches = {}
+
+def debug(k,v):
+ if opts.debug:
+ print >>sys.stderr, k,`v`
+
+def fetch():
+ global soup
+ if opts.chart:
+ url_base = 'index.php?title=Template:Map:%s_Ocean&action=edit'
+ else:
+ url_base = '%s_Ocean'
+ url = ('http://yppedia.puzzlepirates.com/' +
+ (url_base % urllib.quote(ocean,'')))
+ debug('fetching',url)
+ dataf = urllib2.urlopen(url)
+ debug('fetched',dataf)
+ soup = BeautifulSoup(dataf)
+
+
+title_arch_re = regexp.compile('(\\S.*\\S) Archipelago \\((\\S+)\\)$')
+title_any_re = regexp.compile('(\\S.*\\S) \((\\S+)\\)$')
+href_img_re = regexp.compile('\\.png$')
+
+def title_arch_info(t):
+ # returns (arch,ocean)
+ debug('checking',t)
+ if t is None: return (None,None)
+ m = title_arch_re.match(t)
+ if not m: return (None,None)
+ return m.groups()
+
+def title_arch_ok(t):
+ (a,o) = title_arch_info(t)
+ if o is None: return False
+ return o == ocean
+
+def parse_chart():
+ ta = soup.find('textarea')
+ debug('ta',ta)
+ s = ta.string
+ debug('s',s)
+ s = regexp.sub(r'\<\;', '<', s)
+ s = regexp.sub(r'\>\;', '>', s)
+ s = regexp.sub(r'\"\;', '"', s)
+ s = regexp.sub(r'\&\;', '&', s)
+ debug('s',s)
+ return s
+
+def parse_ocean():
+ content = soup.find('div', attrs = {'id': 'content'})
+
+ def findall_title_arch_ok(t):
+ return t.findAll('a', attrs = {'title': title_arch_ok})
+
+ def is_archestable(u):
+ if u.name != 'table': return False
+ return len(findall_title_arch_ok(u)) > 1
+
+ archestable = content.findChild('table', attrs={'border':'1'})
+ debug('at',archestable)
+
+ archsoups = []
+ for row in archestable.findAll('tr',recursive=False):
+ archsoups += row.findAll('td',recursive=False)
+ debug('ac',archsoups)
+
+ def is_island(v):
+ return len(v.findAll(text = regexp.compile('.*Large'))) > 0
+ def arch_up_map(u):
+ return u.findParent(is_island)
+
+ for arch in archsoups:
+ links = arch.findAll('a', href=True)
+ debug('links',links)
+ if not links: continue
+ (a,o) = title_arch_info(links[0]['title'])
+ debug('arch-ocean', (a,o))
+ assert(o == ocean)
+ assert(a not in arches)
+ isles = []
+ for link in links[1:]:
+ debug('link',link)
+ if href_img_re.search(link['href']): continue
+ m = title_any_re.match(link['title'])
+ assert(m.group(2) == ocean)
+ island = m.group(1)
+ debug('island', island)
+ isles.append(island)
+ isles.sort()
+ arches[a] = isles
+
+def output():
+ print 'ocean',ocean
+ al = arches.keys()
+ al.sort()
+ for a in al:
+ print '',a
+ for island in arches[a]:
+ print ' ',island
+
+def main():
+ global ocean
+ global opts
+
+ pa = OptionParser(
+'''usage: .../yppedia-ocean-scraper [--debug] [--chart] OCEAN''')
+ ao = pa.add_option
+
+ ao('--chart', action='store_true', dest='chart',
+ help='print chart source rather than arch/island info')
+ ao('--debug', action='count', dest='debug', default=0,
+ help='enable debugging output')
+
+ (opts,args) = pa.parse_args()
+ if len(args) != 1:
+ print >>sys.stderr, copyright_info
+ pa.error('need an ocean argument')
+ ocean = args[0]
+
+ fetch()
+ if opts.chart:
+ print parse_chart()
+ else:
+ parse_ocean()
+ output()
+
+main()
~yarrgweb / ypp-sc-tools.db-live.git / commitdiff