pax_global_header00006660000000000000000000000064130011006220014473gustar00rootroot0000000000000052 comment=9c7357f76b88ce53aa188ff04fbbb492462814c8 graph-20161031-git/000077500000000000000000000000001300110062200136145ustar00rootroot00000000000000graph-20161031-git/.gitignore000066400000000000000000000000651300110062200156050ustar00rootroot00000000000000*.fasl *.lx32fsl *.lx64fsl stuff scratch.lisp ltxpng graph-20161031-git/COPYING000066400000000000000000001045131300110062200146530ustar00rootroot00000000000000 GNU GENERAL PUBLIC LICENSE Version 3, 29 June 2007 Copyright (C) 2007 Free Software Foundation, Inc. Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The GNU General Public License is a free, copyleft license for software and other kinds of works. The licenses for most software and other practical works are designed to take away your freedom to share and change the works. By contrast, the GNU General Public License is 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. We, the Free Software Foundation, use the GNU General Public License for most of our software; it applies also to any other work released this way by its authors. You can apply it to your programs, too. 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. To protect your rights, we need to prevent others from denying you these rights or asking you to surrender the rights. Therefore, you have certain responsibilities if you distribute copies of the software, or if you modify it: responsibilities to respect the freedom of others. For example, if you distribute copies of such a program, whether gratis or for a fee, you must pass on to the recipients the same freedoms that you received. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. Developers that use the GNU GPL protect your rights with two steps: (1) assert copyright on the software, and (2) offer you this License giving you legal permission to copy, distribute and/or modify it. For the developers' and authors' protection, the GPL clearly explains that there is no warranty for this free software. For both users' and authors' sake, the GPL requires that modified versions be marked as changed, so that their problems will not be attributed erroneously to authors of previous versions. Some devices are designed to deny users access to install or run modified versions of the software inside them, although the manufacturer can do so. This is fundamentally incompatible with the aim of protecting users' freedom to change the software. The systematic pattern of such abuse occurs in the area of products for individuals to use, which is precisely where it is most unacceptable. Therefore, we have designed this version of the GPL to prohibit the practice for those products. If such problems arise substantially in other domains, we stand ready to extend this provision to those domains in future versions of the GPL, as needed to protect the freedom of users. Finally, every program is threatened constantly by software patents. States should not allow patents to restrict development and use of software on general-purpose computers, but in those that do, we wish to avoid the special danger that patents applied to a free program could make it effectively proprietary. To prevent this, the GPL assures that patents cannot be used to render the program non-free. 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 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. Use with the GNU Affero General Public License. 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 Affero 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 special requirements of the GNU Affero General Public License, section 13, concerning interaction through a network will apply to the combination as such. 14. Revised Versions of this License. The Free Software Foundation may publish revised and/or new versions of the GNU 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 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 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 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. Copyright (C) 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 . Also add information on how to contact you by electronic and paper mail. If the program does terminal interaction, make it output a short notice like this when it starts in an interactive mode: Copyright (C) This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, your program's commands might be different; for a GUI interface, you would use an "about box". 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 GPL, see . The GNU General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Lesser General Public License instead of this License. But first, please read . graph-20161031-git/NOTES000066400000000000000000000026201300110062200144270ustar00rootroot00000000000000Notes and Tasks -*- org -*- * Notes ** simpler backend data structure What if we only used 1 hash to hold all nodes and edges..., and what if nodes could hold other nodes in their edge list, and edges could hold other edges in their node list, what sort of structure would this be? A useful generalization of a graph? * Tasks [4/9] ** DONE min cut Some notes in the stuff/ directory. ** TODO breadth/depth first maps ** DONE minimum spanning tree Prim's algorithm ** TODO minimum edge coloring ** DONE clustering coefficient the clustering coefficient \begin{equation*} C = \frac{\text{number of closed connected triples}}{\text{number of connected triples}} \end{equation*} ** TODO measure assortativity http://en.wikipedia.org/wiki/Assortativity Should take an optional :key function which defaults to node degree. ** DONE random graph generators [2/2] http://en.wikipedia.org/wiki/Random_graph Both of the following types of random graphs - [X] [[http://en.wikipedia.org/wiki/Edgar_Gilbert][Edgar_Gilbert]] - [X] [[http://en.wikipedia.org/wiki/Erd%C5%91s%E2%80%93R%C3%A9nyi_model][Erdos-Renyi]] ** TODO more attractive documentation like it or not, people will initially look for pictures - graph-dot -> images in documentation - graph-json -> images in documentation ** TODO graph Laplacian http://web.mit.edu/newsoffice/2013/short-algorithm-long-range-consequences-0301.html graph-20161031-git/README000066400000000000000000000011231300110062200144710ustar00rootroot00000000000000GRAPH - simple graph data structure and algorithms The GRAPH library strives for simplicity both in backing data structures and in usage. Graphs and Digraphs are represented as CLOS objects with methods and algorithms provided for graph manipulation and analysis. Note: currently this library is only supported on SBCL and Clozure CL because of the need to create hashes with custom equality tests, however custom equality tests are commonly supported so extending to other lisps should be simple. Patches welcome. For more information see http://eschulte.github.com/graph. graph-20161031-git/graph-dot.asd000066400000000000000000000006051300110062200161730ustar00rootroot00000000000000(defsystem :graph-dot :description "Serialize graphs to and from DOT format" :author ("Eric Schulte " "Thomas Dye") :version "0.0.0" :licence "GPL V3" :depends-on (alexandria metabang-bind curry-compose-reader-macros graph cl-ppcre) :components ((:static-file "COPYING") (:file "package-dot") (:file "graph-dot" :depends-on ("package-dot")))) graph-20161031-git/graph-dot.lisp000066400000000000000000000222651300110062200164010ustar00rootroot00000000000000;;; graph-dot.lisp --- serialize graphs to and from DOT format ;; Copyright (C) Eric Schulte and Thomas Dye 2013 ;; Licensed under the Gnu Public License Version 3 or later ;;; Commentary ;; Functions for reading/writing graphs from/to the ;; [graphviz](http://www.graphviz.org/) DOT format. ;; ;; Many graphviz properties and exposed as keyword arguments to the ;; `to-dot` function. ;; ;; (defvar *graph* (populate (make-instance 'digraph) ;; :nodes '(a b c d e f) ;; :edges-w-values '(((a b) . 3) ;; ((b c) . 2) ;; ((c d) . 1) ;; ((d b) . 2) ;; ((b e) . 3)))) ;; ;; (let ((ccs (mapcar #'cons (connected-components *graph*) ;; '(1 2 3 4)))) ;; (to-dot-file *graph* "dot-graph-1.dot" ;; :node-attrs ;; (list (cons :fillcolor ;; (lambda (n) (cdr (assoc-if {member n} ccs)))) ;; (cons :style ;; (constantly "filled")) ;; (cons :colorscheme ;; (constantly "set34"))))) ;; ;; ;; ;; Or less colorfully. ;; ;; (setf *graph* (populate (make-instance 'digraph) ;; :edges '((A T2) (T1 B) (T2 B) (T2 C) (T1 D)))) ;; ;; (let ((s1 (make-subgraph :attributes '(("color" . "lightgrey") ;; ("label" . "One" )) ;; :node-list (first ;; (connected-components ;; *graph* ;; :type :unilateral)))) ;; (s2 (make-subgraph :attributes '(("color" . "lightgrey") ;; ("label" . "Two" )) ;; :node-list (second ;; (connected-components ;; *graph* ;; :type :unilateral))))) ;; (to-dot-file *graph* "dot-graph-2.dot" ;; :subgraphs (list s1 s2))) ;; ;; ;;; Code: (in-package :graph-dot) (eval-when (:compile-toplevel :load-toplevel :execute) (enable-curry-compose-reader-macros)) ;;; Visualization (defstruct rank "The information needed to specify a DOT rank statement. VALUE expects a string and NODE-LIST expects a list." value node-list) (defun rank-print (r) "Returns a string containing a DOT rank statement. R is a RANK structure." (when (rank-p r)) (with-output-to-string (out) (when (and (rank-value r) (rank-node-list r)) (format out "{rank=~a;" (rank-value r)) (mapc (lambda (n) (format out " ~s;" n)) (rank-node-list r)) (format out " }~%")))) (defstruct subgraph "The information needed to specify a DOT subgraph. NODE-ATTRIBUTES, EDGE-ATTRIBUTES, and ATTRIBUTES expect assoc lists, and NODE-LIST expects a list." node-attributes edge-attributes attributes ranks node-list) (defun subgraph-print (s) "Returns a string containing a DOT subgraph statement. S is a SUBGRAPH structure." (when (subgraph-p s) (with-output-to-string (out) (format out "subgraph ~a {~%" (string (gensym "cluster_"))) (when (subgraph-node-attributes s) (format out " node [~a];~%" (mapc (lambda (pair) (format out "~a=~a, " (car pair) (cdr pair))) (subgraph-node-attributes s)))) (when (subgraph-edge-attributes s) (format out " edge [~a];~%" (mapc (lambda (pair) (format out "~a=~a, " (car pair) (cdr pair))) (subgraph-edge-attributes s)))) (when (subgraph-attributes s) (mapc (lambda (pair) (format out " ~a=\"~a\";~%" (car pair) (cdr pair))) (subgraph-attributes s))) (when (subgraph-ranks s) (mapcar #'rank-print (subgraph-ranks s))) (when (subgraph-node-list s) (mapc (lambda (n) (format out " ~a;~%" n)) (subgraph-node-list s))) (format out " }~%")))) (defun edge-to-dot (edge type attrs &optional stream) (format stream " \"~a\" ~a \"~a\" ~{~a~^ ~};~%" (first edge) (ecase type (graph "--") (digraph "->")) (second edge) (mapcar (lambda-bind ((attr . fn)) (let ((val (funcall fn edge))) (if val (if (search "URL" (string attr)) (format nil "[~a=~a]" (string-downcase (string attr) :end (- (length (string attr)) 3)) val) (format nil "[~(~a~)=~a]" attr val)) ""))) attrs))) (defun node-to-dot (node attrs &optional stream) (format stream " \"~a\" ~{~a~^ ~};~%" node (mapcar (lambda-bind ((attr . fn)) (let ((val (funcall fn node))) (if val (if (search "URL" (string attr)) (format nil "[~a=~a]" attr val) (format nil "[~(~a~)=~a]" attr val)) ""))) attrs))) (defgeneric to-dot (graph &key stream attributes node-attrs edge-attrs subgraphs ranks) (:documentation "Print the dot code representing GRAPH. The keyword argument ATTRIBUTES takes an assoc list with DOT graph attribute (name . value) pairs. NODE-ATTRS and EDGE-ATTRS also take assoc lists of DOT graph attributes and functions taking nodes or edges respectively and returning values. The DOT graph, node, and edge attributes are described at http://www.graphviz.org/doc/info/attrs.html. SUBGRAPHS is a list of SUBGRAPH structures. RANKS is a list of RANK structures.")) (defmethod to-dot ((graph graph) &key (stream t) attributes node-attrs edge-attrs subgraphs ranks) ;; by default edges are labeled with their values (unless (assoc :label edge-attrs) (push (cons :label {edge-value graph}) edge-attrs)) (format stream "~a to_dot {~%~{~a~}}~%" (intern (string-downcase (type-of graph))) (append (mapcar (lambda-bind ((a . b)) (if (search "URL" (string a)) (format nil " ~a=~a;~%" a b) (format nil " ~(~a~)=~a;~%" a b))) attributes) (mapcar {node-to-dot _ node-attrs} (nodes graph)) (mapcar {edge-to-dot _ (type-of graph) edge-attrs} (edges graph)) (mapcar #'subgraph-print subgraphs) (mapcar #'rank-print ranks)))) (defgeneric to-dot-file (graph path &key attributes node-attrs edge-attrs subgraphs ranks) (:documentation "Write a dot representation of GRAPH to PATH.")) (defmethod to-dot-file ((graph graph) path &key attributes node-attrs edge-attrs subgraphs ranks) (with-open-file (out path :direction :output :if-exists :supersede) (to-dot graph :stream out :attributes attributes :node-attrs node-attrs :edge-attrs edge-attrs :subgraphs subgraphs :ranks ranks))) (defun from-dot (dot-string) "Parse the DOT format string DOT-STRING into a graph. More robust behavior may be achieved through parsing the output of the dot executable." (flet ((string->symbol (string) (intern (string-upcase string)))) (let* ((graph-type-re "^ *((di)?graph)") (spec-re "[\\s]*(\\[([^]]+)\\])?;") (node-name-re "[\\s]*\"?([a-zA-Z0-9_]+)\"?") (node-spec-re (concatenate 'string node-name-re spec-re)) (edge-spec-re (concatenate 'string node-name-re "[\\s]+([->]+)" node-name-re spec-re)) (label-name-re "label=(\"([^\"]+)\"|([^, ]+))[,\\]]") (number-re "[0-9.\/e]+") (graph (multiple-value-bind (string matches) (scan-to-strings graph-type-re dot-string) (declare (ignorable string)) (make-instance (string->symbol (aref matches 0)))))) ;; add nodes (do-register-groups (node spec) (node-spec-re dot-string) (declare (ignorable spec)) (unless (member node '("node" "graph") :test 'string=) (add-node graph (string->symbol node)))) ;; add edges (do-register-groups (left arrow right spec) (edge-spec-re dot-string) (declare (ignorable arrow)) (multiple-value-bind (matchp regs) (scan-to-strings label-name-re spec) (add-edge graph (mapcar #'string->symbol (list left right)) (when matchp (if (scan number-re (aref regs 1)) (read-from-string (aref regs 1)) (aref regs 1)))))) graph))) graph-20161031-git/graph-json.asd000066400000000000000000000006221300110062200163550ustar00rootroot00000000000000(defsystem :graph-json :description "Serialize graphs to/from json with D3 format support." :author ("Eric Schulte " "Thomas Dye") :version "0.0.0" :licence "GPL V3" :depends-on (alexandria metabang-bind curry-compose-reader-macros graph yason) :components ((:static-file "COPYING") (:file "package-json") (:file "graph-json" :depends-on ("package-json")))) graph-20161031-git/graph-json.lisp000066400000000000000000000143661300110062200165670ustar00rootroot00000000000000;;; graph.lisp --- because its easier to write than to learn such a library ;; Copyright (C) Eric Schulte 2013 ;; Licensed under the Gnu Public License Version 3 or later ;;; Commentary ;; Helper function for serializing Graphs to JSON objects and reading ;; JSON objects back into graphs. The JSON syntax for a graph is ;; compatible with the JavaScript d3 visualization library, allowing ;; for interactive viewing of graphs in the browser. ;; See [d3](http://d3js.org/) ;; (specifically [d3-force](http://bl.ocks.org/4062045)) for more. ;;; Code: (in-package :graph-json) (eval-when (:compile-toplevel :load-toplevel :execute) (enable-curry-compose-reader-macros)) (defun json-to-plist (input) "Parse string or stream INPUT into a plist." (let ((yason:*parse-object-key-fn* (lambda (el) (intern (string-upcase el) "KEYWORD"))) (yason:*parse-object-as* :plist)) (yason:parse input))) ;;; JSON import and export (defmethod yason:encode ((symbol symbol) &optional (stream *standard-output*)) (yason:encode (string-downcase (symbol-name symbol)) stream)) (defgeneric to-json (graph &key stream node-fn edge-fn) (:documentation "Write a JSON encoding of GRAPH to STREAM.")) (defmethod to-json ((graph graph) &key (stream *standard-output*) node-fn edge-fn) (let ((plist (to-plist graph :node-fn node-fn :edge-fn edge-fn))) (yason:encode (plist-hash-table (list :nodes (mapcar #'plist-hash-table (getf plist :nodes)) :edges (mapcar #'plist-hash-table (getf plist :edges)))) stream))) (defun intern-string-nodes (plist) (list :nodes (mapcar [{list :name} #'intern #'string-upcase {getf _ :name}] (getf plist :nodes)) :edges (getf plist :edges))) (defmethod from-json ((graph graph) input) "Parse string or stream INPUT into GRAPH." (from-plist graph (intern-string-nodes (json-to-plist input)))) ;;; plist and D3 conversion (defun plist-to-d3 (plist) "Convert plist graph encoding PLIST to D3 format. Note that D3 only handles 2-node edges, so extra nodes in edges will be silently dropped." (list :nodes (getf plist :nodes) :links (mapcar (lambda (edge) (let ((edge (getf edge :edge)) (value (getf edge :value))) (list :source (first edge) :target (second edge) :value value))) (getf plist :edges)))) (defun d3-to-plist (plist) "Convert D3 format PLIST to graph encoding." (list :nodes (mapcar [{list :name} #'intern #'string-upcase {getf _ :name}] (getf plist :nodes)) :edges (mapcar (lambda (edge) (list :edge (list (getf edge :source) (getf edge :target)) :value (getf edge :value))) (getf plist :links)))) ;;; D3 format JSON import and export (defgeneric to-d3 (graph &key stream group-fn) (:documentation "Return a JSON encoding of GRAPH formatted for D3. Edges should have numeric values which d3 will translate into their width. Optional keyword argument GROUP-FN should be a function from nodes to group numbers.")) (defmethod to-d3 ((graph graph) &key (stream *standard-output*) group-fn) (let* ((plist (plist-to-d3 (if group-fn (to-plist graph :node-fn [{list :group} group-fn]) (to-plist graph)))) (hash (plist-hash-table (list :nodes (mapcar #'plist-hash-table (getf plist :nodes)) :links (mapcar #'plist-hash-table (getf plist :links)))))) (if stream (yason:encode hash stream) (with-output-to-string (out) (yason:encode hash out))))) (defgeneric from-d3 (graph input) (:documentation "Parse a D3 format string or stream INPUT into GRAPH.")) (defmethod from-d3 ((graph graph) input) (from-plist graph (d3-to-plist (json-to-plist input)))) (defgeneric to-html (graph &key stream group-fn) (:documentation "Write GRAPH to an HTML file. The resulting HTML file will display an interactive version of GRAPH. Uses `to-d3' to first encode the graph as JSON which is embedded in the HTML page.")) (defmethod to-html ((graph graph) &key (stream *standard-output*) group-fn) (format stream d3-html (to-d3 graph :stream nil :group-fn group-fn))) (defvar d3-html " ") graph-20161031-git/graph-matrix.asd000066400000000000000000000015561300110062200167170ustar00rootroot00000000000000(defsystem :graph-matrix :description "build and manipulate matrix graph representations" :author ("Eric Schulte " "Thomas Dye") :version "0.0.0" :licence "GPL V3" :depends-on (alexandria metabang-bind curry-compose-reader-macros graph femlisp) :components ((:static-file "COPYING") (:file "package-matrix") (:file "graph-matrix" :depends-on ("package-matrix")))) (defsystem :graph-matrix-test :description "test the matrix graph representations" :author ("Eric Schulte " "Thomas Dye") :version "0.0.0" :licence "GPL V3" :depends-on (alexandria metabang-bind stefil curry-compose-reader-macros graph graph-matrix) :components ((:static-file "COPYING") (:module "test" :components ((:file "package-matrix") (:file "graph-matrix" :depends-on ("package-matrix")))))) graph-20161031-git/graph-matrix.lisp000066400000000000000000000632111300110062200171130ustar00rootroot00000000000000;;; graph-matrix.lisp --- build and manipulate matrix graph representations ;; Copyright (C) Eric Schulte and Tom Dye 2013 ;; Licensed under the Gnu Public License Version 3 or later ;;; Commentary ;; Functions for manipulating matrix graph representations. ;;; Code: (in-package :graph-matrix) (eval-when (:compile-toplevel :load-toplevel :execute) (enable-curry-compose-reader-macros)) (defclass matrix () ((self :initarg :self :accessor self :initform nil))) (defclass fast-matrix (matrix) ()) (defgeneric infinite (matrix) (:documentation "Return the most-positive value for the element type of MATRIX.")) (defmethod infinite ((matrix matrix)) most-positive-fixnum) (defmethod infinite ((matrix fast-matrix)) most-positive-single-float) (defgeneric infinitep (value matrix) (:documentation "Non-nil if VALUE is the most-positive value that can be held in MATRIX.")) (defmethod infinitep (value (matrix matrix)) (= value (infinite matrix))) (defgeneric matrix-ref (matrix row col) (:documentation "Return the value at ROW and COL in MATRIX.")) (defmethod matrix-ref ((matrix matrix) row col) (aref (self matrix) row col)) (defmethod matrix-ref ((fm fast-matrix) row col) (fl.function::mref (self fm) row col)) (defgeneric (setf matrix-ref) (new matrix row col) (:documentation "Make matrix-ref setf-able.")) (defmethod (setf matrix-ref) (new (matrix matrix) row col) (setf (aref (self matrix) row col) new)) (defmethod (setf matrix-ref) (new (fm fast-matrix) row col) (setf (fl.function::mref (self fm) row col) new)) (defgeneric matrix-n-rows (matrix) (:documentation "Return the number of rows in MATRIX.")) (defmethod matrix-n-rows ((matrix matrix)) (if (self matrix) (array-dimension (self matrix) 0) 0)) (defmethod matrix-n-rows ((matrix fast-matrix)) (if (self matrix) (fl.function::nrows (self matrix)) 0)) (defgeneric matrix-n-cols (matrix) (:documentation "Return the number of columns in MATRIX.")) (defmethod matrix-n-cols ((matrix matrix)) (if (self matrix) (array-dimension (self matrix) 1) 0)) (defmethod matrix-n-cols ((matrix fast-matrix)) (if (self matrix) (fl.function::ncols (self matrix)) 0)) (defun matrix-same-size-p (m1 m2) "Return t if matrix M1 has the same number of rows and columns as matrix M2, nil otherwise." (and (= (matrix-n-rows m1) (matrix-n-rows m2)) (= (matrix-n-cols m1) (matrix-n-cols m2)))) (defun matrix-entries-different-p (m1 m2) "Returns nil if the entries in matrix M1 and matrix M2 do not differ from one another. Returns 1 if the sizes of matrix M1 and matrix M2 differ. Otherwise, returns a list of lists containing discrepant entries. " (let ((result)) (if (matrix-same-size-p m1 m2) (let ((m (matrix-n-rows m1)) (n (matrix-n-cols m1))) (loop :for i :from 0 :below m :do (loop :for j :from 0 :below n :do (unless (= (matrix-ref m1 i j) (matrix-ref m2 i j)) (push (list i j) result)))) (when result (reverse result))) (setf result 1)) result)) (defun matrix-symmetric-p (matrix) "Return t if matrix MATRIX is symmetric, nil otherwise." (not (matrix-entries-different-p matrix (matrix-transpose matrix)))) (defgeneric matrix-copy (matrix) (:documentation "Return a copy of MATRIX.")) (defmethod matrix-copy ((matrix matrix)) (let* ((m (matrix-n-rows matrix)) (n (matrix-n-cols matrix)) (result (make-zeros-matrix (make-instance 'matrix) m n))) (when (self matrix) (loop :for i :from 0 :below m :do (loop :for j :from 0 :below n :do (setf (matrix-ref result i j) (matrix-ref matrix i j))))) result)) (defmethod matrix-copy ((fm fast-matrix)) (let ((result (make-instance 'fast-matrix))) (when (self fm) (setf (self result) (fl.function::copy (self fm)))) result)) (defgeneric matrix-sum (m1 m2 &key boolean) (:documentation "Return the result of adding matrix M1 and matrix M2. M1 and M2 must be the same size. If BOOLEAN is non-nil, then use boolean arithmetic, where 1+1=1.")) (defmethod matrix-sum ((m1 matrix) (m2 matrix) &key boolean) (and (matrix-same-size-p m1 m2) (let* ((m (matrix-n-rows m1)) (n (matrix-n-cols m1)) (result (make-zeros-matrix (make-instance 'matrix) m n)) (zero 0) (one 1)) (declare (type fixnum zero)) (declare (type fixnum one)) (loop :for i :from 0 :below m :do (loop :for j :from 0 :below n :do (setf (matrix-ref result i j) (if boolean (if (> (+ (matrix-ref m1 i j) (matrix-ref m2 i j)) 0) one zero) (+ (matrix-ref m1 i j) (matrix-ref m2 i j)))))) result))) (defmethod matrix-sum ((m1 fast-matrix) (m2 fast-matrix) &key boolean) (when (matrix-same-size-p m1 m2) (let ((result (make-instance 'fast-matrix))) (setf (self result) (fl.function::m+ (self m1) (self m2))) (when boolean (let ((m (matrix-n-rows result)) (n (matrix-n-cols result)) (one 1.0s0)) (declare (type single-float one)) (loop :for i :from 0 :below m :do (loop :for j :from 0 :below n :do (if (> (matrix-ref result i j) 0) (setf (matrix-ref result i j) one)))))) result))) (defgeneric matrix-difference (m1 m2) (:documentation "Return the result of subtracting M2 from M1. M1 and M2 must be the same size.")) (defmethod matrix-difference ((m1 matrix) (m2 matrix)) (and (matrix-same-size-p m1 m2) (let ((result (matrix-copy m1)) (m (matrix-n-rows m1)) (n (matrix-n-cols m1))) (loop :for i :from 0 :below m :do (loop :for j :from 0 :below n :do (setf (matrix-ref result i j) (- (matrix-ref result i j) (matrix-ref m2 i j))))) result))) (defgeneric matrix-elementwise-product (m1 m2 &key boolean) (:documentation "Return the result of multiplying the elements of matrix M1 and matrix M2. M1 and M2 must be the same size.")) (defmethod matrix-elementwise-product ((m1 matrix) (m2 matrix) &key boolean) (and (matrix-same-size-p m1 m2) (let ((result (matrix-copy m1)) (m (matrix-n-rows m1)) (n (matrix-n-cols m1))) (loop :for i :from 0 :below m :do (loop :for j :from 0 :below n :do (setf (matrix-ref result i j) (if boolean (if (* (matrix-ref result i j) (matrix-ref m2 i j)) 1 0) (* (matrix-ref result i j) (matrix-ref m2 i j)))))) result))) (defgeneric matrix-product (m1 m2) (:documentation "Return the result of multiplying matrix M1 and matrix M2. The number of columns of M1 must equal the number of rows of M2.")) (defmethod matrix-product ((m1 matrix) (m2 matrix)) (and (= (matrix-n-cols m1) (matrix-n-rows m2)) (loop :with m = (matrix-n-rows m1) :with n = (matrix-n-cols m1) :with l = (matrix-n-cols m2) :with c = (make-zeros-matrix (make-instance 'matrix) m l) :for i :below m :do (loop :for k :below l :do (setf (matrix-ref c i k) (loop :for j :below n :sum (* (matrix-ref m1 i j) (matrix-ref m2 j k))))) :finally (return c))) ) (defmethod matrix-product ((m1 fast-matrix) (m2 fast-matrix)) (and (= (matrix-n-cols m1) (matrix-n-rows m2)) (let ((result (make-instance 'fast-matrix))) (setf (self result) (fl.function::m* (self m1) (self m2))) result))) (defgeneric matrix-transpose (matrix) (:documentation "Return a new matrix that interchanges the rows and columns of MATRIX.")) (defmethod matrix-transpose ((matrix matrix)) (let ((m (matrix-n-rows matrix)) (n (matrix-n-cols matrix)) (result (make-instance 'matrix))) (setf result (make-zeros-matrix result n m)) (loop :for i :from 0 :below m :do (loop :for j :from 0 :below n :do (setf (matrix-ref result j i) (matrix-ref matrix i j)))) result)) (defmethod matrix-transpose ((fm fast-matrix)) (let ((result (make-instance 'fast-matrix))) (setf (self result) (fl.function::transpose (self fm))) result)) (defgeneric make-zeros-matrix (matrix rows cols) (:documentation "Return matrix MATRIX with ROWS rows and COLS columns of zeros.")) (defmethod make-zeros-matrix ((matrix matrix) rows cols) (setf (self matrix) (make-array (list rows cols) :element-type 'fixnum :initial-element 0)) matrix) (defmethod make-zeros-matrix ((fm fast-matrix) rows cols) (setf (self fm) (fl.function::zeros rows cols 'single-float)) fm) (defgeneric make-universal-matrix (matrix rows cols) (:documentation "Return a universal matrix with ROWS rows and COLS columns.")) (defmethod make-universal-matrix ((matrix matrix) rows cols) (setf (self matrix) (make-array (list rows cols) :element-type 'fixnum :initial-element 1)) matrix) (defmethod make-universal-matrix ((fm fast-matrix) rows cols) (setf (self fm) (fl.function::ones rows cols 'single-float)) fm) (defgeneric make-infinity-matrix (matrix rows cols) (:documentation "Return a matrix of ROWS rows and COLS cols with each entry set to infinity")) (defmethod make-infinity-matrix ((matrix matrix) rows cols) (progn (setf (self matrix) (make-array (list rows cols) :element-type 'fixnum :initial-element (infinite matrix))) matrix)) (defmethod make-infinity-matrix ((fm fast-matrix) rows cols) (progn (setf (self fm) (fl.function::zeros rows cols 'single-float)) (fl.function::fill! (self fm) (infinite fm)) ;; (loop :for i :from 0 :below rows :do ;; (loop :for j :from 0 :below cols :do ;; (setf (matrix-ref fm i j) infinity))) fm)) (defgeneric make-identity-matrix (matrix order) (:documentation "Return an identity matrix of order ORDER.")) (defmethod make-identity-matrix ((matrix matrix) order) (setf matrix (make-zeros-matrix matrix order order)) (loop :for i :from 0 :below order :do (setf (matrix-ref matrix i i) 1)) matrix) (defmethod make-identity-matrix ((fm fast-matrix) order) (setf (self fm) (fl.function::eye order order 'single-float)) fm) ;; Adapted from ;; https://rosettacode.org/wiki/Matrix-exponentiation_operator#Common_Lisp (defgeneric matrix-power (matrix exp) (:documentation "Raise MATRIX to the power EXP and return the result.")) (defmethod matrix-power ((matrix matrix) exp) (let ((m-rows (matrix-n-rows matrix))) (cond ((/= m-rows (matrix-n-cols matrix)) (error "Non-square matrix")) ((zerop exp) (make-identity-matrix matrix m-rows)) ((= 1 exp) (matrix-copy matrix)) ((zerop (mod exp 2)) (let ((me2 (matrix-power matrix (/ exp 2)))) (matrix-product me2 me2))) (t (let ((me2 (matrix-power matrix (/ (1- exp) 2)))) (matrix-product matrix (matrix-product me2 me2))))))) (defgeneric to-adjacency-matrix (graph matrix) (:documentation "Return the adjacency matrix of GRAPH.")) (defmethod to-adjacency-matrix ((graph graph) (matrix matrix)) (let ((node-index-hash (make-hash-table)) (counter -1)) (mapc (lambda (node) (setf (gethash node node-index-hash) (incf counter))) (nodes graph)) (setf matrix (make-zeros-matrix matrix (+ counter 1) (+ counter 1))) (mapc (lambda-bind ((a b)) (setf (matrix-ref matrix (gethash a node-index-hash) (gethash b node-index-hash)) 1) (setf (matrix-ref matrix (gethash b node-index-hash) (gethash a node-index-hash)) 1)) (edges graph)) matrix)) (defmethod to-adjacency-matrix ((graph digraph) (matrix matrix)) (let ((node-index-hash (make-hash-table)) (counter -1)) (mapc (lambda (node) (setf (gethash node node-index-hash) (incf counter))) (nodes graph)) (setf matrix (make-zeros-matrix matrix (+ counter 1) (+ counter 1))) (mapc (lambda-bind ((a b)) (setf (matrix-ref matrix (gethash a node-index-hash) (gethash b node-index-hash)) 1)) (edges graph)) matrix)) (defmethod to-adjacency-matrix ((graph graph) (matrix fast-matrix)) (let ((node-index-hash (make-hash-table)) (counter -1) (one 1.0s0)) (declare (type single-float one)) (mapc (lambda (node) (setf (gethash node node-index-hash) (incf counter))) (nodes graph)) (setf matrix (make-zeros-matrix matrix (+ counter 1) (+ counter 1))) (mapc (lambda-bind ((a b)) (setf (matrix-ref matrix (gethash a node-index-hash) (gethash b node-index-hash)) one) (setf (matrix-ref matrix (gethash b node-index-hash) (gethash a node-index-hash)) one)) (edges graph)) matrix)) (defmethod to-adjacency-matrix ((graph digraph) (matrix fast-matrix)) (let ((node-index-hash (make-hash-table)) (counter -1) (one 1.0s0)) (declare (type single-float one)) (mapc (lambda (node) (setf (gethash node node-index-hash) (incf counter))) (nodes graph)) (setf matrix (make-zeros-matrix matrix (+ counter 1) (+ counter 1))) (mapc (lambda-bind ((a b)) (setf (matrix-ref matrix (gethash a node-index-hash) (gethash b node-index-hash)) one)) (edges graph)) matrix)) (defgeneric to-reachability-matrix (graph matrix &key limit) (:documentation "Return the reachability matrix of the graph GRAPH. With the optional argument LIMIT set to an integer in the range 2 to two less than the number of nodes in GRAPH, produces a limited reachability matrix with paths of length LIMIT or less.")) (defmethod to-reachability-matrix ((graph graph) (matrix matrix) &key limit) (let ((n (length (nodes graph)))) (assert (or (not limit) (and (integerp limit) (> limit 1) (< limit (- n 1)))) (limit) "~S must be an integer between 2 and ~S" limit (- n 2)) (let* ((result (make-identity-matrix (make-instance 'matrix) n)) (max-power (or limit (- n 1))) (adjacency (to-adjacency-matrix graph (make-instance 'matrix))) (adjacency-powers (matrix-copy adjacency))) (setf result (matrix-sum adjacency result :boolean t)) (loop :for i :from 2 :to max-power :do (setf adjacency-powers (matrix-product adjacency-powers adjacency)) (setf result (matrix-sum adjacency-powers result :boolean t))) result))) (defmethod to-reachability-matrix ((graph graph) (matrix fast-matrix) &key limit) (let ((n (length (nodes graph)))) (assert (or (not limit) (and (integerp limit) (> limit 1) (< limit (- n 1)))) (limit) "~S must be an integer between 2 and ~S" limit (- n 2)) (let* ((result (make-identity-matrix (make-instance 'fast-matrix) n)) (max-power (or limit (- n 1))) (adjacency (to-adjacency-matrix graph (make-instance 'fast-matrix))) (adjacency-powers (matrix-copy adjacency))) (setf result (matrix-sum adjacency result :boolean t)) (loop :for i :from 2 :to max-power :do (setf adjacency-powers (matrix-product adjacency-powers adjacency)) (setf result (matrix-sum adjacency-powers result :boolean t))) result))) (defgeneric reachablep (graph rd from to) (:documentation "Given a graph GRAPH and a reachability matrix RD, returns t if node TO is reachable from node FROM, nil otherwise.")) (defmethod reachablep ((graph graph) (rd matrix) from to) (let ((node-index-hash (make-hash-table)) (counter -1)) (mapc (lambda (node) (setf (gethash node node-index-hash) (incf counter))) (nodes graph)) (= 1 (matrix-ref rd (gethash from node-index-hash) (gethash to node-index-hash))))) (defgeneric reachable-from (graph rd from) (:documentation "Given a reachability matrix RD, return a list of the nodes in graph GRAPH reachable from node FROM.")) (defmethod reachable-from ((graph graph) (rd matrix) from) (let ((node-index-hash (make-hash-table)) (counter -1) (result)) (mapc (lambda (node) (setf (gethash node node-index-hash) (incf counter))) (nodes graph)) (maphash #'(lambda (k v) (unless (= 0 (matrix-ref rd (gethash from node-index-hash) v)) (push k result))) node-index-hash) (reverse result))) (defgeneric to-strong-component-matrix (rd) (:documentation "Given a reachability matrix of a digraph, RD, return a matrix in which the strong component of GRAPH containing node_i is given by the entries of 1 in the ith row (or column).")) (defmethod to-strong-component-matrix ((rd matrix)) (matrix-elementwise-product rd (matrix-transpose rd))) (defgeneric strong-component-of (node graph strong-components) (:documentation "Return a list of nodes from graph GRAPH in the strong component that contains node NODE, as given by the strong component matrix STRONG-COMPONENTS.")) (defmethod strong-component-of (node (graph graph) (strong-components matrix)) (let ((node-index-hash (make-hash-table)) (counter -1) (result)) (mapc (lambda (node) (setf (gethash node node-index-hash) (incf counter))) (nodes graph)) (maphash #'(lambda (k v) (unless (= 0 (matrix-ref strong-components (gethash node node-index-hash) v)) (push k result))) node-index-hash) (reverse result))) (defgeneric to-distance-matrix (graph nd) (:documentation "Return the distance matrix ND of graph GRAPH.")) (defmethod to-distance-matrix ((graph graph) (nd matrix)) (let* ((a (to-adjacency-matrix graph (make-instance 'matrix))) (a-power (to-adjacency-matrix graph (make-instance 'matrix))) (m (matrix-n-rows a)) (finished) (zero 0) (one 1)) (declare (type fixnum one)) (declare (type fixnum zero)) (setf nd (make-infinity-matrix nd m m)) (loop :for i :from 0 :below m :do (setf (matrix-ref nd i i) zero)) (loop :for i :from 0 :below m :do (loop :for j :from 0 :below m :do (when (= (matrix-ref a i j) one) (setf (matrix-ref nd i j) one)))) (loop :for i :from 2 :to m :unless finished :do (setf a-power (matrix-product a a-power)) (setf finished t) (loop :for j :from 0 :below m :do (loop :for k :from 0 :below m :do (when (and (infinitep (matrix-ref nd j k) nd) (> (matrix-ref a-power j k) zero)) (setf (matrix-ref nd j k) (coerce i 'fixnum)) (setf finished nil))))) nd)) (defmethod to-distance-matrix ((graph graph) (nd fast-matrix)) (let* ((a (to-adjacency-matrix graph (make-instance 'fast-matrix))) (a-power (to-adjacency-matrix graph (make-instance 'fast-matrix))) (m (matrix-n-rows a)) (finished) (zero 0.0s0) (one 1.0s0)) (declare (type single-float one)) (declare (type single-float zero)) (setf nd (make-infinity-matrix nd m m)) (loop :for i :from 0 :below m :do (setf (matrix-ref nd i i) zero)) (loop :for i :from 0 :below m :do (loop :for j :from 0 :below m :do (when (= (matrix-ref a i j) one) (setf (matrix-ref nd i j) one)))) (loop :for i :from 2 :to m :unless finished :do (setf a-power (matrix-product a a-power)) (setf finished t) (loop :for j :from 0 :below m :do (loop :for k :from 0 :below m :do (when (and (infinitep (matrix-ref nd j k) nd) (> (matrix-ref a-power j k) zero)) (setf (matrix-ref nd j k) (coerce i 'single-float)) (setf finished nil))))) nd)) (defgeneric distance-from-to (graph nd from to) (:documentation "Returns the number of edges in graph GRAPH from node FROM to node TO, given the distance matrix ND.")) (defmethod distance-from-to ((graph graph) (nd matrix) from to) (let ((node-index-hash (make-hash-table)) (counter -1)) (mapc (lambda (node) (setf (gethash node node-index-hash) (incf counter))) (nodes graph)) (matrix-ref nd (gethash from node-index-hash) (gethash to node-index-hash)))) ;; Peirce's relational properties (defun reflexivep (graph matrix) :documentation "Returns t if GRAPH is reflexive, nil otherwise." (let ((a (to-adjacency-matrix graph matrix)) (result)) (loop :for j :from 0 :below (matrix-n-rows a) :unless result :do (setf result (not (= 1 (matrix-ref a j j))))) (not result))) (defun irreflexivep (graph matrix) :documentation "Returns t if GRAPH is irreflexive, nil otherwise." (let ((a (to-adjacency-matrix graph matrix)) (result)) (loop :for j :from 0 :below (matrix-n-rows a) :unless result :do (setf result (not (= 0 (matrix-ref a j j))))) (not result))) (defun symmetricp (graph matrix) :documentation "Returns t if GRAPH is symmetric, nil otherwise." (let* ((a (to-adjacency-matrix graph matrix)) (at (matrix-transpose a))) (if (matrix-entries-different-p a at) nil t))) (defun asymmetricp (graph matrix) :documentation "Returns t if GRAPH is asymmetric, nil otherwise." (let* ((a (to-adjacency-matrix graph matrix)) (at (matrix-transpose a)) (result)) (loop :for j :from 0 :below (matrix-n-rows a) :unless result :do (loop :for k :from 0 :below (matrix-n-rows a) :unless result :do (setf result (and (not (eq j k)) (eq (matrix-ref a j k) 1) (eq (matrix-ref at j k) 1))))) (not result))) (defun transitivep (graph matrix) :documentation "Returns t if GRAPH is transitive, nil otherwise." (let* ((a (to-adjacency-matrix graph matrix)) (a2 (matrix-product a a)) (two-path) (no-match)) (loop :for j :from 0 :below (matrix-n-rows a) :do (loop :for k :from 0 :below (matrix-n-rows a) :do (and (not two-path) (eq (matrix-ref a2 j k) 1) (setf two-path j)) (and (not no-match) (eq (matrix-ref a2 j k) 1) (eq (matrix-ref a j k) 0) (setf no-match j)))) (and two-path (not no-match)))) (defun intransitivep (graph matrix) :documentation "Returns t if GRAPH is intransitive, nil otherwise." (let* ((a (to-adjacency-matrix graph matrix)) (a2 (matrix-product a a)) (two-path) (match)) (loop :for j :from 0 :below (matrix-n-rows a) :do (loop :for k :from 0 :below (matrix-n-rows a) :do (and (not two-path) (eq (matrix-ref a2 j k) 1) (setf two-path j)) (and (not match) (not (eq j k)) (eq (matrix-ref a2 j k) 1) (eq (matrix-ref a j k) 1) (setf match j)))) (and two-path (not match)))) (defun completep (graph matrix) :documentation "Returns t if GRAPH is complete, nil otherwise." (let* ((a (to-adjacency-matrix graph matrix)) (at (matrix-transpose a)) (result)) (loop :for j :from 0 :below (matrix-n-rows a) :unless result :do (loop :for k :from 0 :below (matrix-n-rows a) :unless (or result (eq j k)) :do (setf result (and (eq (graph-matrix::matrix-ref a j k) 0) (eq (graph-matrix::matrix-ref at j k) 0))))) (not result))) (defun relational-structure (graph matrix) :documentation "Returns a string with the name of a relational structure whose axiom system GRAPH satisfies, or nil if no relational structure axiom system is satisfied." (let ((rnobar (reflexivep graph matrix)) (rbar (irreflexivep graph matrix)) (snobar (symmetricp graph matrix)) (sbar (asymmetricp graph matrix)) (tnobar (transitivep graph matrix)) (tbar (intransitivep graph matrix)) (cnobar (completep graph matrix))) (or (when (and rbar (not (or snobar sbar tnobar tbar cnobar))) "digraph") (when (and rbar snobar (not (or tnobar tbar cnobar))) "graph") (when (and rbar sbar (not (or tnobar tbar cnobar))) "oriented graph") (when (and rnobar snobar (not tnobar)) "similarity relation") (when (and rnobar snobar tnobar (not cnobar)) "equivalence relation") (when (and rbar sbar tnobar (not cnobar)) "partial order") (when (and rbar sbar tnobar cnobar) "complete order") (when (and rbar sbar cnobar (not (or tnobar tbar))) "tournament") (when (and rbar snobar tnobar (not cnobar)) "parity relation") (when (and rbar sbar tbar (not cnobar)) "antiequivalence relation") (when (and rnobar sbar tbar) "antiparity relation")))) graph-20161031-git/graph.asd000066400000000000000000000014321300110062200154060ustar00rootroot00000000000000(defsystem :graph :description "simple library for building and manipulating graphs" :version "0.0.0" :author ("Eric Schulte " "Thomas Dye") :licence "GPL V3" :depends-on (alexandria metabang-bind curry-compose-reader-macros) :components ((:static-file "COPYING") (:file "package") (:file "graph" :depends-on ("package")))) (defsystem :graph-test :description "Test the graph library." :author ("Eric Schulte " "Thomas Dye") :version "0.0.0" :licence "GPL V3" :depends-on (alexandria metabang-bind graph stefil curry-compose-reader-macros) :components ((:static-file "COPYING") (:module "test" :components ((:file "package") (:file "graph" :depends-on ("package")))))) graph-20161031-git/graph.lisp000066400000000000000000001415161300110062200156160ustar00rootroot00000000000000;;; graph.lisp --- because its easier to write than to learn such a library ;; Copyright (C) Eric Schulte and Thomas Dye 2012-2013 ;; Licensed under the Gnu Public License Version 3 or later ;;; Commentary ;; Graphs are composed of two hash tables, nodes and edges. The node ;; hash is keyed by node and holds the edges containing that node, ;; while the edge hash is keyed by edge containing any optional edge ;; value. ;; ;; Nodes Edges ;; ------- ------- ;; +----Graph G-----+ key | value key | value ;; | 3 2 | -----+--------- -------+---------- ;; | a---b---c g | a | (a b) (a b) | 3 ;; | 1| |1 | b | (b d) (b c) (b d) | 1 ;; | d---e---f | c | (b c) (c e) (b c) | 2 ;; | 2 3 | d | (b d) (d e) (c e) | 1 ;; +----------------+ e | (d e) (c e) (d e) | 2 ;; f | (e f) (e f) | 3 ;; g | ;; ;; Graphs are CLOS objects which are constructed with the usual `make ;; instance` and are populated with the `populate` function. ;; ;; (defvar *graph* (populate (make-instance 'graph) ;; :nodes '(a b c d e f g) ;; :edges-w-values '(((a b) . 3) ;; ((b d) . 1) ;; ((b c) . 2) ;; ((c e) . 1) ;; ((d e) . 2) ;; ((e f) . 3)))) ;; ;; Standard accessors are provided. ;; ;; * (nodes *graph*) ;; (A B C D E F G) ;; ;; * (edges *graph*) ;; ((A B) (B D) (B C) (C E) (D E) (E F)) ;; ;; * (node-edges *graph* 'b) ;; ((B C) (B D) (A B)) ;; ;; * (edge-value *graph* '(d e)) ;; 2 ;; ;; Nodes and edges may be removed using `delete-node` and ;; `delete-edge`, or using setf methods on any of the accessors above. ;; ;; * (delete-edge *graph* '(e f)) ;; 3 ;; ;; * (edges *graph*) ;; ((A B) (B D) (B C) (C E) (D E)) ;; ;; * (setf (nodes *graph*) (remove 'a (nodes *graph*))) ;; (B C D E F G) ;; ;; * (edges *graph*) ;; ((B D) (B C) (C E) (D E)) ;; ;; Some more sophisticated graph algorithms are implemented. A couple ;; are shown below, see the dictionary for a complete list. ;; ;; * (shortest-path *graph* 'b 'e) ;; ((B C) (C E)) ;; ;; * (connected-components *graph*) ;; ((G) (B D C E) (F)) ;; ;; * (setf (nodes *graph*) '(B D C E)) ;; (B C D E) ;; ;; * (min-cut *graph*) ;; ((B C) (E D)) ;; 2 ;; ;; Additionally digraphs represent graphs with directed edges. ;; Starting with the original graph above we get the following. ;; ;; * (strongly-connected-components *graph*) ;; ((G) (D F E C B A)) ;; ;; * (strongly-connected-components (digraph-of *graph*)) ;; ((G) (A) (B) (D) (C) (E) (F)) ;; ;; * (delete-edge *graph* '(d e)) ;; 2 ;; ;; * (push '(e d) (edges *graph*)) ;; ((A B) (B D) (B C) (C E) (E D) (E F)) ;; ;; * (push '(d c) (edges *graph*)) ;; ((A B) (B D) (B C) (C E) (E D) (E F) (D C)) ;; ;; * (strongly-connected-components (digraph-of *graph*)) ;; ((G) (A) (B) (D E C) (F)) ;;; Code: (in-package :graph) (eval-when (:compile-toplevel :load-toplevel :execute) (enable-curry-compose-reader-macros)) ;;; Special hashes keyed for edges (defun edge-equalp (edge1 edge2) (set-equal edge1 edge2)) (defun sxhash-edge (edge) (sxhash (sort (copy-tree edge) (if (numberp (car edge)) #'< #'string<)))) #+sbcl (sb-ext:define-hash-table-test edge-equalp sxhash-edge) #+clisp (ext:define-hash-table-test edge-equalp edge-equalp sxhash-edge) (defun dir-edge-equalp (edge1 edge2) (tree-equal edge1 edge2)) #+sbcl (sb-ext:define-hash-table-test dir-edge-equalp sxhash) #+clisp (ext:define-hash-table-test dir-edge-equalp dir-edge-equalp sxhash) (defun make-edge-hash-table () #+sbcl (make-hash-table :test 'edge-equalp) #+clisp (make-hash-table :test 'edge-equalp) #+ccl (make-hash-table :test 'edge-equalp :hash-function 'sxhash-edge) #-(or sbcl clisp ccl) (error "unsupport lisp distribution")) (defun make-diedge-hash-table () #+sbcl (make-hash-table :test 'dir-edge-equalp) #+clisp (make-hash-table :test 'dir-edge-equalp) #+ccl (make-hash-table :test 'dir-edge-equalp :hash-function 'sxhash) #-(or sbcl clisp ccl) (error "unsupport lisp distribution")) ;;; Graph objects and basic methods (defclass graph () ((node-h :initarg :node-h :accessor node-h :initform (make-hash-table)) (edge-h :initarg :edge-h :accessor edge-h :initform (make-edge-hash-table)) (edge-eq :initarg :edge-eq :accessor edge-eq :initform 'edge-equalp)) (:documentation "A graph consisting of `nodes' connected by `edges'. Nodes must be numbers symbols or keywords. Edges may be assigned arbitrary values, although some functions assume numeric values (e.g., `merge-nodes', `merge-edges', `max-flow' and `min-cut').")) (defclass digraph (graph) ((edge-h :initarg :edge-h :accessor edge-h :initform (make-diedge-hash-table)) (edge-eq :initarg :edge-eq :accessor edge-eq :initform 'dir-edge-equalp)) (:documentation "A `graph' with directed edges.")) (defun copy-hash (hash &optional test comb) "Return a copy of HASH. Optional argument TEST specifies a new equality test to use for the copy. Second optional argument COMB specifies a function to use to combine the values of elements of HASH which collide in the copy due to a new equality test specified with TEST." (let ((copy #+sbcl (make-hash-table :test (or test (hash-table-test hash))) #+clisp (make-hash-table :test (or test (hash-table-test hash))) #+ccl (make-hash-table :test (or test (hash-table-test hash)) :hash-function (case (or test (hash-table-test hash)) (edge-equalp 'sxhash-edge) ((dir-edge-equalp equalp) 'sxhash))) #-(or sbcl clisp ccl) (error "unsupported lisp distribution"))) (maphash (lambda (k v) (setf (gethash k copy) (if (and (gethash k copy) comb) (funcall comb (gethash k copy) v) v))) hash) copy)) (defun node-hash-equal (hash1 hash2) "Test node hashes HASH1 and HASH2 for equality." (set-equal (hash-table-alist hash1) (hash-table-alist hash2) :test (lambda (a b) (and (equalp (car a) (car b)) (set-equal (cdr a) (cdr b) :test 'tree-equal))))) (defun edge-hash-equal (hash1 hash2) "Test edge hashes HASH1 and HASH2 for equality." (set-equal (hash-table-alist hash1) (hash-table-alist hash2) :test 'equalp)) (defgeneric copy (graph) (:documentation "Return a copy of GRAPH.")) (defmethod copy ((graph graph)) (make-instance (type-of graph) :node-h (copy-hash (node-h graph)) :edge-h (copy-hash (edge-h graph)) :edge-eq (edge-eq graph))) (defgeneric digraph-of (graph) (:documentation "Copy GRAPH into a `digraph' and return.")) (defmethod digraph-of ((graph graph)) (make-instance 'digraph :node-h (copy-hash (node-h graph)) :edge-h (copy-hash (edge-h graph)) :edge-eq (edge-eq graph))) (defgeneric graph-of (digraph) (:documentation "Copy DIGRAPH into a `graph' and return.")) (defmethod graph-of ((digraph digraph)) (make-instance 'graph :node-h (copy-hash (node-h digraph)) :edge-h (copy-hash (edge-h digraph) 'equalp) :edge-eq (edge-eq digraph))) (defgeneric populate (graph &key nodes edges edges-w-values) (:documentation "Populate the nodes and edges of GRAPH based on keyword arguments.")) (defmethod populate ((graph graph) &key nodes edges edges-w-values) (mapc {add-node graph} nodes) (mapc {add-edge graph} edges) (setf (edges-w-values graph) edges-w-values) graph) (defgeneric graph-equal (graph1 graph2) (:documentation "Compare GRAPH1 and GRAPH2 for equality.")) (defmethod graph-equal ((graph1 graph) (graph2 graph)) (every (lambda-bind ((test key)) ;; TODO: digraph's need a stricter graph-equal (apply test (append (mapcar key (list graph1 graph2))))) '((eq type-of) (equal edge-eq) (edge-hash-equal edge-h) (node-hash-equal node-h)))) ;;; Serialize graphs (defgeneric to-plist (graph &key node-fn edge-fn) (:documentation "Serialize GRAPH as a plist. Keyword arguments NODE-FN and EDGE-FN will be called on a node or edge and should return a plist of data to associate with the given node or edge in the results.")) (defmethod to-plist ((graph graph) &key node-fn edge-fn) (let ((counts (make-hash-table)) (counter -1)) (list :nodes (mapcar (lambda (node) (append (list :name node) (when node-fn (funcall node-fn node)))) (mapc (lambda (n) (setf (gethash n counts) (incf counter))) (nodes graph))) :edges (map 'list (lambda (edge value) (append (list :edge edge :value value) (when edge-fn (funcall edge-fn edge)))) (mapcar {mapcar {gethash _ counts}} (edges graph)) (mapcar {edge-value graph} (edges graph)))))) (defgeneric from-plist (graph plist) (:documentation "Populate GRAPH with the contents of PLIST.")) (defmethod from-plist ((graph graph) plist) (let ((nodes (map 'vector {getf _ :name} (getf plist :nodes)))) (populate graph :nodes (coerce nodes 'list) :edges-w-values (mapcar (lambda (el) (cons (mapcar {aref nodes} (getf el :edge)) (getf el :value))) (getf plist :edges))))) (defgeneric to-value-matrix (graph) (:documentation "Return the value matrix of GRAPH.")) (defmethod to-value-matrix ((graph graph)) (let ((node-index-hash (make-hash-table)) (counter -1)) (mapc (lambda (node) (setf (gethash node node-index-hash) (incf counter))) (nodes graph)) (let ((matrix (make-array (list (1+ counter) (1+ counter)) :initial-element nil))) (mapc (lambda-bind (((a b) . value)) (setf (aref matrix (gethash a node-index-hash) (gethash b node-index-hash)) (or value t))) (edges-w-values graph)) matrix))) (defgeneric from-value-matrix (graph matrix) (:documentation "Populate GRAPH from the value matrix MATRIX.")) (defmethod from-value-matrix ((graph graph) matrix) (bind (((as bs) (array-dimensions matrix))) (assert (= as bs) (matrix) "Value matrix ~S must be square." matrix) (loop :for a :below as :do (loop :for b :below bs :do (when (aref matrix a b) (add-edge graph (list a b) (if (eq t (aref matrix a b)) nil (aref matrix a b))))))) graph) ;;; Simple graph methods (defgeneric edges (graph) (:documentation "Return a list of the edges in GRAPH.")) (defmethod edges ((graph graph)) (loop :for key :being :each :hash-key :of (edge-h graph) :collect key)) (defgeneric (setf edges) (new graph) (:documentation "Set the edges in GRAPH to NEW.")) (defmethod (setf edges) (new (graph graph)) (mapc {delete-edge graph} (set-difference (edges graph) new :test (edge-eq graph))) (mapc {add-edge graph} (set-difference new (edges graph) :test (edge-eq graph))) (edges graph)) (defgeneric edges-w-values (graph) (:documentation "Return an alist of edges of GRAPH with their values.")) (defmethod edges-w-values ((graph graph) &aux alist) (maphash (lambda (edge value) (push (cons edge value) alist)) (edge-h graph)) alist) (defgeneric (setf edges-w-values) (new graph) (:documentation "Set the edges of graph to edges and values in NEW.")) (defmethod (setf edges-w-values) (new (graph graph)) (mapc (lambda-bind ((edge . value)) (add-edge graph edge value)) new)) (defgeneric nodes (graph) (:documentation "Return a list of the nodes in GRAPH.")) (defmethod nodes ((graph graph)) (loop :for key :being :each :hash-key :of (node-h graph) :collect key)) (defgeneric (setf nodes) (new graph) (:documentation "Set the nodes in GRAPH to NEW.")) (defmethod (setf nodes) (new (graph graph)) (mapc {delete-node graph} (set-difference (nodes graph) new)) (mapc {add-node graph} (set-difference new (nodes graph))) (nodes graph)) (defgeneric nodes-w-values (graph) (:documentation "Return an alist of nodes of GRAPH with their values.")) (defmethod nodes-w-values ((graph graph) &aux alist) (maphash (lambda (node value) (push (cons node value) alist)) (node-h graph)) alist) (defgeneric has-node-p (graph node) (:documentation "Return `true' if GRAPH has node NODE.")) (defmethod has-node-p ((graph graph) node) (multiple-value-bind (value included) (gethash node (node-h graph)) (declare (ignorable value)) included)) (defgeneric has-edge-p (graph edge) (:documentation "Return `true' if GRAPH has edge EDGE.")) (defmethod has-edge-p ((graph graph) edge) (multiple-value-bind (value included) (gethash edge (edge-h graph)) (declare (ignorable value)) included)) (defgeneric subgraph (graph nodes) (:documentation "Return the subgraph of GRAPH restricted to NODES.")) (defmethod subgraph ((graph graph) nodes) (let ((g (copy graph))) (setf (nodes g) nodes) g)) (defgeneric add-node (graph node) (:documentation "Add NODE to GRAPH.")) (defmethod add-node ((graph graph) node) ;; NOTE: This limitation on the types of node simplifies the ;; equality tests, and the use of nodes as hash keys ;; throughout the remainder of this library. In fact the ;; addition of type-annotations around node quality operations ;; may improve performance. The desire for more complex node ;; structures, may often be met by maintaining a hash table ;; outside of the graph which maps graph nodes to the more ;; complex object related to the node. (assert (or (numberp node) (symbolp node)) (node) "Nodes must be numbers, symbols or keywords, not ~S.~%Invalid node:~S" (type-of node) node) (unless (has-node-p graph node) (setf (gethash node (node-h graph)) nil) node)) (defgeneric add-edge (graph edge &optional value) (:documentation "Add EDGE to GRAPH with optional VALUE. The nodes of EDGE are also added to GRAPH.")) (defmethod add-edge ((graph graph) edge &optional value) (mapc (lambda (node) (add-node graph node) (pushnew (case (type-of graph) (graph (remove-duplicates edge)) (digraph edge)) (gethash node (node-h graph)) :test (edge-eq graph))) edge) (setf (gethash edge (edge-h graph)) value) edge) (defgeneric node-edges (graph node) (:documentation "Return the value of NODE in GRAPH.")) (defmethod node-edges ((graph graph) node) (multiple-value-bind (edges included) (gethash node (node-h graph)) (assert included (node graph) "~S doesn't include ~S" graph node) (copy-tree edges))) (defgeneric degree (graph node) (:documentation "Return the degree of NODE in GRAPH.")) (defmethod degree ((graph graph) node) (length (node-edges graph node))) (defgeneric indegree (digraph node) (:documentation "The number of edges directed to NODE in GRAPH.")) (defmethod indegree ((digraph digraph) node) (length (remove-if-not [{member node} #'cdr] (node-edges digraph node)))) (defgeneric outdegree (digraph node) (:documentation "The number of edges directed from NODE in DIGRAPH.")) (defmethod outdegree ((digraph digraph) node) (length (remove-if-not [{equal node} #'car] (node-edges digraph node)))) (defgeneric transmitterp (digraph node) (:documentation "Returns t if node is a transmitter, i.e., has indegree of 0 and positive outdegree.")) (defmethod transmitterp ((digraph digraph) node) (and (eq (indegree digraph node) 0) (> (outdegree digraph node) 0))) (defgeneric receiverp (digraph node) (:documentation "Returns t if node is a receiver, i.e., has outdegree of 0 and positive indegree.")) (defmethod receiverp ((digraph digraph) node) (and (eq (outdegree digraph node) 0) (> (indegree digraph node) 0))) (defgeneric isolatep (digraph node) (:documentation "Returns t if node is an isolate, i.e., both indegree and outdegree are 0.")) (defmethod isolatep ((digraph digraph) node) (and (eq (indegree digraph node) 0) (eq (outdegree digraph node) 0))) (defgeneric carrierp (digraph node) (:documentation "Returns t if node is a carrier, i.e., both indegree and outdegree are 1.")) (defmethod carrierp ((digraph digraph) node) (and (eq (indegree digraph node) 1) (eq (outdegree digraph node) 1))) (defgeneric ordinaryp (digraph node) (:documentation "Returns t if node is ordinary, i.e., is not a transmitter, receiver, isolate, or carrier.")) (defmethod ordinaryp ((digraph digraph) node) (not (or (transmitterp digraph node) (receiverp digraph node) (isolatep digraph node) (carrierp digraph node)))) (defgeneric transmitters (digraph) (:documentation "Return a list of the transmitters in digraph.")) (defmethod transmitters ((digraph digraph)) (let ((r)) (dolist (n (nodes digraph) r) (when (transmitterp digraph n) (push n r))))) (defgeneric receivers (digraph) (:documentation "Return a list of the receivers in digraph.")) (defmethod receivers ((digraph digraph)) (let ((r)) (dolist (n (nodes digraph) r) (when (receiverp digraph n) (push n r))))) (defgeneric isolates (digraph) (:documentation "Return a list of the isolated node in digraph.")) (defmethod isolates ((digraph digraph)) (let ((r)) (dolist (n (nodes digraph) r) (when (isolatep digraph n) (push n r))))) (defgeneric ordinaries (digraph) (:documentation "Return a list of the ordinary nodes in digraph.")) (defmethod ordinaries ((digraph digraph)) (let ((r)) (dolist (n (nodes digraph) r) (when (ordinaryp digraph n) (push n r))))) (defgeneric (setf node-edges) (new graph node) ;; TODO: seg-faults in clisp (:documentation "Set the edges of NODE in GRAPH to NEW. Delete and return the old edges of NODE in GRAPH.")) (defmethod (setf node-edges) (new (graph graph) node) (prog1 (mapc {delete-edge graph} (gethash node (node-h graph))) (mapc {add-edge graph} new))) (defgeneric delete-node (graph node) (:documentation "Delete NODE from GRAPH. Delete and return the old edges of NODE in GRAPH.")) (defmethod delete-node ((graph graph) node) (prog1 (mapcar (lambda (edge) (cons edge (delete-edge graph edge))) (node-edges graph node)) (remhash node (node-h graph)))) (defgeneric edge-value (graph edge) (:documentation "Return the value of EDGE in GRAPH.")) (defmethod edge-value ((graph graph) edge) (multiple-value-bind (value included) (gethash edge (edge-h graph)) (assert included (edge graph) "~S doesn't include ~S" graph edge) value)) (defgeneric (setf edge-value) (new graph edge) (:documentation "Set the value of EDGE in GRAPH to NEW.")) (defmethod (setf edge-value) (new (graph graph) edge) (setf (gethash edge (edge-h graph)) new)) (defgeneric delete-edge (graph edge) (:documentation "Delete EDGE from GRAPH. Return the old value of EDGE.")) (defmethod delete-edge ((graph graph) edge) (prog1 (edge-value graph edge) (mapc (lambda (node) (setf (gethash node (node-h graph)) (remove edge (gethash node (node-h graph)) :test (edge-eq graph)))) edge) (remhash edge (edge-h graph)))) (defgeneric reverse-edges (graph) (:documentation "Return a copy of GRAPH with all edges reversed.")) (defmethod reverse-edges ((graph graph)) (populate (make-instance (type-of graph)) :nodes (nodes graph) :edges-w-values (mapcar (lambda-bind ((edge . value)) (cons (reverse edge) value)) (edges-w-values graph)))) ;;; Complex graph methods (defgeneric merge-nodes (graph node1 node2 &key new) (:documentation "Combine NODE1 and NODE2 in GRAPH into the node NEW. All edges of NODE1 and NODE2 in GRAPH will be combined into a new node of value NEW. Edges between only NODE1 and NODE2 will be removed.")) (defmethod merge-nodes ((graph graph) node1 node2 &key (new node1)) ;; replace all removed edges with NEW instead of NODE1 or NODE2 (mapcar (lambda-bind ((edge . value)) (let ((e (mapcar (lambda (n) (if (member n (list node1 node2)) new n)) edge))) (if (has-edge-p graph e) (when (and (edge-value graph e) value) (setf (edge-value graph e) (+ (edge-value graph e) value))) (add-edge graph e value)))) ;; drop edges between only node1 and node2 (remove-if-not [{set-difference _ (list node1 node2)} #'car] ;; delete both nodes keeping their edges and values (prog1 (append (delete-node graph node1) (delete-node graph node2)) ;; add the new node (add-node graph new)))) graph) (defgeneric merge-edges (graph edge1 edge2 &key value) (:documentation "Combine EDGE1 and EDGE2 in GRAPH into a new EDGE. Optionally provide a value for the new edge, the values of EDGE1 and EDGE2 will be combined.")) (defmethod merge-edges ((graph graph) edge1 edge2 &key value) (add-edge graph (remove-duplicates (append edge1 edge2)) (or value (when (and (edge-value graph edge1) (edge-value graph edge2)) (+ (edge-value graph edge1) (edge-value graph edge2))))) (append (delete-edge graph edge1) (delete-edge graph edge2))) (defgeneric edge-neighbors (graph edge) (:documentation "Return all edges which share a node with EDGE in GRAPH.")) (defmethod edge-neighbors ((graph graph) edge) (mapcan {node-edges graph} edge)) (defgeneric neighbors (graph node) (:documentation "Return all nodes which share an edge with NODE in GRAPH.")) (defmethod neighbors ((graph graph) node) (apply {concatenate 'list} (node-edges graph node))) (defmethod neighbors ((digraph digraph) node) (mapcan [#'cdr {member node}] (node-edges digraph node))) (defgeneric precedents (digraph node) (:documentation "Return all nodes preceding NODE in an edge of DIGRAPH.")) (defmethod precedents ((digraph digraph) node) (mapcan [#'cdr {member node} #'reverse] (node-edges digraph node))) (defgeneric connected-component (graph node &key type) (:documentation "Return the connected component of NODE in GRAPH. The TYPE keyword argument only has an effect for directed graphs in which it may be set to one of the following with :STRONG being the default value. :STRONG ..... connections only traverse edges along the direction of the edge :WEAK ....... connections may traverse edges in any direction regardless of the edge direction :UNILATERAL . two nodes a and b connected iff a is strongly connected to b or b is strongly connected to a")) (defun connected-component- (node neighbor-fn) ;; Helper function for `connected-component'. (let ((from (list node)) (seen (list node))) (loop :until (null from) :do (let ((next (remove-duplicates (mapcan neighbor-fn from)))) (setf from (set-difference next seen)) (setf seen (union next seen)))) (reverse seen))) (defmethod connected-component ((graph graph) node &key type) (declare (ignorable type)) (connected-component- node {neighbors graph})) (defmethod connected-component ((digraph digraph) node &key type) (ecase (or type :strong) (:strong (connected-component- node {neighbors digraph})) (:weak (connected-component- node {neighbors (graph-of digraph)})) (:unilateral (let ((weakly (connected-component- node {neighbors (graph-of digraph)})) (strongly (connected-component- node {neighbors digraph}))) ;; keep weakly connected components which are strongly ;; connected to NODE in digraph or to which NODE is strongly ;; connected in the directional compliment of digraph (union strongly (remove-if-not [{member node} {connected-component (reverse-edges digraph)}] (set-difference weakly strongly))))))) (defgeneric connectedp (graph &key type) (:documentation "Return true if the graph is connected. TYPE keyword argument is passed to `connected-components'.")) (defmethod connectedp ((graph graph) &key type) (declare (ignorable type)) (let ((nodes (nodes graph))) (subsetp (nodes graph) (connected-component graph (car nodes))))) (defmethod connectedp ((digraph digraph) &key type) (every [{subsetp (nodes digraph)} (lambda (n) (connected-component digraph n :type type))] (nodes digraph))) (defgeneric connected-components (graph &key type) (:documentation "Return a list of the connected components of GRAPH. Keyword TYPE is passed to `connected-component' and only has effect for directed graphs. Returns strongly connected components of a directed graph by default.")) (defmethod connected-components ((graph graph) &key type) (flet ((cc-helper () (let ((nodes (sort (nodes graph) #'< :key {degree graph})) ccs) (loop :until (null nodes) :do (let ((cc (connected-component graph (car nodes) :type type))) (setf nodes (set-difference nodes cc)) (push cc ccs))) ccs))) (cond ((and type (eq (type-of graph) 'graph)) (warn "type parameter has no effect for undirected graphs") (cc-helper)) ((eq type :unilateral) (warn "unilateral connected component partition may not be well defined") (cc-helper)) ((or (eq type :strong) (and (null type) (eq (type-of graph) 'digraph))) (strongly-connected-components graph)) (t (cc-helper))))) (defgeneric topological-sort (digraph) (:documentation "Returns a topologically ordered list of the nodes in DIGRAPH, such that, for each edge in DIGRAPH, the start of the edge appears in the list before the end of the edge.")) (defmethod topological-sort (digraph) (assert (null (basic-cycles digraph)) (digraph) "~S has a cycle so no topological sort is possible" digraph) (let ((index (make-hash-table)) stack) (labels ((visit (node) (mapc (lambda (neighbor) (unless (gethash neighbor index) (visit neighbor))) (neighbors digraph node)) ;; mark this node (setf (gethash node index) 1) (push node stack))) (mapc (lambda (node) (unless (gethash node index) (visit node))) (nodes digraph))) stack)) (defgeneric levels (digraph &key alist) (:documentation "Assign a positive integer to each node in DIGRAPH, called its level, where, for each directed edge (a b) the corresponding integers satisfy a < b. Returns either a hash table where the nodes are keys and the levels are values, or an association list of nodes and their levels, along with the number of levels in DIGRAPH.")) (defmethod levels (digraph &key alist) (let ((longest (make-hash-table))) (dolist (x (topological-sort digraph)) (let ((max-val 0) (incoming (precedents digraph x))) (if incoming (progn (dolist (y incoming) (when (> (gethash y longest) max-val) (setf max-val (gethash y longest)))) (setf (gethash x longest) (+ 1 max-val))) (setf (gethash x longest) max-val)))) (values (if alist (nreverse (hash-table-alist longest)) longest) (+ 1 (reduce #'max (hash-table-values longest)))))) ;;; Cycles and strongly connected components (defgeneric strongly-connected-components (graph) (:documentation "Return the nodes of GRAPH partitioned into strongly connected components. Uses Tarjan's algorithm.")) (defmethod strongly-connected-components ((graph graph)) (let ((index (make-hash-table)) (lowlink (make-hash-table)) (counter 0) stack sccs) (labels ((tarjan (node) ;; mark this node (setf (gethash node index) counter) (setf (gethash node lowlink) counter) (incf counter) (push node stack) ;; consider successors (mapc (lambda (neighbor) (cond ((not (gethash neighbor index)) (tarjan neighbor) (setf (gethash node lowlink) (min (gethash node lowlink) (gethash neighbor lowlink)))) ((member neighbor stack) (setf (gethash node lowlink) (min (gethash node lowlink) (gethash neighbor index)))))) (neighbors graph node)) ;; is NODE the root of a strongly connected component (when (= (gethash node index) (gethash node lowlink)) (push (loop :for v = (pop stack) :collect v :until (eq v node)) sccs)))) (mapc (lambda (node) (unless (gethash node index) (tarjan node))) (nodes graph))) sccs)) (defgeneric basic-cycles (graph) (:documentation "Return all basic cycles in the GRAPH.")) (defmethod basic-cycles ((graph graph)) (let (cycles seen) (labels ((follow (node path used-edges) (push node seen) (dolist (edge (node-edges graph node)) (unless (member edge used-edges :test (edge-eq graph)) (dolist (neighbor (case (type-of graph) (graph (remove node edge)) (digraph (cdr (member node edge))))) (cond ((member neighbor path) (push (subseq path 0 (1+ (position neighbor path))) cycles)) (t (follow neighbor (cons neighbor path) (cons edge used-edges))))))))) (dolist (node (nodes graph)) (unless (member node seen) (follow node (list node) nil)))) (remove-duplicates cycles :test 'set-equal))) (defgeneric cycles (graph) (:documentation "Return all cycles of GRAPH (both basic and compound).")) (defmethod cycles ((graph graph)) (flet ((combine (c1 c2) (let (done) (reduce (lambda (acc el) (append (if (and (not done) (member el c1)) (progn (setf done t) (append (member el c1) (reverse (member el (reverse c1))))) (list el)) acc)) c2 :initial-value nil)))) (let ((basic-cycles (basic-cycles graph)) cycles) (loop :for cycle = (pop basic-cycles) :while cycle :do (push cycle cycles) (mapc (lambda (c) (push (combine c cycle) cycles)) (remove-if-not {intersection cycle} basic-cycles))) cycles))) (defgeneric minimum-spanning-tree (graph &optional tree) (:documentation "Return a minimum spanning tree of GRAPH. Prim's algorithm is used. Optional argument TREE may be used to specify an initial tree, otherwise a random node is used.")) (defmethod minimum-spanning-tree ((graph graph) &optional (tree (populate (make-instance 'graph) :nodes (list (random-elt (nodes graph)))))) (assert (connectedp graph) (graph) "~S is not connected" graph) (let ((copy (copy graph)) (total-nodes (length (nodes graph)))) (loop :until (= (length (nodes tree)) total-nodes) :do (let ((e (car (sort (remove-if-not {intersection (set-difference (nodes copy) (nodes tree))} (mapcan {node-edges copy} (nodes tree))) #'< :key {edge-value copy})))) (when e (add-edge tree e (edge-value graph e)) (delete-edge copy e)))) tree)) (defgeneric connected-groups-of-size (graph size) (:documentation "Return all connected node groups of SIZE in GRAPH.")) (defmethod connected-groups-of-size ((graph graph) size) ;; Note: this function doesn't work with hyper graphs (assert (> size 1) (size) "can't group less than two items") (let ((connected-groups (edges graph))) (loop :for i :from 2 :below size :do (setf connected-groups (mapcan (lambda (group) (mapcar {union group} (remove-if {subsetp _ group} (mapcan {node-edges graph} group)))) connected-groups))) (remove-duplicates connected-groups :test 'set-equal))) (defgeneric closedp (graph nodes) (:documentation "Return true if NODES are fully connected in GRAPH.")) (defmethod closedp ((graph graph) nodes) (block nil ;; Note: this function doesn't work with hyper graphs (map-combinations (lambda (pair) (unless (has-edge-p graph pair) (return nil))) nodes :length 2))) (defgeneric clustering-coefficient (graph) (:documentation "Fraction of connected triples which are closed.")) (defmethod clustering-coefficient ((graph graph)) (let ((triples (connected-groups-of-size graph 3))) (/ (length (remove-if-not {closedp graph} triples)) (length triples)))) (defgeneric cliques (graph) (:documentation "Return the maximal cliques of GRAPH. The Bron-Kerbosh algorithm is used.")) (defmethod cliques ((graph graph) &aux cliques) (labels ((bron-kerbosch (r p x) (if (and (null x) (null p)) (push r cliques) (loop :for v :in p :collect ;; TODO: use `degeneracy' ordering (let ((n (neighbors graph v))) (bron-kerbosch (union (list v) r) (intersection (set-difference p r) n) (intersection x n))) :do (setf p (remove v p) x (union (list v) x)))))) (bron-kerbosch nil (nodes graph) nil)) cliques) ;;; Shortest Path (defgeneric shortest-path (graph a b) (:documentation "Return the shortest path in GRAPH from A to B. GRAPH must be a directed graph. Dijkstra's algorithm is used.")) ;; TODO: needs to work for un-directed edges (defmethod shortest-path ((graph graph) a b &aux seen) (block nil ;; (car next) is leading node, (cdr next) is edge path (let ((next (list (list a)))) (loop :until (null next) :do (setf next (mapcan (lambda-bind ((from . rest)) (mapcan (lambda (edge) (if (case (type-of graph) (graph (member b edge)) (digraph (member b (cdr (member from edge))))) (return (reverse (cons edge rest))) (unless (member edge seen :test (edge-eq graph)) (push edge seen) (mapcar (lambda (n) (cons n (cons edge rest))) (case (type-of graph) (graph (remove from edge)) (digraph (cdr (member from edge)))))))) (node-edges graph from))) next)))))) ;;; Max Flow ;; - Must be a "network" (digraph in which each edge has a positive weight) ;; - Ford-Fulkerson is used (defgeneric residual (graph flow) (:documentation "Return the residual graph of GRAPH with FLOW. Each edge in the residual has a value equal to the original capacity minus the current flow, or equal to the negative of the current flow.")) (defmethod residual ((graph graph) flow) (flet ((flow-value (edge) (or (cdr (assoc edge flow :test (edge-eq graph))) 0))) (let ((residual (make-instance (type-of graph)))) (mapc (lambda (edge) (let ((left (- (edge-value graph edge) (flow-value edge)))) (when (not (zerop left)) (add-edge residual edge left))) (when (not (zerop (flow-value edge))) (add-edge residual (reverse edge) (flow-value edge)))) (edges graph)) residual))) (defgeneric add-paths (graph path1 path2) (:documentation "Return the combination of paths PATH1 and PATH2 through GRAPH. Each element of PATH has the form (cons edge value).")) (defmethod add-paths ((graph graph) path1 path2) (let ((comb (copy-tree path1))) (mapc (lambda-bind ((edge . value)) (if (assoc edge comb :test (edge-eq graph)) (setf (cdr (assoc edge comb :test (edge-eq graph))) (+ (cdr (assoc edge comb :test (edge-eq graph))) value)) (push (cons edge value) comb))) path2) comb)) (defmethod add-paths ((digraph digraph) path1 path2) "Return the combination of paths PATH1 and PATH2 through DIGRAPH. Each element of path has the form (cons edge value)." (let ((comb (copy-tree path1))) (mapc (lambda-bind ((edge . value)) (cond ((assoc edge comb :test (edge-eq digraph)) (setf (cdr (assoc edge comb :test (edge-eq digraph))) (+ (cdr (assoc edge comb :test (edge-eq digraph))) value))) ((assoc (reverse edge) comb :test (edge-eq digraph)) (setf (cdr (assoc (reverse edge) comb :test (edge-eq digraph))) (- (cdr (assoc edge comb :test (edge-eq digraph))) value))) (t (push (cons edge value) comb)))) path2) comb)) (defgeneric max-flow (graph from to) (:documentation "Return the maximum flow from FROM and TO in GRAPH. GRAPHS must be a network with numeric values of all edges. The Ford-Fulkerson algorithm is used.")) (defmethod max-flow ((digraph digraph) from to) (flet ((trim-path (path) (when path (let ((flow (apply #'min (mapcar #'cdr path)))) (mapcar (lambda (el) (cons (car el) flow)) path)))) (flow-value-into (flow node) (reduce #'+ (remove-if-not (lambda (el) (equal (lastcar (car el)) node)) flow) :key #'cdr))) (let ((from from) (to to) augment residual flow) (loop :do (setf residual (residual digraph flow)) ;; "augmenting path" is path through residual network in which each ;; edge has positive capacity (setf augment (trim-path (mapcar (lambda (edge) (cons edge (edge-value residual edge))) (shortest-path residual from to)))) :while augment :do ;; if ∃ an augmenting path, add it to the flow and repeat (setf flow (add-paths digraph flow augment))) (values flow (flow-value-into flow to))))) ;;; Min Cut ;; ;; Stoer, M. and Wagner, Frank. 1997. A Simple Min-Cut Algorithm. ;; Journal of the ACM ;; ;; Theorem: Let s,t ∈ (nodes G), let G' be the result of merging s and ;; t in G. Then (min-cut G) is equal to the minimum of the ;; min cut of s and t in G and (min-cut G'). ;; (defun weigh-cut (graph cut) (reduce #'+ (mapcar {edge-value graph} (remove-if-not (lambda (edge) (and (intersection edge (first cut)) (intersection edge (second cut)))) (edges graph))))) (defgeneric min-cut (graph) (:documentation "Return both the global min-cut of GRAPH and the weight of the cut.")) (defmethod min-cut ((graph graph)) (let ((g (copy graph)) (merged-nodes (mapcar (lambda (n) (list n n)) (nodes graph))) cuts-of-phase) (flet ((connection-weight (group node) ;; return the weight of edges between GROUP and NODE (reduce #'+ (mapcar {edge-value g} (remove-if-not {intersection group} (node-edges g node))))) (my-merge (a b) ;; merge in the graph (merge-nodes g a b) ;; update our merged nodes alist (setf (cdr (assoc a merged-nodes)) (append (cdr (assoc a merged-nodes)) (cdr (assoc b merged-nodes)))) (setq merged-nodes (remove-if (lambda (it) (eql (car it) b)) merged-nodes)))) (loop :while (> (length (nodes g)) 1) :do (let* ((a (list (random-elt (nodes g)))) (rest (remove (car a) (nodes g)))) (loop :while rest :do ;; grow A by adding the node most tightly connected to A (let ((new (car (sort rest #'> :key {connection-weight a})))) (setf rest (remove new rest)) (push new a))) ;; store the cut-of-phase (push (cons (connection-weight (cdr a) (car a)) (cdr (assoc (car a) merged-nodes))) cuts-of-phase) ;; merge two last added nodes (my-merge (first a) (second a)))) ;; return the minimum cut-of-phase (let* ((half (cdar (sort cuts-of-phase #'< :key #'car))) (cut (list half (set-difference (nodes graph) half)))) (values (sort cut #'< :key #'length) (weigh-cut graph cut)))))) ;;; Random graphs generation (defgeneric preferential-attachment-populate (graph nodes &key edge-vals) (:documentation ;; TODO: add optional argument for desired average degree "Add NODES to GRAPH using preferential attachment, return the new edges. Optionally assign edge values from those listed in EDGE-VALS.")) (defmethod preferential-attachment-populate ((graph graph) nodes &key edge-vals) (let ((degree-sum 0) (connections (make-array (* 2 (length nodes))))) (flet ((save-edge (from to) (incf degree-sum 2) (setf (aref connections (- degree-sum 2)) from) (setf (aref connections (- degree-sum 1)) to) (add-edge graph (list from to) (when edge-vals (pop edge-vals))))) (assert (not (= 1 (length nodes))) (nodes) "Can't preferentially attach a single node.") (when (null (nodes graph)) (save-edge (pop nodes) (pop nodes))) (mapc (lambda (n) (save-edge n (aref connections (random degree-sum)))) nodes) (edges-w-values graph)))) (defgeneric erdos-renyi-populate (graph m) (:documentation "Populate GRAPH with M edges in an Erdős–Rényi random graph model.")) (defmethod erdos-renyi-populate ((graph graph) m) (let* ((nodes (coerce (nodes graph) 'vector)) (num (length nodes))) (loop :until (= m 0) :do ;; NOTE: this naive approach will slow down drastically for ;; large nearly complete graphs (let ((a (aref nodes (random num))) (b (aref nodes (random num)))) (unless (or (= a b) (has-edge-p graph (list a b))) (add-edge graph (list a b)) (decf m))))) graph) (defun erdos-renyi-graph (n m) "Return an Erdős–Rényi graph with N nodes and M edges." (assert (and (not (< m 0)) (< m (/ (* n (1- n)) 2))) (n m) "an ~S-node graph can not have ~S edges" n m) (erdos-renyi-populate (populate (make-instance 'graph) :nodes (loop :for i :below n :collect i)) m)) (defun erdos-renyi-digraph (n m) "Return an Erdős–Rényi digraph with N nodes and M edges." (assert (and (not (< m 0)) (< m (* n (1- n)))) (n m) "an ~S-node digraph can not have ~S edges" n m) (erdos-renyi-populate (populate (make-instance 'digraph) :nodes (loop :for i :below n :collect i)) m)) (defgeneric edgar-gilbert-populate (graph p) (:documentation "Populate GRAPH including every possible edge with probability P.")) (defmethod edgar-gilbert-populate ((graph graph) p) (setf (edges graph) nil) (map-combinations (lambda (pair) ;; Note: needs refinement for hyper-graphs (when (< (random 1.0) p) (add-edge graph pair))) (nodes graph) :length 2) graph) (defmethod edgar-gilbert-populate ((digraph digraph) p) (setf (edges digraph) nil) (mapc (lambda (from) ;; Note: needs refinement for hyper-graphs (mapc (lambda (to) (when (< (random 1.0) p) (add-edge digraph (list from to)))) (remove from (nodes digraph)))) (nodes digraph)) digraph) (defun edgar-gilbert-graph (n p) (edgar-gilbert-populate (populate (make-instance 'graph) :nodes (loop :for i :below n :collect i)) p)) (defun edgar-gilbert-digraph (n p) (edgar-gilbert-populate (populate (make-instance 'digraph) :nodes (loop :for i :below n :collect i)) p)) ;;; Centrality (defgeneric farness (graph node) (:documentation "Sum of the distance from NODE to every other node in connected GRAPH.")) (defmethod farness ((graph graph) node) (assert (connectedp graph) (graph) "~S must be connected to calculate farness." graph) (reduce #'+ (mapcar [#'length {shortest-path graph node}] (remove node (nodes graph))))) (defgeneric closeness (graph node) (:documentation "Inverse of the `farness' for NODE in GRAPH.")) (defmethod closeness ((graph graph) node) (/ 1 ) (farness graph node)) (defgeneric betweenness (graph node) (:documentation "Fraction of shortest paths through GRAPH which pass through NODE. Fraction of node pairs (s,t) s.t. s and t ≠ NODE and the shortest path between s and t in GRAPH passes through NODE.")) (defmethod betweenness ((graph graph) node) (flet ((all-pairs (lst) (case (type-of graph) (graph (mapcan (lambda (n) (mapcar {list n} (cdr (member n lst)))) lst)) (digraph (mapcan (lambda (n) (mapcar {list n} (remove n lst))) lst))))) (let ((num 0) (denom 0)) (mapc (lambda-bind ((a b)) (when (member node (apply #'append (shortest-path graph a b))) (incf num)) (incf denom)) (all-pairs (remove node (nodes graph)))) (/ num denom)))) (defgeneric katz-centrality (graph node &key attenuation) (:documentation "Combined measure of number and nearness of nodes to NODE.")) (defmethod katz-centrality ((graph graph) node &key (attenuation 0.8)) (let ((cc (connected-component graph node))) (reduce #'+ (mapcar [{expt attenuation} #'length {shortest-path graph node}] (remove node cc))))) ;;; Degeneracy ;; ;; From the Wikipedia article on "Degeneracy (graph theory)". ;; (defgeneric degeneracy (graph) (:documentation "Return the degeneracy and k-cores of GRAPH. Also return the node ordering with optimal coloring number as an alist. The `car' of each element of the alist identifies k-cores and the `cdr' holds the nodes in the ordering.")) (defmethod degeneracy ((graph graph)) (let ((copy (copy graph)) (node-degree (make-hash-table)) (max-degree 0) (num-nodes 0) (k 0) (i 0) by-degree output) ;; initialize (mapc (lambda (n) (let ((degree (degree copy n))) (incf num-nodes) (setf (gethash n node-degree) degree) (setf max-degree (max max-degree degree)))) (nodes copy)) (setf by-degree (make-array (1+ max-degree) :initial-element nil)) (maphash (lambda (node degree) (push node (aref by-degree degree))) node-degree) ;; reduction (dotimes (n num-nodes (values k output)) (setf i 0) (loop :until (aref by-degree i) :do (incf i)) ;; create alist element for the new core (when (< k (setf k (max k i))) (push (list k) output)) ;; drop a node and demote all neighbors (let ((node (pop (aref by-degree i)))) (push node (cdr (assoc k output))) (mapc (lambda (node) (setf (aref by-degree (gethash node node-degree)) (remove node (aref by-degree (gethash node node-degree)))) (decf (gethash node node-degree)) (push node (aref by-degree (gethash node node-degree)))) (prog1 (remove-duplicates (remove node (neighbors copy node))) (delete-node copy node))))))) (defgeneric k-cores (graph) (:documentation "Return the k-cores of GRAPH.")) (defmethod k-cores ((graph graph)) (multiple-value-bind (k cores) (degeneracy graph) (declare (ignorable k)) cores)) graph-20161031-git/package-dot.lisp000066400000000000000000000003321300110062200166620ustar00rootroot00000000000000(defpackage #:graph-dot (:use :common-lisp :alexandria :metabang-bind :curry-compose-reader-macros :graph :cl-ppcre) (:export :to-dot :to-dot-file :from-dot :make-subgraph)) graph-20161031-git/package-json.lisp000066400000000000000000000003241300110062200170460ustar00rootroot00000000000000(defpackage #:graph-json (:use :common-lisp :alexandria :metabang-bind :curry-compose-reader-macros :graph :yason) (:export :to-json :from-json :to-d3 :from-d3 :to-html )) graph-20161031-git/package-matrix.lisp000066400000000000000000000016531300110062200174070ustar00rootroot00000000000000(defpackage #:graph-matrix (:use :common-lisp :alexandria :metabang-bind :curry-compose-reader-macros :graph :fl.function) ;; shadow functions defined in alexandria, fl.function, and graph (:shadow :copy :factorial :standard-deviation :variance :median :mean :degree) (:export :matrix :fast-matrix :matrix-ref :matrix-n-rows :matrix-n-cols :matrix-same-size-p :matrix-symmetric-p :matrix-entries-different-p :matrix-copy :matrix-transpose :make-universal-matrix :make-identity-matrix :make-zeros-matrix :to-adjacency-matrix :to-reachability-matrix :reachablep :reachable-from :to-strong-component-matrix :strong-component-of :to-distance-matrix :distance-from-to :reflexivep :irreflexivep :symmetricp :asymmetricp :transitivep :intransitivep :completep :relational-structure :infinite :infinitep)) graph-20161031-git/package.lisp000066400000000000000000000026651300110062200161110ustar00rootroot00000000000000(defpackage #:graph (:use :common-lisp :alexandria :metabang-bind :curry-compose-reader-macros) (:export :graph :digraph :copy :digraph-of :graph-of :populate :graph-equal ;; Serialization :to-plist :from-plist :to-adjacency-matrix :to-value-matrix :from-value-matrix ;; Simple Graph Methods :edges :edges-w-values :nodes :nodes-w-values :has-node-p :has-edge-p :subgraph :add-node :add-edge :node-edges :degree :indegree :outdegree :delete-node :edge-value :delete-edge :reverse-edges ;; Complex Graph Methods :merge-nodes :merge-edges :edge-neighbors :neighbors :precedents :connected-component :connectedp :connected-components :topological-sort :levels ;; Cycles and strongly connected components :strongly-connected-components :basic-cycles :cycles :minimum-spanning-tree :connected-groups-of-size :closedp :clustering-coefficient :cliques ;; Shortest Path :shortest-path ;; Max Flow :residual :add-paths :max-flow ;; Min Cut :min-cut ;; Random Graph generation :preferential-attachment-populate :erdos-renyi-populate :erdos-renyi-graph :erdos-renyi-digraph :edgar-gilbert-populate :edgar-gilbert-graph :edgar-gilbert-digraph ;; Centrality :farness :closeness :betweenness :katz-centrality ;; Degeneracy :degeneracy :k-cores)) graph-20161031-git/test/000077500000000000000000000000001300110062200145735ustar00rootroot00000000000000graph-20161031-git/test/graph-matrix.lisp000066400000000000000000000647451300110062200201070ustar00rootroot00000000000000;;; test/graph-matrix.lisp --- tests for the graph matrix library ;; Copyright (C) Eric Schulte and Tom Dye 2013 ;; Licensed under the Gnu Public License Version 3 or later ;;; Code: (in-package :graph-matrix-test) (eval-when (:compile-toplevel :load-toplevel :execute) (enable-curry-compose-reader-macros)) (defsuite test) (in-suite test) (defvar *graph* nil "Variable for use in graph tests.") (defixture basic-graph (:setup (setf *graph* (populate (make-instance 'graph) :nodes '(a b c d e f) :edges '((a b) (b c) (c d) (d e) (e c) (e f) (f b))))) (:teardown (setf *graph* nil))) ;;; Structural Models in Anthropology, Hage and Harary 1983, Figure ;;; 5.2, p. 96 (defixture hh-5-2 (:setup (setf *graph* (populate (make-instance 'graph) :nodes '(1 2 3 4) :edges '((1 2) (1 3) (1 4) (2 3) (3 4))))) (:teardown (setf *graph* nil))) ;;; Structural Models in Anthropology, Hage and Harary 1983, Figure ;;; 5.3, p. 97 (defixture hh-5-3 (:setup (setf *graph* (populate (make-instance 'digraph) :nodes '(1 2 3 4) :edges '((1 3) (1 4) (2 1) (2 3) (3 2) (4 3) (4 1))))) (:teardown (setf *graph* nil))) ;;; Structural Models in Anthropology, Hage and Harary 1983, Figure ;;; 5.10, p. 107 (defixture hh-5-10 (:setup (setf *graph* (populate (make-instance 'digraph) :nodes '(1 2 3 4) :edges '((1 2) (2 3) (2 4) (3 2) (3 4))))) (:teardown (setf *graph* nil))) ;;; Exchange in Oceania: A Graph Theoretic Analysis, Hage and Harary ;;; 1991, Figure 4.5, p. 121 (defixture hh-4-5 (:setup (setf *graph* (populate (make-instance 'digraph) :nodes '(1 2 3 4) :edges '((1 2) (1 3) (1 4) (2 3) (3 1) (4 3))))) (:teardown (setf *graph* nil))) ;;; Structural Models in Anthropology, Hage and Harary 1983, Figure ;;; 5.11, p. 110 (defixture hh-5-11 (:setup (setf *graph* (populate (make-instance 'digraph) :nodes '(1 2 3 4 5) :edges '((1 2) (1 3) (2 3) (3 1) (4 3) (5 4) (5 1))))) (:teardown (setf *graph* nil))) ;;; Structural Models in Anthropology, Hage and Harary 1983, Figure ;;; 4.18, p. 86. 2' -> 22, 2" -> 222, etc. (defixture hh-4-18 (:setup (setf *graph* (populate (make-instance 'digraph) :nodes '(0 1 11 2 22 222 3 33) :edges '((0 1) (0 11) (1 2) (1 22) (1 222) (1 3) (1 33) (11 2) (11 22) (11 222) (11 3) (11 33) (2 22) (2 222) (2 3) (2 33) (22 2) (22 222) (22 3) (22 33) (222 2) (222 22) (222 3) (222 33))))) (:teardown (setf *graph* nil))) (defixture relation (:setup (setf *graph* (populate (make-instance 'digraph) :nodes '(a b c d) :edges '((a c) (b b) (c c) (c b) (c a) (d a) (d c))))) (:teardown (setf *graph* nil))) (defixture digraph (:setup (setf *graph* (populate (make-instance 'digraph) :nodes '(a b c d) :edges '((a c) (a d) (c b) (c a) (d c))))) (:teardown (setf *graph* nil))) (defixture graph (:setup (setf *graph* (populate (make-instance 'digraph) :nodes '(a b c d) :edges '((a c) (a d) (b c) (c b) (c a) (c d) (d c) (d a))))) (:teardown (setf *graph* nil))) (defixture oriented-graph (:setup (setf *graph* (populate (make-instance 'digraph) :nodes '(a b c d) :edges '((a d) (b c) (c a) (c d))))) (:teardown (setf *graph* nil))) (defixture similarity-relation (:setup (setf *graph* (populate (make-instance 'digraph) :nodes '(a b c d) :edges '((a a) (a c) (a d) (b b) (b c) (c c) (c a) (c b) (c d) (d d) (d a) (d c))))) (:teardown (setf *graph* nil))) (defixture equivalence-relation (:setup (setf *graph* (populate (make-instance 'digraph) :nodes '(a b c d) :edges '((a a) (a c) (a d) (b b) (c c) (c a) (c d) (d d) (d c) (d a))))) (:teardown (setf *graph* nil))) (defixture partial-order (:setup (setf *graph* (populate (make-instance 'digraph) :nodes '(a b c d) :edges '((a c) (a d) (b c) (d c))))) (:teardown (setf *graph* nil))) (defixture complete-order (:setup (setf *graph* (populate (make-instance 'digraph) :nodes '(a b c d) :edges '((a b) (a c) (a d) (b c) (d b) (d c))))) (:teardown (setf *graph* nil))) (defixture tournament (:setup (setf *graph* (populate (make-instance 'digraph) :nodes '(a b c d) :edges '((a c) (a d) (b a) (c b) (d b) (d c))))) (:teardown (setf *graph* nil))) (defixture parity-relation (:setup (setf *graph* (populate (make-instance 'digraph) :nodes '(a b c d) :edges '((a c) (a d) (c a) (c d) (d a) (d c))))) (:teardown (setf *graph* nil))) (defixture antiequivalence-relation (:setup (setf *graph* (populate (make-instance 'digraph) :nodes '(a b c d) :edges '((a d) (b a) (c b) (d c))))) (:teardown (setf *graph* nil))) (defixture antiparity-relation (:setup (setf *graph* (populate (make-instance 'digraph) :nodes '(a b c d) :edges '((a a) (a d) (b b) (b a) (c c) (c b) (d d) (d c))))) (:teardown (setf *graph* nil))) ;;; Tests ;;; Test simple functions (deftest same-size-p () (let ((f1 (make-zeros-matrix (make-instance 'fast-matrix) 2 4)) (l1 (make-zeros-matrix (make-instance 'matrix) 2 4)) (f2 (make-zeros-matrix (make-instance 'fast-matrix) 4 2)) (l2 (make-zeros-matrix (make-instance 'matrix) 4 2)) (l3 (make-zeros-matrix (make-instance 'matrix) 2 4)) (f3 (make-zeros-matrix (make-instance 'fast-matrix) 2 4))) (is (not (matrix-same-size-p f1 f2))) (is (not (matrix-same-size-p l1 l2))) (is (not (matrix-same-size-p f1 l2))) (is (matrix-same-size-p f1 f3)) (is (matrix-same-size-p l1 l3)) (is (matrix-same-size-p l1 f1)) (is (matrix-same-size-p f1 l3)))) (deftest symmetric-p () (with-fixture hh-5-10 (let ((m1 (make-identity-matrix (make-instance 'matrix) 3)) (f1 (make-identity-matrix (make-instance 'fast-matrix) 3)) (m2 (to-adjacency-matrix *graph* (make-instance 'matrix))) (f2 (to-adjacency-matrix *graph* (make-instance 'fast-matrix)))) (is (matrix-symmetric-p m1)) (is (matrix-symmetric-p f1)) (is (not (matrix-symmetric-p m2))) (is (not (matrix-symmetric-p f2)))))) ;;; Test whether matrix entry comparisons work as expected (deftest matrix-entries-are-not-different () (with-fixture basic-graph (let ((m (to-adjacency-matrix *graph* (make-instance 'matrix)))) (is (not (matrix-entries-different-p m m)))))) (deftest fast-matrix-entries-are-not-different () (with-fixture basic-graph (let ((m (to-adjacency-matrix *graph* (make-instance 'fast-matrix)))) (is (not (matrix-entries-different-p m m)))))) (deftest matrix-entries-are-different () (let ((z (make-zeros-matrix (make-instance 'matrix) 3 3)) (u (make-universal-matrix (make-instance 'matrix) 3 3))) (is (matrix-entries-different-p u z)))) (deftest fast-matrix-entries-are-different () (let ((z (make-zeros-matrix (make-instance 'fast-matrix) 3 3)) (u (make-universal-matrix (make-instance 'fast-matrix) 3 3))) (is (matrix-entries-different-p u z)))) (deftest matrix-entries-are-different-sizes () (let ((z (make-zeros-matrix (make-instance 'matrix) 3 4)) (u (make-universal-matrix (make-instance 'matrix) 3 3))) (is (= 1 (matrix-entries-different-p u z))))) (deftest fast-matrix-entries-are-different-sizes () (let ((z (make-zeros-matrix (make-instance 'fast-matrix) 3 4)) (u (make-universal-matrix (make-instance 'fast-matrix) 3 3))) (is (= 1 (matrix-entries-different-p u z))))) (deftest lisp-and-fast-matrix-entries-are-not-different () (let ((f (make-zeros-matrix (make-instance 'fast-matrix) 3 3)) (l (make-zeros-matrix (make-instance 'matrix) 3 3))) (is (not (matrix-entries-different-p f l))))) ;;; Tests for comparability of lisp and fast matrix operations (deftest lisp-vs-fast-difference () (let ((f0 (make-zeros-matrix (make-instance 'fast-matrix) 3 3)) (f1 (make-universal-matrix (make-instance 'fast-matrix) 3 3)) (l0 (make-zeros-matrix (make-instance 'matrix) 3 3)) (l1 (make-universal-matrix (make-instance 'matrix) 3 3))) (is (not (matrix-entries-different-p (graph-matrix::matrix-difference f0 f1) (graph-matrix::matrix-difference l0 l1)))))) (deftest lisp-vs-fast-sum () (let ((f0 (make-zeros-matrix (make-instance 'fast-matrix) 3 3)) (f1 (make-universal-matrix (make-instance 'fast-matrix) 3 3)) (l0 (make-zeros-matrix (make-instance 'matrix) 3 3)) (l1 (make-universal-matrix (make-instance 'matrix) 3 3))) (is (not (matrix-entries-different-p (graph-matrix::matrix-sum f0 f1) (graph-matrix::matrix-sum l0 l1)))))) (deftest lisp-vs-fast-elementwise-product () (let ((f0 (make-zeros-matrix (make-instance 'fast-matrix) 3 3)) (f1 (make-universal-matrix (make-instance 'fast-matrix) 3 3)) (l0 (make-zeros-matrix (make-instance 'matrix) 3 3)) (l1 (make-universal-matrix (make-instance 'matrix) 3 3))) (is (not (matrix-entries-different-p (graph-matrix::matrix-elementwise-product f0 f1) (graph-matrix::matrix-elementwise-product l0 l1)))))) (deftest lisp-vs-fast-sum-boolean () (let ((f0 (make-zeros-matrix (make-instance 'fast-matrix) 3 3)) (f1 (make-universal-matrix (make-instance 'fast-matrix) 3 3)) (l0 (make-zeros-matrix (make-instance 'matrix) 3 3)) (l1 (make-universal-matrix (make-instance 'matrix) 3 3))) (is (not (matrix-entries-different-p (graph-matrix::matrix-sum f0 f1 :boolean t) (graph-matrix::matrix-sum l0 l1 :boolean t)))))) (deftest lisp-vs-fast-product () (let ((f0 (make-zeros-matrix (make-instance 'fast-matrix) 3 3)) (f1 (make-universal-matrix (make-instance 'fast-matrix) 3 3)) (l0 (make-zeros-matrix (make-instance 'matrix) 3 3)) (l1 (make-universal-matrix (make-instance 'matrix) 3 3))) (is (not (matrix-entries-different-p (graph-matrix::matrix-product f0 f1) (graph-matrix::matrix-product l0 l1)))))) (deftest lisp-vs-fast-transpose () (let ((f0 (make-zeros-matrix (make-instance 'fast-matrix) 3 3)) (f1 (make-universal-matrix (make-instance 'fast-matrix) 3 3)) (l0 (make-zeros-matrix (make-instance 'matrix) 3 3)) (l1 (make-universal-matrix (make-instance 'matrix) 3 3))) (is (not (matrix-entries-different-p (matrix-transpose (graph-matrix::matrix-elementwise-product f0 f1)) (matrix-transpose (graph-matrix::matrix-elementwise-product l0 l1))))))) (deftest lisp-vs-fast-power-0 () (let ((f0 (make-zeros-matrix (make-instance 'fast-matrix) 3 3)) (f1 (make-universal-matrix (make-instance 'fast-matrix) 3 3)) (l0 (make-zeros-matrix (make-instance 'matrix) 3 3)) (l1 (make-universal-matrix (make-instance 'matrix) 3 3))) (is (not (matrix-entries-different-p (graph-matrix::matrix-power (graph-matrix::matrix-elementwise-product f0 f1) 0) (graph-matrix::matrix-power (graph-matrix::matrix-elementwise-product l0 l1) 0)))))) (deftest lisp-vs-fast-power-1 () (let ((f0 (make-zeros-matrix (make-instance 'fast-matrix) 3 3)) (f1 (make-universal-matrix (make-instance 'fast-matrix) 3 3)) (l0 (make-zeros-matrix (make-instance 'matrix) 3 3)) (l1 (make-universal-matrix (make-instance 'matrix) 3 3))) (is (not (matrix-entries-different-p (graph-matrix::matrix-power (graph-matrix::matrix-elementwise-product f0 f1) 1) (graph-matrix::matrix-power (graph-matrix::matrix-elementwise-product l0 l1) 1)))))) (deftest lisp-vs-fast-power-2 () (let ((f0 (make-zeros-matrix (make-instance 'fast-matrix) 3 3)) (f1 (make-universal-matrix (make-instance 'fast-matrix) 3 3)) (l0 (make-zeros-matrix (make-instance 'matrix) 3 3)) (l1 (make-universal-matrix (make-instance 'matrix) 3 3))) (is (not (matrix-entries-different-p (graph-matrix::matrix-power (graph-matrix::matrix-elementwise-product f0 f1) 2) (graph-matrix::matrix-power (graph-matrix::matrix-elementwise-product l0 l1) 2)))))) (deftest lisp-vs-fast-power-3 () (let ((f0 (make-zeros-matrix (make-instance 'fast-matrix) 3 3)) (f1 (make-universal-matrix (make-instance 'fast-matrix) 3 3)) (l0 (make-zeros-matrix (make-instance 'matrix) 3 3)) (l1 (make-universal-matrix (make-instance 'matrix) 3 3))) (is (not (matrix-entries-different-p (graph-matrix::matrix-power (graph-matrix::matrix-elementwise-product f0 f1) 3) (graph-matrix::matrix-power (graph-matrix::matrix-elementwise-product l0 l1) 3)))))) (deftest lisp-vs-fast-copy () (let ((f (make-zeros-matrix (make-instance 'fast-matrix) 3 3)) (l (make-zeros-matrix (make-instance 'matrix) 3 3))) (is (not (matrix-entries-different-p (matrix-copy f) (matrix-copy l)))))) ;;; Tests comparing matrix and fast-matrix results (deftest adjacency-matrix-vs-fast-matrix () (with-fixture basic-graph (let ((m (to-adjacency-matrix *graph* (make-instance 'matrix))) (f (to-adjacency-matrix *graph* (make-instance 'fast-matrix)))) (is (not (matrix-entries-different-p m f)))))) (deftest adjacency-matrix-vs-fast-matrix-digraph () (with-fixture hh-4-18 (let ((m (to-adjacency-matrix *graph* (make-instance 'matrix))) (f (to-adjacency-matrix *graph* (make-instance 'fast-matrix)))) (is (not (matrix-entries-different-p m f)))))) (deftest reachability-matrix-vs-fast-matrix () (with-fixture basic-graph (let ((m (to-reachability-matrix *graph* (make-instance 'matrix))) (f (to-reachability-matrix *graph* (make-instance 'fast-matrix)))) (is (not (matrix-entries-different-p m f)))))) (deftest reachablep-lisp-vs-fast () (with-fixture hh-5-10 (let ((m (to-reachability-matrix *graph* (make-instance 'matrix))) (f (to-reachability-matrix *graph* (make-instance 'fast-matrix)))) (is (and (reachablep *graph* m 1 2) (reachablep *graph* f 1 2))) (is (and (reachablep *graph* m 2 3) (reachablep *graph* f 2 3))) (is (not (or (reachablep *graph* f 2 1) (reachablep *graph* f 2 1))))))) (deftest reachable-from-lisp-vs-fast () (with-fixture hh-5-10 (let ((m (to-reachability-matrix *graph* (make-instance 'matrix))) (f (to-reachability-matrix *graph* (make-instance 'fast-matrix)))) (is (equal (reachable-from *graph* m 1) (reachable-from *graph* f 1))) (is (equal (reachable-from *graph* m 2) (reachable-from *graph* f 2))) (is (equal (reachable-from *graph* m 3) (reachable-from *graph* f 3))) (is (equal (reachable-from *graph* m 4) (reachable-from *graph* f 4))) (is (equal (reachable-from *graph* m 1) '(1 2 3 4))) (is (equal (reachable-from *graph* m 2) '(2 3 4))) (is (equal (reachable-from *graph* m 3) '(2 3 4))) (is (equal (reachable-from *graph* m 4) '(4)))))) (deftest strong-component-matrix-vs-fast-matrix () (with-fixture hh-5-10 (let ((m (to-reachability-matrix *graph* (make-instance 'matrix))) (f (to-reachability-matrix *graph* (make-instance 'fast-matrix)))) (is (not (matrix-entries-different-p (to-strong-component-matrix m) (to-strong-component-matrix f))))))) (deftest strong-component-of-lisp-vs-fast-matrix () (with-fixture hh-5-10 (let ((m (to-strong-component-matrix (to-reachability-matrix *graph* (make-instance 'matrix)))) (f (to-strong-component-matrix (to-reachability-matrix *graph* (make-instance 'fast-matrix))))) (is (equal (strong-component-of 1 *graph* m) (strong-component-of 1 *graph* f))) (is (equal (strong-component-of 2 *graph* m) (strong-component-of 2 *graph* f))) (is (equal (strong-component-of 3 *graph* m) (strong-component-of 3 *graph* f))) (is (equal (strong-component-of 4 *graph* m) (strong-component-of 4 *graph* f)))))) (deftest distance-matrix-vs-fast-matrix () (with-fixture basic-graph (let ((m (to-distance-matrix *graph* (make-instance 'matrix))) (f (to-distance-matrix *graph* (make-instance 'fast-matrix)))) (is (not (matrix-entries-different-p m f)))))) (deftest distance-from-to-lisp-vs-fast-matrix () (with-fixture basic-graph (let ((m (to-distance-matrix *graph* (make-instance 'matrix))) (f (to-distance-matrix *graph* (make-instance 'fast-matrix)))) (is (= (distance-from-to *graph* m 'a 'b) (distance-from-to *graph* f 'a 'b))) (is (= (distance-from-to *graph* m 'a 'c) (distance-from-to *graph* f 'a 'c))) (is (= (distance-from-to *graph* m 'a 'd) (distance-from-to *graph* f 'a 'd))) (is (= (distance-from-to *graph* m 'a 'e) (distance-from-to *graph* f 'a 'e))) (is (= (distance-from-to *graph* m 'a 'f) (distance-from-to *graph* f 'a 'f)))))) ;;; Tests comparing results of lisp matrix routines to Hage and Harary's book (deftest digraph-and-adjacency-matrix () (let ((m (make-instance 'matrix))) (setf (graph-matrix::self m) (make-array '(4 4) :element-type 'fixnum :initial-contents '((0 0 1 1) (1 0 1 0) (0 1 0 0) (1 0 1 0)))) (with-fixture hh-5-3 (is (not (matrix-entries-different-p (to-adjacency-matrix *graph* (make-instance 'matrix)) m)))))) (deftest digraph-and-reachability-matrix () (let ((m (make-instance 'matrix))) (setf (graph-matrix::self m) (make-array '(4 4) :element-type 'fixnum :initial-contents '((1 1 1 1)(0 1 1 1)(0 1 1 1)(0 0 0 1)))) (with-fixture hh-5-10 (is (not (matrix-entries-different-p (to-reachability-matrix *graph* (make-instance 'matrix)) m)))))) ;;; This is the matrix R2 on p. 126 of Exchange in Oceania: A Graph ;;; Theoretic Analysis by Per Hage and Frank Harary (deftest digraph-and-reachability-matrix-with-limit-2 () (let ((m (make-instance 'matrix))) (setf (graph-matrix::self m) (make-array '(4 4) :element-type 'fixnum :initial-contents '((1 1 1 1)(1 1 1 0)(1 1 1 1)(1 0 1 1)))) (with-fixture hh-4-5 (is (not (matrix-entries-different-p (to-reachability-matrix *graph* (make-instance 'matrix) :limit 2) m)))))) (deftest digraph-and-distance-matrix () (let* ((m (make-instance 'matrix)) (i (graph-matrix::infinite m))) (setf (graph-matrix::self m) (make-array '(5 5) :initial-contents `((0 1 1 ,i ,i) (2 0 1 ,i ,i) (1 2 0 ,i ,i) (2 3 1 0 ,i) (1 2 2 1 0)))) (with-fixture hh-5-11 (let ((d (to-distance-matrix *graph* (make-instance 'matrix)))) (is (not (matrix-entries-different-p d m))))))) (deftest digraph-and-strong-component-matrix () (let ((m (make-instance 'matrix))) (setf (graph-matrix::self m) (make-array '(8 8) :element-type 'fixnum :initial-contents '((1 0 0 0 0 0 0 0) (0 1 0 0 0 0 0 0) (0 0 1 0 0 0 0 0) (0 0 0 1 1 1 0 0) (0 0 0 1 1 1 0 0) (0 0 0 1 1 1 0 0) (0 0 0 0 0 0 1 0) (0 0 0 0 0 0 0 1)))) (with-fixture hh-4-18 (is (not (matrix-entries-different-p (to-strong-component-matrix (to-reachability-matrix *graph* (make-instance 'matrix))) m)))))) ;;; Tests of Peirce relations (deftest relation-test () (with-fixture relation (is (not (relational-structure *graph* (make-instance 'matrix)))))) (deftest digraph-test () (with-fixture digraph (is (relational-structure *graph* (make-instance 'matrix)) "digraph"))) (deftest graph-test () (with-fixture graph (is (relational-structure *graph* (make-instance 'matrix)) "graph"))) (deftest oriented-graph-test () (with-fixture oriented-graph (is (relational-structure *graph* (make-instance 'matrix)) "oriented graph"))) (deftest similarity-relation-test () (with-fixture similarity-relation (is (relational-structure *graph* (make-instance 'matrix)) "similarity relation"))) (deftest equivalence-relation-test () (with-fixture equivalence-relation (is (relational-structure *graph* (make-instance 'matrix)) "equivalence relation"))) (deftest complete-order-test () (with-fixture complete-order (is (relational-structure *graph* (make-instance 'matrix)) "complete order"))) (deftest tournament-test () (with-fixture tournament (is (relational-structure *graph* (make-instance 'matrix)) "tournament"))) (deftest parity-relation-test () (with-fixture parity-relation (is (relational-structure *graph* (make-instance 'matrix)) "parity relation"))) (deftest antiequivalence-relation-test () (with-fixture antiequivalence-relation (is (relational-structure *graph* (make-instance 'matrix)) "antiequivalence relation"))) (deftest antiparity-relation-test () (with-fixture antiparity-relation (is (relational-structure *graph* (make-instance 'matrix)) "antiparity relation"))) graph-20161031-git/test/graph.lisp000066400000000000000000000412651300110062200165750ustar00rootroot00000000000000;;; test/graph.lisp --- tests for the graph library ;; Copyright (C) Eric Schulte 2012 ;; Licensed under the Gnu Public License Version 3 or later ;;; Code: (in-package :graph-test) (eval-when (:compile-toplevel :load-toplevel :execute) (enable-curry-compose-reader-macros)) (defsuite test) (in-suite test) (defvar *graph* nil "Variable for use in graph tests.") (defvar *network* nil "Variable for use in graph tests.") (defvar *cycle* nil "Variable for use in graph tests.") (defvar *digraph* nil "Digraph for use in graph tests.") (defvar *halfs* nil "Variable for use in graph tests.") (defvar *star* nil "Variable for use in graph tests.") (defixture small-graph (:setup (setf *graph* (populate (make-instance 'graph) :nodes '(:foo :bar :baz :qux) :edges '((:foo :bar) (:foo :baz) (:bar :baz))))) (:teardown (setf *graph* nil))) (defixture less-small-graph (:setup (setf *graph* (populate (make-instance 'graph) :nodes '(:foo :bar :baz :qux :zap :zaf :fiz) :edges '((:foo :bar) (:bar :baz) (:baz :foo) (:zap :zaf) (:zaf :qux) (:qux :zap) (:fiz :fiz))))) (:teardown (setf *graph* nil))) (defixture normal-graph (:setup (setf *graph* (populate (make-instance 'graph) :nodes '(a b c d e f) :edges '((a b) (b c) (c d) (d e) (e c) (e f) (f b))))) (:teardown (setf *graph* nil))) (defixture small-network (:setup (setf *network* (populate (make-instance 'graph) :nodes '(:a :b :s :t) :edges-w-values '(((:a :b) . 1) ((:s :a) . 2) ((:s :b) . 1) ((:a :t) . 4) ((:b :t) . 2))))) (:teardown (setf *network* nil))) (defixture cycle (:setup (setf *cycle* (populate (make-instance 'digraph) :nodes '(:a :b :s :t) :edges-w-values '(((:s :a) . 1) ((:s :b) . 3) ((:b :a) . 1) ((:a :t) . 2) ((:b :t) . 2) ((:t :s) . 2))))) (:teardown (setf *cycle* nil))) (defixture digraph (:setup (setf *digraph* (populate (make-instance 'digraph) :nodes '(a b c d e f g) :edges-w-values '(((a b) . 3) ((b d) . 1) ((b c) . 2) ((c e) . 1) ((d e) . 2) ((e f) . 3)))))) (defixture halfs (:setup (setf *halfs* (populate (make-instance 'graph) :edges-w-values '(((:a :b) . 10) ((:b :c) . 10) ((:c :a) . 10) ((:q :r) . 20) ((:r :s) . 20) ((:s :q) . 20) ((:c :s) . 2))))) (:teardown (setf *halfs* nil))) (defixture star (:setup (setf *star* (populate (make-instance 'graph) :edges '((:a :s) (:b :s) (:c :s) (:d :s) (:e :s) (:f :s) (:g :s) (:h :s))))) (:teardown (setf *star* nil))) ;;; Tests (deftest make-graph-sets-nodes () (with-fixture small-graph (is (set-equal (nodes *graph*) '(:FOO :BAR :BAZ :QUX))))) (deftest make-graph-sets-edges () (with-fixture small-graph (is (set-equal (edges *graph*) '((:FOO :BAR) (:FOO :BAZ) (:BAR :BAZ)) :test 'tree-equal)))) (deftest node-edge-for-foo () (with-fixture small-graph (is (tree-equal (node-edges *graph* :foo) '((:FOO :BAZ) (:FOO :BAR)))) (is (tree-equal (setf (node-edges *graph* :foo) '((:foo :qux))) '((:FOO :BAZ) (:FOO :BAR)))) (is (tree-equal (node-edges *graph* :foo) '((:FOO :QUX)))) (is (set-equal (edges *graph*) '((:FOO :QUX) (:BAR :BAZ)) :test #'tree-equal)))) (deftest delete-an-edge-from-small-graph () (with-fixture small-graph (is (null (delete-edge *graph* '(:foo :bar)))) (is (= 2 (length (edges *graph*)))) (is (= 1 (length (node-edges *graph* :foo)))))) (deftest add-duplicate-edge-to-small-graph () (with-fixture small-graph (add-edge *graph* '(:bar :foo)) (is (not (member '(:bar :foo) (edges *graph*) :test #'tree-equal))) (is (not (member '(:bar :foo) (node-edges *graph* :bar)))))) (deftest edge-value-for-foo-bar () (with-fixture small-graph (is (null (edge-value *graph* '(:foo :bar)))) (setf (edge-value *graph* '(:foo :bar)) 22) (is (= 22 (edge-value *graph* '(:foo :bar)))))) (deftest copy-of-a-graph () (with-fixture small-graph (let ((c (copy *graph*))) (is (set-equal (nodes *graph*) (nodes c))) (is (set-equal (edges *graph*) (edges c) :test #'tree-equal)) (delete-node c :foo) (is (not (set-equal (nodes *graph*) (nodes c)))) (is (not (set-equal (edges *graph*) (edges c) :test #'tree-equal)))))) (deftest copy-of-a-graph-w-graph-equal () (with-fixture less-small-graph (is (graph-equal *graph* (copy *graph*))))) (deftest merge-nodes-in-small-graph () (with-fixture small-graph (setf *graph* (merge-nodes *graph* :bar :baz :new :zap)) (is (set-equal (nodes *graph*) '(:FOO :QUX :ZAP))) (is (set-equal (edges *graph*) '((:FOO :ZAP)) :test #'tree-equal)))) (deftest merge-nodes-in-small-network () (with-fixture small-network (setf *network* (merge-nodes *network* :a :b :new :ab)) (is (set-equal (nodes *network*) '(:S :T :AB))) (is (set-equal (edges-w-values *network*) '(((:S :AB) . 3) ((:AB :T) . 6)) :test #'tree-equal)))) (deftest merge-edges-in-small-graph () (with-fixture small-graph (merge-edges *graph* '(:foo :bar) '(:foo :baz)) (is (set-equal (edges *graph*) '((:BAR :BAZ) (:BAR :FOO :BAZ)) :test #'tree-equal)))) (deftest edge-neighbors-of-c-on-graph () (with-fixture less-small-graph (is (set-equal (edge-neighbors *graph* '(:foo :bar)) '((:BAZ :FOO) (:FOO :BAR) (:BAR :BAZ) (:FOO :BAR)) :test #'tree-equal)))) (deftest neighbors-of-c-on-graph () (with-fixture normal-graph (is (every (lambda (it) (member it (neighbors *graph* 'b))) '(a b c))))) (deftest neighbors-of-e-on-digraph () (with-fixture normal-graph (is (set-equal (neighbors (digraph-of *graph*) 'e) '(C F))))) (deftest conected-component-of-e-on-digraph () (with-fixture normal-graph (is (set-equal (connected-component (digraph-of *graph*) 'e) '(C E D B F))))) (deftest is-normal-digraph-connected () (with-fixture normal-graph (is (not (connectedp (digraph-of *graph*)))))) (deftest connected-component-e-in-normal-graph () (with-fixture normal-graph (is (set-equal (connected-component *graph* 'e) (nodes *graph*))))) (deftest connected-component-of-foo-in-small-digraph () (with-fixture small-graph (is (set-equal (connected-component (digraph-of *graph*) :foo) '(:foo :bar :baz))) (is (set-equal (connected-component (digraph-of *graph*) :bar) '(:bar :baz))))) (deftest connected-component-of-a-cycle () (with-fixture cycle (is (set-equal (connected-component *cycle* :s) (nodes *cycle*))))) (deftest connectedp-of-multiple-graphs () (with-fixture small-graph (is (not (connectedp *graph*)))) (with-fixture less-small-graph (is (not (connectedp *graph*)))) (with-fixture normal-graph (is (connectedp *graph*)))) (deftest connected-components-of-less-small-graph () (with-fixture less-small-graph (is (set-equal (connected-components *graph*) '((:ZAP :ZAF :QUX) (:FIZ) (:BAZ :FOO :BAR)) :test #'set-equal)))) (deftest strongly-connected-components-of-small-graph () (with-fixture small-graph (is (set-equal (strongly-connected-components *graph*) '((:QUX) (:BAR :BAZ :FOO)) :test #'set-equal)))) (deftest topological-sort-with-digraph () (with-fixture digraph (let ((s (topological-sort *digraph*))) (is (not (dolist (x (edges *digraph*)) (when (> (position (car x) s) (position (cadr x) s)) (return t)))))))) (deftest levels-with-digraph () (with-fixture digraph (let ((l (levels *digraph*))) (is (not (dolist (x (edges *digraph*)) (when (> (gethash (car x) l) (gethash (cadr x) l)) (return t)))))))) (deftest basic-cycles-of-small-graph () (with-fixture small-graph (is (set-equal (basic-cycles *graph*) '((:BAR :BAZ :FOO)) :test #'set-equal)))) (deftest basic-cycles-of-less-small-graph () (with-fixture less-small-graph (is (set-equal (basic-cycles *graph*) '((:ZAF :ZAP :QUX) (:BAR :BAZ :FOO)) :test #'set-equal)))) (deftest basic-cycles-of-graph () (with-fixture normal-graph (is (set-equal (basic-cycles *graph*) '((D C E) (D C B F E) (C B F E)) :test #'set-equal)))) (deftest cycles-of-graph () (with-fixture normal-graph (is (set-equal (cycles *graph*) '((D C E) (D C B F E) (C B F E)) :test #'set-equal)))) (deftest cycles-of-a-digraph () (with-fixture digraph (is (null (cycles *digraph*))))) (deftest minimum-spanning-tree-on-a-network () (with-fixture small-network (is (= (reduce #'+ (mapcar {edge-value *network*} (edges (minimum-spanning-tree *network*)))) 4)))) (deftest connected-groups-of-size-in-less-small-graph () (with-fixture less-small-graph (is (= (length (edges *graph*)) (length (connected-groups-of-size *graph* 2)))) (is (set-equal '((:foo :bar :baz) (:zaf :qux :zap)) (connected-groups-of-size *graph* 3) :test #'set-equal)) (is (null (connected-groups-of-size *graph* 4))))) (deftest closed-groups-in-less-small-graph () (with-fixture less-small-graph (is (every {closedp *graph*} (connected-groups-of-size *graph* 3))))) (deftest clustering-coefficient-of-less-small-graph () (with-fixture less-small-graph (is (= 1 (clustering-coefficient *graph*))))) (deftest cliques-of-some-graphs () (with-fixture less-small-graph (is (set-equal (cliques *graph*) '((:FIZ) (:QUX :ZAF :ZAP) (:FOO :BAZ :BAR)) :test #'set-equal))) (with-fixture halfs (is (set-equal (cliques *halfs*) '((:Q :S :R) (:C :S) (:A :C :B)) :test #'set-equal)))) (deftest shortest-path-between-foo-and-baz-or-qux () (with-fixture less-small-graph (is (tree-equal (shortest-path (digraph-of *graph*) :foo :baz) '((:FOO :BAR) (:BAR :BAZ)))))) (deftest shortest-path-through-a-residual () (with-fixture cycle (let* ((flow '(((:A :T) . 1) ((:S :A) . 1) ((:B :T) . 2) ((:S :B) . 2))) (residual (residual *cycle* flow))) (is (shortest-path residual :s :t))))) (deftest shortest-path-against-undirected-edge () (with-fixture star (is (tree-equal (shortest-path *star* :a :g) '((:a :s) (:g :s)))))) (deftest residual-of-a-small-network () (with-fixture small-network (let ((orig-edges (copy-tree (edges-w-values *network*))) (resi-edges (edges-w-values (residual (digraph-of *network*) '(((:s :a) . 2) ((:a :t) . 2)))))) (is (= (cdr (assoc '(:a :s) resi-edges :test 'tree-equal))) 2) (is (= (cdr (assoc '(:a :t) resi-edges :test 'tree-equal))) 2) (is (tree-equal orig-edges (edges-w-values *network*)))))) (deftest max-flow-on-a-small-network () (with-fixture small-network (multiple-value-bind (path flow) (max-flow (digraph-of *network*) :s :t) (is (set-equal path '(((:A :T) . 2) ((:S :A) . 2) ((:B :T) . 1) ((:S :B) . 1)) :test #'tree-equal)) (is (= flow 3))))) (deftest max-flow-with-a-cycle () (with-fixture cycle (multiple-value-bind (flow value) (max-flow *cycle* :s :t) (is (set-equal flow '(((:B :A) . 1) ((:A :T) . 2) ((:S :A) . 1) ((:B :T) . 2) ((:S :B) . 3)) :test #'tree-equal)) (is (= value 4))))) (deftest min-cut-on-a-small-network () (with-fixture small-network (multiple-value-bind (cut weight) (min-cut *network*) (is (set-equal cut '((:S) (:T :B :A)) :test 'set-equal)) (is (= 3 weight))))) (deftest min-cut-on-a-graph-of-two-halfs () (with-fixture halfs (multiple-value-bind (cut weight) (min-cut *halfs*) (is (set-equal cut '((:a :b :c) (:q :r :s)) :test 'set-equal)) (is (= 2 weight))))) (deftest small-graph-to-plist () (with-fixture small-graph (let* ((plist (to-plist *graph*)) (edges (mapcar {mapcar {position _ (mapcar #'second (getf plist :nodes))}} (edges *graph*)))) (is (set-equal (getf plist :nodes) '((:NAME :FOO) (:NAME :BAR) (:NAME :BAZ) (:NAME :QUX)) :test 'tree-equal)) (is (set-equal (mapcar {getf _ :edge} (getf plist :edges)) edges :test 'set-equal)) (is (set-equal (mapcar {getf _ :value} (getf plist :edges)) '(NIL NIL NIL NIL)))))) (deftest two-way-plist-conversion-on-multiple-graphs () (with-fixture small-graph (is (graph-equal *graph* (from-plist (make-instance 'graph) (to-plist *graph*))))) (with-fixture less-small-graph (is (graph-equal *graph* (from-plist (make-instance 'graph) (to-plist *graph*))))) (with-fixture small-network (is (graph-equal *network* (from-plist (make-instance 'graph) (to-plist *network*)))))) (deftest test-preferential-attachment-population () (let ((graph (make-instance 'graph)) (many 1000)) (preferential-attachment-populate graph (loop :for i :below many :collect i)) (is (= many (length (nodes graph)))) (is (= (1- many) (length (edges graph)))))) (deftest test-erdos-renyi-graphs () (let ((g (erdos-renyi-graph 8 16))) (is (= 8 (length (nodes g)))) (is (= 16 (length (edges g))))) (let ((dg (erdos-renyi-digraph 3 5))) (is (= 3 (length (nodes dg)))) (is (= 5 (length (edges dg)))))) (deftest farness-of-s-in-network () (with-fixture small-network (is (= 4 (farness *network* :s))))) (deftest betweenness-of-center-of-a-star () (with-fixture star (is (= 1 (betweenness *star* :s))) (is (= 0 (betweenness *star* :a))))) (deftest conversion-to-value-matrix () (flet ((sum (array) (let ((dims (array-dimensions array))) (reduce #'+ (mapcar {reduce #'+} (loop :for x :below (first dims) :collect (loop :for y :below (second dims) :collect (let ((val (aref array x y))) (cond ((numberp val) val) ((null val) 0) (t 1)))))))))) (with-fixture small-network (is (= (sum (to-value-matrix *network*)) (reduce #'+ (mapcar #'cdr (edges-w-values *network*)))))) (with-fixture halfs (is (= (sum (to-value-matrix *halfs*)) (reduce #'+ (mapcar #'cdr (edges-w-values *halfs*)))))))) (deftest conversion-from-value-matrix () (is (set-equal (edges-w-values (from-value-matrix (make-instance 'graph) #2A((nil 1 nil) (nil nil 2) (nil nil nil)))) '(((1 2) . 2) ((0 1) . 1)) :test 'equalp))) graph-20161031-git/test/package-matrix.lisp000066400000000000000000000003161300110062200203610ustar00rootroot00000000000000(defpackage #:graph-matrix-test (:use :common-lisp :alexandria :metabang-bind :graph :graph-matrix :stefil :curry-compose-reader-macros) (:export :test)) graph-20161031-git/test/package.lisp000066400000000000000000000002611300110062200170560ustar00rootroot00000000000000(defpackage #:graph-test (:use :common-lisp :alexandria :metabang-bind :graph :stefil :curry-compose-reader-macros) (:export :test))