diff --git a/COPYING b/COPYING new file mode 100644 --- /dev/null +++ b/COPYING @@ -0,0 +1,661 @@ + GNU AFFERO GENERAL PUBLIC LICENSE + Version 3, 19 November 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 Affero General Public License is a free, copyleft license for +software and other kinds of works, specifically designed to ensure +cooperation with the community in the case of network server software. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +our General Public Licenses are intended to guarantee your freedom to +share and change all versions of a program--to make sure it remains free +software for all its users. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +them if you wish), that you receive source code or can get it if you +want it, that you can change the software or use pieces of it in new +free programs, and that you know you can do these things. + + Developers that use our General Public Licenses protect your rights +with two steps: (1) assert copyright on the software, and (2) offer +you this License which gives you legal permission to copy, distribute +and/or modify the software. + + A secondary benefit of defending all users' freedom is that +improvements made in alternate versions of the program, if they +receive widespread use, become available for other developers to +incorporate. Many developers of free software are heartened and +encouraged by the resulting cooperation. However, in the case of +software used on network servers, this result may fail to come about. +The GNU General Public License permits making a modified version and +letting the public access it on a server without ever releasing its +source code to the public. + + The GNU Affero General Public License is designed specifically to +ensure that, in such cases, the modified source code becomes available +to the community. It requires the operator of a network server to +provide the source code of the modified version running there to the +users of that server. Therefore, public use of a modified version, on +a publicly accessible server, gives the public access to the source +code of the modified version. + + An older license, called the Affero General Public License and +published by Affero, was designed to accomplish similar goals. This is +a different license, not a version of the Affero GPL, but Affero has +released a new version of the Affero GPL which permits relicensing under +this license. + + The precise terms and conditions for copying, distribution and +modification follow. + + TERMS AND CONDITIONS + + 0. Definitions. + + "This License" refers to version 3 of the GNU Affero General Public License. + + "Copyright" also means copyright-like laws that apply to other kinds of +works, such as semiconductor masks. + + "The Program" refers to any copyrightable work licensed under this +License. Each licensee is addressed as "you". "Licensees" and +"recipients" may be individuals or organizations. + + To "modify" a work means to copy from or adapt all or part of the work +in a fashion requiring copyright permission, other than the making of an +exact copy. The resulting work is called a "modified version" of the +earlier work or a work "based on" the earlier work. + + A "covered work" means either the unmodified Program or a work based +on the Program. + + To "propagate" a work means to do anything with it that, without +permission, would make you directly or secondarily liable for +infringement under applicable copyright law, except executing it on a +computer or modifying a private copy. Propagation includes copying, +distribution (with or without modification), making available to the +public, and in some countries other activities as well. + + To "convey" a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user through +a computer network, with no transfer of a copy, is not conveying. + + An interactive user interface displays "Appropriate Legal Notices" +to the extent that it includes a convenient and prominently visible +feature that (1) displays an appropriate copyright notice, and (2) +tells the user that there is no warranty for the work (except to the +extent that warranties are provided), that licensees may convey the +work under this License, and how to view a copy of this License. If +the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + + 1. Source Code. + + The "source code" for a work means the preferred form of the work +for making modifications to it. "Object code" means any non-source +form of a work. + + A "Standard Interface" means an interface that either is an official +standard defined by a recognized standards body, or, in the case of +interfaces specified for a particular programming language, one that +is widely used among developers working in that language. + + The "System Libraries" of an executable work include anything, other +than the work as a whole, that (a) is included in the normal form of +packaging a Major Component, but which is not part of that Major +Component, and (b) serves only to enable use of the work with that +Major Component, or to implement a Standard Interface for which an +implementation is available to the public in source code form. A +"Major Component", in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system +(if any) on which the executable work runs, or a compiler used to +produce the work, or an object code interpreter used to run it. + + The "Corresponding Source" for a work in object code form means all +the source code needed to generate, install, and (for an executable +work) run the object code and to modify the work, including scripts to +control those activities. However, it does not include the work's +System Libraries, or general-purpose tools or generally available free +programs which are used unmodified in performing those activities but +which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for +the work, and the source code for shared libraries and dynamically +linked subprograms that the work is specifically designed to require, +such as by intimate data communication or control flow between those +subprograms and other parts of the work. + + The Corresponding Source need not include anything that users +can regenerate automatically from other parts of the Corresponding +Source. + + The Corresponding Source for a work in source code form is that +same work. + + 2. Basic Permissions. + + All rights granted under this License are granted for the term of +copyright on the Program, and are irrevocable provided the stated +conditions are met. This License explicitly affirms your unlimited +permission to run the unmodified Program. The output from running a +covered work is covered by this License only if the output, given its +content, constitutes a covered work. This License acknowledges your +rights of fair use or other equivalent, as provided by copyright law. + + You may make, run and propagate covered works that you do not +convey, without conditions so long as your license otherwise remains +in force. You may convey covered works to others for the sole purpose +of having them make modifications exclusively for you, or provide you +with facilities for running those works, provided that you comply with +the terms of this License in conveying all material for which you do +not control copyright. Those thus making or running the covered works +for you must do so exclusively on your behalf, under your direction +and control, on terms that prohibit them from making any copies of +your copyrighted material outside their relationship with you. + + Conveying under any other circumstances is permitted solely under +the conditions stated below. Sublicensing is not allowed; section 10 +makes it unnecessary. + + 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + + No covered work shall be deemed part of an effective technological +measure under any applicable law fulfilling obligations under article +11 of the WIPO copyright treaty adopted on 20 December 1996, or +similar laws prohibiting or restricting circumvention of such +measures. + + When you convey a covered work, you waive any legal power to forbid +circumvention of technological measures to the extent such circumvention +is effected by exercising rights under this License with respect to +the covered work, and you disclaim any intention to limit operation or +modification of the work as a means of enforcing, against the work's +users, your or third parties' legal rights to forbid circumvention of +technological measures. + + 4. Conveying Verbatim Copies. + + You may convey verbatim copies of the Program's source code as you +receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice; +keep intact all notices stating that this License and any +non-permissive terms added in accord with section 7 apply to the code; +keep intact all notices of the absence of any warranty; and give all +recipients a copy of this License along with the Program. + + You may charge any price or no price for each copy that you convey, +and you may offer support or warranty protection for a fee. + + 5. Conveying Modified Source Versions. + + You may convey a work based on the Program, or the modifications to +produce it from the Program, in the form of source code under the +terms of section 4, provided that you also meet all of these conditions: + + a) The work must carry prominent notices stating that you modified + it, and giving a relevant date. + + b) The work must carry prominent notices stating that it is + released under this License and any conditions added under section + 7. This requirement modifies the requirement in section 4 to + "keep intact all notices". + + c) You must license the entire work, as a whole, under this + License to anyone who comes into possession of a copy. This + License will therefore apply, along with any applicable section 7 + additional terms, to the whole of the work, and all its parts, + regardless of how they are packaged. This License gives no + permission to license the work in any other way, but it does not + invalidate such permission if you have separately received it. + + d) If the work has interactive user interfaces, each must display + Appropriate Legal Notices; however, if the Program has interactive + interfaces that do not display Appropriate Legal Notices, your + work need not make them do so. + + A compilation of a covered work with other separate and independent +works, which are not by their nature extensions of the covered work, +and which are not combined with it such as to form a larger program, +in or on a volume of a storage or distribution medium, is called an +"aggregate" if the compilation and its resulting copyright are not +used to limit the access or legal rights of the compilation's users +beyond what the individual works permit. Inclusion of a covered work +in an aggregate does not cause this License to apply to the other +parts of the aggregate. + + 6. Conveying Non-Source Forms. + + You may convey a covered work in object code form under the terms +of sections 4 and 5, provided that you also convey the +machine-readable Corresponding Source under the terms of this License, +in one of these ways: + + a) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by the + Corresponding Source fixed on a durable physical medium + customarily used for software interchange. + + b) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by a + written offer, valid for at least three years and valid for as + long as you offer spare parts or customer support for that product + model, to give anyone who possesses the object code either (1) a + copy of the Corresponding Source for all the software in the + product that is covered by this License, on a durable physical + medium customarily used for software interchange, for a price no + more than your reasonable cost of physically performing this + conveying of source, or (2) access to copy the + Corresponding Source from a network server at no charge. + + c) Convey individual copies of the object code with a copy of the + written offer to provide the Corresponding Source. This + alternative is allowed only occasionally and noncommercially, and + only if you received the object code with such an offer, in accord + with subsection 6b. + + d) Convey the object code by offering access from a designated + place (gratis or for a charge), and offer equivalent access to the + Corresponding Source in the same way through the same place at no + further charge. You need not require recipients to copy the + Corresponding Source along with the object code. If the place to + copy the object code is a network server, the Corresponding Source + may be on a different server (operated by you or a third party) + that supports equivalent copying facilities, provided you maintain + clear directions next to the object code saying where to find the + Corresponding Source. Regardless of what server hosts the + Corresponding Source, you remain obligated to ensure that it is + available for as long as needed to satisfy these requirements. + + e) Convey the object code using peer-to-peer transmission, provided + you inform other peers where the object code and Corresponding + Source of the work are being offered to the general public at no + charge under subsection 6d. + + A separable portion of the object code, whose source code is excluded +from the Corresponding Source as a System Library, need not be +included in conveying the object code work. + + A "User Product" is either (1) a "consumer product", which means any +tangible personal property which is normally used for personal, family, +or household purposes, or (2) anything designed or sold for incorporation +into a dwelling. In determining whether a product is a consumer product, +doubtful cases shall be resolved in favor of coverage. For a particular +product received by a particular user, "normally used" refers to a +typical or common use of that class of product, regardless of the status +of the particular user or of the way in which the particular user +actually uses, or expects or is expected to use, the product. A product +is a consumer product regardless of whether the product has substantial +commercial, industrial or non-consumer uses, unless such uses represent +the only significant mode of use of the product. + + "Installation Information" for a User Product means any methods, +procedures, authorization keys, or other information required to install +and execute modified versions of a covered work in that User Product from +a modified version of its Corresponding Source. The information must +suffice to ensure that the continued functioning of the modified object +code is in no case prevented or interfered with solely because +modification has been made. + + If you convey an object code work under this section in, or with, or +specifically for use in, a User Product, and the conveying occurs as +part of a transaction in which the right of possession and use of the +User Product is transferred to the recipient in perpetuity or for a +fixed term (regardless of how the transaction is characterized), the +Corresponding Source conveyed under this section must be accompanied +by the Installation Information. But this requirement does not apply +if neither you nor any third party retains the ability to install +modified object code on the User Product (for example, the work has +been installed in ROM). + + The requirement to provide Installation Information does not include a +requirement to continue to provide support service, warranty, or updates +for a work that has been modified or installed by the recipient, or for +the User Product in which it has been modified or installed. Access to a +network may be denied when the modification itself materially and +adversely affects the operation of the network or violates the rules and +protocols for communication across the network. + + Corresponding Source conveyed, and Installation Information provided, +in accord with this section must be in a format that is publicly +documented (and with an implementation available to the public in +source code form), and must require no special password or key for +unpacking, reading or copying. + + 7. Additional Terms. + + "Additional permissions" are terms that supplement the terms of this +License by making exceptions from one or more of its conditions. +Additional permissions that are applicable to the entire Program shall +be treated as though they were included in this License, to the extent +that they are valid under applicable law. If additional permissions +apply only to part of the Program, that part may be used separately +under those permissions, but the entire Program remains governed by +this License without regard to the additional permissions. + + When you convey a copy of a covered work, you may at your option +remove any additional permissions from that copy, or from any part of +it. (Additional permissions may be written to require their own +removal in certain cases when you modify the work.) You may place +additional permissions on material, added by you to a covered work, +for which you have or can give appropriate copyright permission. + + Notwithstanding any other provision of this License, for material you +add to a covered work, you may (if authorized by the copyright holders of +that material) supplement the terms of this License with terms: + + a) Disclaiming warranty or limiting liability differently from the + terms of sections 15 and 16 of this License; or + + b) Requiring preservation of specified reasonable legal notices or + author attributions in that material or in the Appropriate Legal + Notices displayed by works containing it; or + + c) Prohibiting misrepresentation of the origin of that material, or + requiring that modified versions of such material be marked in + reasonable ways as different from the original version; or + + d) Limiting the use for publicity purposes of names of licensors or + authors of the material; or + + e) Declining to grant rights under trademark law for use of some + trade names, trademarks, or service marks; or + + f) Requiring indemnification of licensors and authors of that + material by anyone who conveys the material (or modified versions of + it) with contractual assumptions of liability to the recipient, for + any liability that these contractual assumptions directly impose on + those licensors and authors. + + All other non-permissive additional terms are considered "further +restrictions" within the meaning of section 10. If the Program as you +received it, or any part of it, contains a notice stating that it is +governed by this License along with a term that is a further +restriction, you may remove that term. If a license document contains +a further restriction but permits relicensing or conveying under this +License, you may add to a covered work material governed by the terms +of that license document, provided that the further restriction does +not survive such relicensing or conveying. + + If you add terms to a covered work in accord with this section, you +must place, in the relevant source files, a statement of the +additional terms that apply to those files, or a notice indicating +where to find the applicable terms. + + Additional terms, permissive or non-permissive, may be stated in the +form of a separately written license, or stated as exceptions; +the above requirements apply either way. + + 8. Termination. + + You may not propagate or modify a covered work except as expressly +provided under this License. Any attempt otherwise to propagate or +modify it is void, and will automatically terminate your rights under +this License (including any patent licenses granted under the third +paragraph of section 11). + + However, if you cease all violation of this License, then your +license from a particular copyright holder is reinstated (a) +provisionally, unless and until the copyright holder explicitly and +finally terminates your license, and (b) permanently, if the copyright +holder fails to notify you of the violation by some reasonable means +prior to 60 days after the cessation. + + Moreover, your license from a particular copyright holder is +reinstated permanently if the copyright holder notifies you of the +violation by some reasonable means, this is the first time you have +received notice of violation of this License (for any work) from that +copyright holder, and you cure the violation prior to 30 days after +your receipt of the notice. + + Termination of your rights under this section does not terminate the +licenses of parties who have received copies or rights from you under +this License. If your rights have been terminated and not permanently +reinstated, you do not qualify to receive new licenses for the same +material under section 10. + + 9. Acceptance Not Required for Having Copies. + + You are not required to accept this License in order to receive or +run a copy of the Program. Ancillary propagation of a covered work +occurring solely as a consequence of using peer-to-peer transmission +to receive a copy likewise does not require acceptance. However, +nothing other than this License grants you permission to propagate or +modify any covered work. These actions infringe copyright if you do +not accept this License. Therefore, by modifying or propagating a +covered work, you indicate your acceptance of this License to do so. + + 10. Automatic Licensing of Downstream Recipients. + + Each time you convey a covered work, the recipient automatically +receives a license from the original licensors, to run, modify and +propagate that work, subject to this License. You are not responsible +for enforcing compliance by third parties with this License. + + An "entity transaction" is a transaction transferring control of an +organization, or substantially all assets of one, or subdividing an +organization, or merging organizations. If propagation of a covered +work results from an entity transaction, each party to that +transaction who receives a copy of the work also receives whatever +licenses to the work the party's predecessor in interest had or could +give under the previous paragraph, plus a right to possession of the +Corresponding Source of the work from the predecessor in interest, if +the predecessor has it or can get it with reasonable efforts. + + You may not impose any further restrictions on the exercise of the +rights granted or affirmed under this License. For example, you may +not impose a license fee, royalty, or other charge for exercise of +rights granted under this License, and you may not initiate litigation +(including a cross-claim or counterclaim in a lawsuit) alleging that +any patent claim is infringed by making, using, selling, offering for +sale, or importing the Program or any portion of it. + + 11. Patents. + + A "contributor" is a copyright holder who authorizes use under this +License of the Program or a work on which the Program is based. The +work thus licensed is called the contributor's "contributor version". + + A contributor's "essential patent claims" are all patent claims +owned or controlled by the contributor, whether already acquired or +hereafter acquired, that would be infringed by some manner, permitted +by this License, of making, using, or selling its contributor version, +but do not include claims that would be infringed only as a +consequence of further modification of the contributor version. For +purposes of this definition, "control" includes the right to grant +patent sublicenses in a manner consistent with the requirements of +this License. + + Each contributor grants you a non-exclusive, worldwide, royalty-free +patent license under the contributor's essential patent claims, to +make, use, sell, offer for sale, import and otherwise run, modify and +propagate the contents of its contributor version. + + In the following three paragraphs, a "patent license" is any express +agreement or commitment, however denominated, not to enforce a patent +(such as an express permission to practice a patent or covenant not to +sue for patent infringement). To "grant" such a patent license to a +party means to make such an agreement or commitment not to enforce a +patent against the party. + + If you convey a covered work, knowingly relying on a patent license, +and the Corresponding Source of the work is not available for anyone +to copy, free of charge and under the terms of this License, through a +publicly available network server or other readily accessible means, +then you must either (1) cause the Corresponding Source to be so +available, or (2) arrange to deprive yourself of the benefit of the +patent license for this particular work, or (3) arrange, in a manner +consistent with the requirements of this License, to extend the patent +license to downstream recipients. "Knowingly relying" means you have +actual knowledge that, but for the patent license, your conveying the +covered work in a country, or your recipient's use of the covered work +in a country, would infringe one or more identifiable patents in that +country that you have reason to believe are valid. + + If, pursuant to or in connection with a single transaction or +arrangement, you convey, or propagate by procuring conveyance of, a +covered work, and grant a patent license to some of the parties +receiving the covered work authorizing them to use, propagate, modify +or convey a specific copy of the covered work, then the patent license +you grant is automatically extended to all recipients of the covered +work and works based on it. + + A patent license is "discriminatory" if it does not include within +the scope of its coverage, prohibits the exercise of, or is +conditioned on the non-exercise of one or more of the rights that are +specifically granted under this License. You may not convey a covered +work if you are a party to an arrangement with a third party that is +in the business of distributing software, under which you make payment +to the third party based on the extent of your activity of conveying +the work, and under which the third party grants, to any of the +parties who would receive the covered work from you, a discriminatory +patent license (a) in connection with copies of the covered work +conveyed by you (or copies made from those copies), or (b) primarily +for and in connection with specific products or compilations that +contain the covered work, unless you entered into that arrangement, +or that patent license was granted, prior to 28 March 2007. + + Nothing in this License shall be construed as excluding or limiting +any implied license or other defenses to infringement that may +otherwise be available to you under applicable patent law. + + 12. No Surrender of Others' Freedom. + + If conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot convey a +covered work so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you may +not convey it at all. For example, if you agree to terms that obligate you +to collect a royalty for further conveying from those to whom you convey +the Program, the only way you could satisfy both those terms and this +License would be to refrain entirely from conveying the Program. + + 13. Remote Network Interaction; Use with the GNU General Public License. + + Notwithstanding any other provision of this License, if you modify the +Program, your modified version must prominently offer all users +interacting with it remotely through a computer network (if your version +supports such interaction) an opportunity to receive the Corresponding +Source of your version by providing access to the Corresponding Source +from a network server at no charge, through some standard or customary +means of facilitating copying of software. This Corresponding Source +shall include the Corresponding Source for any work covered by version 3 +of the GNU General Public License that is incorporated pursuant to the +following paragraph. + + Notwithstanding any other provision of this License, you have +permission to link or combine any covered work with a work licensed +under version 3 of the GNU General Public License into a single +combined work, and to convey the resulting work. The terms of this +License will continue to apply to the part which is the covered work, +but the work with which it is combined will remain governed by version +3 of the GNU General Public License. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new versions of +the GNU Affero General Public License from time to time. Such new versions +will be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + + Each version is given a distinguishing version number. If the +Program specifies that a certain numbered version of the GNU Affero General +Public License "or any later version" applies to it, you have the +option of following the terms and conditions either of that numbered +version or of any later version published by the Free Software +Foundation. If the Program does not specify a version number of the +GNU Affero General Public License, you may choose any version ever published +by the Free Software Foundation. + + If the Program specifies that a proxy can decide which future +versions of the GNU Affero General Public License can be used, that proxy's +public statement of acceptance of a version permanently authorizes you +to choose that version for the Program. + + Later license versions may give you additional or different +permissions. However, no additional obligations are imposed on any +author or copyright holder as a result of your choosing to follow a +later version. + + 15. Disclaimer of Warranty. + + THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY +APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT +HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY +OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM +IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF +ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. Limitation of Liability. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS +THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY +GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE +USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF +DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD +PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), +EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF +SUCH DAMAGES. + + 17. Interpretation of Sections 15 and 16. + + If the disclaimer of warranty and limitation of liability provided +above cannot be given local legal effect according to their terms, +reviewing courts shall apply local law that most closely approximates +an absolute waiver of all civil liability in connection with the +Program, unless a warranty or assumption of liability accompanies a +copy of the Program in return for a fee. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +state the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU Affero General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Affero General Public License for more details. + + You should have received a copy of the GNU Affero General Public License + along with this program. If not, see . + +Also add information on how to contact you by electronic and paper mail. + + If your software can interact with users remotely through a computer +network, you should also make sure that it provides a way for users to +get its source. For example, if your program is a web application, its +interface could display a "Source" link that leads users to an archive +of the code. There are many ways you could offer source, and different +solutions will be better for different programs; see section 13 for the +specific requirements. + + You should also get your employer (if you work as a programmer) or school, +if any, to sign a "copyright disclaimer" for the program, if necessary. +For more information on this, and how to apply and follow the GNU AGPL, see +. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/shady-gen.cabal b/shady-gen.cabal new file mode 100644 --- /dev/null +++ b/shady-gen.cabal @@ -0,0 +1,58 @@ +Name: shady-gen +Version: 0.5.1 +Cabal-Version: >= 1.2 +Synopsis: Functional GPU programming - DSEL & compiler +Category: Language, GPU +Description: + Compile functional specifications for GPU execution. + See also shady-render, shady-tv, and shady-examples + . + Copyright 2009-2011 by Conal Elliott; GNU AGPLv3 license (see COPYING). + This license is a place-holder. Let me know if you'd like other terms. +Author: Conal Elliott +Maintainer: conal@conal.net +Homepage: http://haskell.org/haskellwiki/shady +Package-Url: http://conal.net/repos/shady-gen +Copyright: (c) by Conal Elliott 2009,2010 +License: OtherLicense +License-File: COPYING +Stability: experimental +build-type: Simple + +Library + hs-Source-Dirs: src + + Build-Depends: base >=4 && < 5, containers, mtl, wl-pprint + , applicative-numbers>=0.0.4, vector-space>=0.5.6 + , TypeCompose >= 0.7 + , MemoTrie, ty, data-treify, Boolean + + Exposed-Modules: + Text.PrettyPrint.Leijen.PrettyPrec + Text.PrettyPrint.Leijen.DocExpr + Data.NameM + Shady.Misc + Shady.Vec + Shady.Complex + Shady.Language.Type + Shady.Language.Glom + Shady.Language.Operator + Shady.Language.Exp + Shady.Language.Graph + Shady.Language.Reify + Shady.Language.Cse + Shady.Language.Share + Shady.Language.GLSL + + Shady.CompileE + Shady.CompileEs + + Data.StableMemo + Shady.Play.CseTest + Shady.Play.VectorTest + -- experimental: + Data.PolyStableMemo + -- Data.NatTrie + -- Data.TypeTrie + +-- For examples, see examples/shady-examples.cabal diff --git a/src/Data/NameM.hs b/src/Data/NameM.hs new file mode 100644 --- /dev/null +++ b/src/Data/NameM.hs @@ -0,0 +1,33 @@ +-- {-# LANGUAGE #-} +{-# OPTIONS_GHC -Wall #-} +---------------------------------------------------------------------- +-- | +-- Module : Data.NameM +-- Copyright : (c) Conal Elliott 2009 +-- License : AGPLv3 +-- +-- Maintainer : conal@conal.net +-- Stability : experimental +-- +-- Name supply monad. Non-abstract synonym for @State [String]@ +---------------------------------------------------------------------- + +module Data.NameM (NameM, genName, runNameM, allNames) where + +import Control.Monad.State + +type NameM = State [String] + +-- Generate a new variable name +genName :: State [x] x +genName = do x:xs' <- get + put xs' + return x + +runNameM :: NameM a -> a +runNameM m = evalState m allNames + +allNames :: [String] +allNames = map reverse (tail names) + where + names = "" : [ c:cs | cs <- names , c <- ['a' .. 'z'] ] diff --git a/src/Data/PolyStableMemo.hs b/src/Data/PolyStableMemo.hs new file mode 100644 --- /dev/null +++ b/src/Data/PolyStableMemo.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE TypeOperators, BangPatterns, Rank2Types, PatternGuards + , ExistentialQuantification, ScopedTypeVariables, GADTs + #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- temp +{-# OPTIONS_GHC -Wall #-} +---------------------------------------------------------------------- +-- | +-- Module : Data.PolyStableMemo +-- Copyright : (c) Conal Elliott 2009 +-- License : AGPLv3 +-- +-- Maintainer : conal@conal.net +-- Stability : experimental +-- +-- Polymorphic memoization based using stable names. +---------------------------------------------------------------------- + +module Data.PolyStableMemo ((:-->),memo) where -- ,memo2,memo3 + +import System.IO.Unsafe (unsafePerformIO) + +import Control.Concurrent.MVar +import System.Mem.StableName +import qualified Data.IntMap as I + +-- import Shady.Language.Graph +-- import Shady.Language.Operator +-- import Shady.Language.Exp +-- import Shady.Language.Graph + +import Shady.Language.Type + + +-- Stable names have EQ but not Ord, so they're not convenient for fast +-- maps. On the other hand, there's 'hashStableName', which generates an +-- 'Int', with rare collisions. So represent the memo table as an IntMap +-- whose entries are lists of StableName/value pairs. + + +-- @(k a, v a)@ pair +data StableBind k v = + forall a. HasType a => SB (StableName (k a)) (v a) + +-- Polymorphic function +type k :--> v = forall a. (HasType a, Show a) => k a -> v a + +-- Sorry about the 'Show' constraint. Turns out to be needed indirectly, +-- due to constant folding. + +-- Stable map +type SM k v = I.IntMap [StableBind k v] + +-- | Pointer-based memoization. Evaluates keys to WHNF to improve hit rate. +memo :: (k :--> v) -> (k :--> v) +-- memo :: (forall a. HasType a => k a -> v a) -> (forall a. HasType a => k a -> v a) +-- memo :: HasType a => (k a -> v a) -> (k a -> v a) +memo f = fetch f (unsafePerformIO (newMVar I.empty)) + +{- +-- polymorphic function +newtype Pfun p q a = Pfun { unPfun :: p a -> q a } + +-- | Memoized binary function +-- memo2 :: HasType a => +-- (k a -> l a -> v a) -> (k a -> l a -> v a) +memo2 :: (forall a. HasType a => k a -> l a -> v a) + -> (forall a. HasType a => k a -> l a -> v a) +memo2 h = unPfun . memo (Pfun . memo . h) + +-- h :: k a -> l a -> v a +-- memo . h :: k a -> l a -> v a +-- Pfun . memo . h :: k a -> Pfun l v a +-- memo (Pfun . memo . h) :: k a -> Pfun l v a +-- unPfun . memo (Pfun . memo . h) :: k a -> l a -> v a + +-- | Memoized binary function +memo3 :: HasType a => + (k a -> l a -> m a -> v a) -> (k a -> l a -> m a -> v a) +memo3 h = unPfun . memo (Pfun . memo2 . h) + +pfun2 :: (l a -> m a -> v a) -> Pfun l (Pfun m v) a +pfun2 = Pfun . fmap Pfun + +unPfun2 :: Pfun l (Pfun m v) a -> (l a -> m a -> v a) +unPfun2 = fmap unPfun . unPfun + +-- h :: k a -> l a -> m a -> v a +-- memo2 . h :: k a -> l a -> m a -> v a +-- pfun2 . memo2 . h :: k a -> Pfun l (Pfun m v) a +-- memo (pfun2 . memo2 . h) :: k a -> Pfun l (Pfun m v) a +-- unPfun2 . memo (pfun2 . memo2 . h) :: k a -> l a -> m a -> v a + +-- I worry that the function compositions will lose sharing. + + +-- -- | Memoized ternary function +-- memo3 :: HasType a => +-- (k a -> l a -> m a -> v a) -> (k a -> l a -> m a -> v a) +-- memo3 h = unPfun2 . memo (pfun2 . memo2 . h) + +-} + +-- TODO: Make lazy and strict versions. + +-- fetch :: (k :--> v) -> MVar (SM k v) -> (k :--> v) +fetch :: HasType a => (k a -> v a) -> MVar (SM k v) -> (k a -> v a) + +fetch f smv !k = unsafePerformIO $ + do st <- makeStableName k + modifyMVar smv $ \ sm -> return $ + let h = hashStableName st in + maybe (let v = f k in (I.insertWith (++) h [SB st v] sm, v)) -- new + ((,) sm) -- found + (I.lookup h sm >>= blookup st) -- look + +blookup :: forall k v a. HasType a => + StableName (k a) -> [StableBind k v] -> Maybe (v a) +blookup stk = look + where + look :: [StableBind k v] -> Maybe (v a) + look [] = Nothing + look (SB stk' v : binds') + | Just Refl <- tya `tyEq` typeOf2 stk', stk == stk' = Just v + | otherwise = look binds' + tya :: Type a + tya = typeT diff --git a/src/Data/StableMemo.hs b/src/Data/StableMemo.hs new file mode 100644 --- /dev/null +++ b/src/Data/StableMemo.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE TypeOperators, BangPatterns #-} +{-# OPTIONS_GHC -Wall #-} +---------------------------------------------------------------------- +-- | +-- Module : Data.StableMemo +-- Copyright : (c) Conal Elliott 2009 +-- License : AGPLv3 +-- +-- Maintainer : conal@conal.net +-- Stability : experimental +-- +-- Memoization based using stable names. WHNFs keys. +---------------------------------------------------------------------- + +module Data.StableMemo (memo,memo2,memo3) where + +import System.IO.Unsafe (unsafePerformIO) +-- import Debug.Trace (trace) + +import Control.Concurrent.MVar +import System.Mem.StableName +import qualified Data.IntMap as I + + +-- import Shady.Language.Graph +-- import Shady.Language.Operator +-- import Shady.Language.Exp +-- import Shady.Language.Graph + + +-- Stable names have EQ but not Ord, so they're not convenient for fast +-- maps. On the other hand, there's 'hashStableName', which generates an +-- 'Int', with rare collisions. So represent the memo table as an IntMap +-- whose entries are lists of StableName/value pairs. + + +-- @(k a, v a)@ pair +type StableBind k v = (StableName k, v) + +-- Stable map +type k :-> v = I.IntMap [StableBind k v] + + +-- | Pointer-based memoization. Evaluates keys to WHNF to improve hit rate. +memo :: (k -> v) -> (k -> v) +memo f = fetch f (unsafePerformIO (newMVar I.empty)) + +-- | Memoized binary function +memo2 :: (k -> l -> v) -> (k -> l -> v) +memo2 h = memo (memo . h) + +-- | Memoized ternary function +memo3 :: (k -> l -> m -> v) -> (k -> l -> m -> v) +memo3 h = memo (memo2 . h) + +-- TODO: Make lazy and strict versions. + +fetch :: (k -> v) -> MVar (k :-> v) -> (k -> v) + +fetch f smv !k = unsafePerformIO $ + do st <- makeStableName k + modifyMVar smv $ \ sm -> return $ + let h = hashStableName st in + maybe (let v = f k in (I.insertWith (++) h [(st,v)] sm, v)) -- new + ((,) sm) -- found + (I.lookup h sm >>= lookup st) -- look + +{- +---- tests + +sqr :: Num a => a -> a +sqr x = trace ("sqr " ++ show x) $ x*x + +t1,t2,t3,t4 :: Int + +t1 = sqr 6 + sqr 6 +t2 = s + s where s = sqr 6 + +-- Doesn't reuse 6 in ghci & ghc, but probably does with ghc -O +t3 = sqr' 6 + sqr' 6 + where + sqr' = memo sqr + +-- Works! +t4 = sqr' six + sqr' six + where + sqr' = memo sqr + six = 6 + +q :: Integer -> Integer +q = memo sqr + +-} diff --git a/src/Shady/CompileE.hs b/src/Shady/CompileE.hs new file mode 100644 --- /dev/null +++ b/src/Shady/CompileE.hs @@ -0,0 +1,183 @@ +{-# LANGUAGE TypeOperators, ScopedTypeVariables, ExistentialQuantification + #-} +{-# OPTIONS_GHC -Wall #-} +---------------------------------------------------------------------- +-- | +-- Module : Shady.CompileE +-- Copyright : (c) Conal Elliott 2009 +-- License : AGPLv3 +-- +-- Maintainer : conal@conal.net +-- Stability : experimental +-- +-- Generate and compile vertex and fragment shaders. +-- +-- In this version, shader programs are represented by functions function +-- a single expression to a single expression. See also CompileEs, which +-- allows functions between more flexible representations. +---------------------------------------------------------------------- + +module Shady.CompileE + ( -- VShaderF, FShaderF, SProgramF(..) + Pos, (:->)(..), ShaderVF + , GLSL(..), shaderProgram + -- , ShaderExe(..), sinker, compile + ) where + +-- import Control.Applicative (liftA3) + +import Text.PrettyPrint.Leijen +import qualified Text.PrettyPrint.Leijen as L +import Text.PrettyPrint.Leijen.PrettyPrec (PrettyPrec) +import Text.PrettyPrint.Leijen.DocExpr + +-- import Shady.Misc (Sink) +import Shady.Language.Glom +import Shady.Language.Exp +import Shady.Language.GLSL +-- import Shady.Color (Color) + +{- +import Shady.MechanicsGL (setupShader,glUseProgram,glMaxTextureUnits) +import Shady.Uniform +import Shady.Attribute +-} + +-- | For gl_Position +type Pos = R4 + + +{-------------------------------------------------------------------- + Generate and compile shader programs +--------------------------------------------------------------------} + +infixr 7 :->, :-^, :-* + +-- | Vertex shader +type a :-^ v = a :=>* (Pos,v) + +-- | Fragment shader +type v :-* o = v :=>* (R4,o) + +-- type v :--> o = v :=>* (R4,o) + +-- | For building vertex/fragment shader pairs. The idea is that a +-- complete parameterized shader program has type @u :=> a :- v :--> o@, +-- which expands to @u :=> (a :-^> v, v :-* o)@. +-- +-- u == uniform, a == (vertex) attribute, v == varying, o == fragment output. +-- +-- When @o == ()@ (color-only output), use the short-hand @u :=> a :-> v@. + +-- | General vertex/fragment shader pair. +data a :-> o = forall v. (HasType v, HasExpr v, PrettyPrec v) => + ShaderVF (a :-^ v) (v :-* o) + +-- | Vertex/fragment pair with no extra output besides color +type ShaderVF a = a :-> () + +-- | GLSL vertex program, fragment program, uniform and vertex attribute. +data GLSL u a = GLSL String String (Pat u) (Pat a) + +instance (HasExpr u, HasExpr a) => Pretty (GLSL u a) where + pretty (GLSL v f u a) = announce "vertex " v <$> announce "fragment" f + <$> pretty (u,a) + where + announce l sh = text (l ++ ": ") L.<+> align (pretty sh) + +instance (HasExpr u, HasExpr a) => Show (GLSL u a) where + show = show . pretty + +-- | Compile a parameterized shader program. TODO: generalize to non-() +-- outputs, i.e., to @u :=> a :-> o@. +shaderProgram :: (HasType a, HasExpr a, HasType u, HasExpr u) => + (u :=> ShaderVF a) -> GLSL u a +shaderProgram uav = + case uav (patE u) of + ShaderVF vert frag -> + let v = pat "_varying" + + vertOut = vert (patE a) + fragOut = frag (patE v) + + uD = D [ Uniform ] u + aD = D [Attribute] a + vD = D [ Varying ] v + + vsh = shader [uD,aD,vD] (glPosition :* v ) vertOut + fsh = shader [uD, vD] (glFragColor :* UnitG) fragOut + in + GLSL (show vsh) (show fsh) u a + where + -- Uniform/varying variables + u = pat "_uniform" + a = pat "_attribute" + +-- The awkward "case" keeps ghc's brain from exploding. + +-- TODO: What do we want to do when o /= ()? + +shader :: (HasExpr a, HasType a) => [Declaration] -> Pat a -> E a -> Shader +shader decls p e = Sh decls [mainDef (p =: e)] + +{- + +-- | Executable shader +data ShaderExe u a = + ShaderExe { xSelect :: IO () -- ^ install this exe + , xSinkU :: Sink u -- ^ set uniform + , xsinkA :: Sink [a] -- ^ set attribute + } + +sinker :: GLSL u a -> IO (ShaderExe u a) +sinker (GLSL vsh fsh u a) = + do p <- setupShader vsh fsh + units <- glMaxTextureUnits + return $ + ShaderExe (glUseProgram p) (setUniform units u p) (setAttribute a p) + +{- +-- | Compile a parameterized shader program. Set up a static (for now) +-- vertex mesh, and give a sink for setting uniforms and rendering. +compile :: (HasType a, HasExpr a, HasType u, HasExpr u) => + (u :=> ShaderVF a) -> IO () -> [a] -> IO (Sink u) +compile shf draw as = + sinker (shaderProgram shf) >>= renderSE draw as + +renderSE :: IO () -> [a] -> ShaderExe u a -> IO (Sink u) +renderSE draw as (ShaderExe useProg setU setA) = + do useProg + setA as + return $ \ u -> useProg >> setU u >> draw + +-- TODO: Maybe eliminate ShaderExe, collapsing sinker & renderSE into +-- compile + +-} + + +-- | Compile a parameterized shader program. Set up a static (for now) +-- vertex mesh, and give a sink for setting uniforms and rendering. +compile :: (HasType a, HasExpr a, HasType u, HasExpr u) => + (u :=> ShaderVF a) -> IO () -> [a] -> IO (Sink u) +compile shf draw as = + do -- print (pretty g) + p <- setupShader vsh fsh + units <- glMaxTextureUnits + let useProg = glUseProgram p + setA = setAttribute pa p + setU = setUniform units pu p + useProg + setA as + return $ \ u -> useProg >> setU u >> draw + where + GLSL vsh fsh pu pa = shaderProgram shf + + +-- TODO: switch from Sink [a] to Sink (Vbos a), so that the [a] -> Vbos +-- conversion can be done up front. Vbos = Glom Vbo. Then simplify the +-- signature to Vbos a -> u -> IO (). + +-- For now I'm wiring in a fixed mesh. + +-} diff --git a/src/Shady/CompileEs.hs b/src/Shady/CompileEs.hs new file mode 100644 --- /dev/null +++ b/src/Shady/CompileEs.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE TypeOperators, ScopedTypeVariables, TypeFamilies + , FlexibleContexts, ExistentialQuantification, GADTs + #-} +{-# OPTIONS_GHC -Wall #-} +---------------------------------------------------------------------- +-- | +-- Module : Shady.CompileEs +-- Copyright : (c) Conal Elliott 2009 +-- License : AGPLv3 +-- +-- Maintainer : conal@conal.net +-- Stability : experimental +-- +-- Generate and compile vertex and fragment shaders. Unlike +-- "Shady.CompileE", this version allows a looser structure to +-- the inputs & outputs of shaders, according to 'FromE'. You can use +-- the types and 'compile' in this module, or just 'shaders', along with +-- "Shady.CompileE", e.g., @compile (shaders sh)@. +---------------------------------------------------------------------- + +module Shady.CompileEs + ( shaders + , Pos, (:->)(..), ShaderVF + , GLSL + , shaderProgram + -- , ShaderExe(..), compile + ) where + +import Text.PrettyPrint.Leijen.PrettyPrec (PrettyPrec) +import Text.PrettyPrint.Leijen.DocExpr (HasExpr) + +import Shady.Language.Exp +import qualified Shady.CompileE as C +import Shady.CompileE (Pos, GLSL) +-- import Shady.CompileE (ShaderExe(..)) +-- import Shady.Misc (Sink) + +{-------------------------------------------------------------------- + Generate and compile shader programs +--------------------------------------------------------------------} + +infixr 7 :->, :-^, :-* + +-- | Vertex shader +type a' :-^ v' = a' -> (E Pos,v') + +-- | Fragment shader +type v' :-* o' = v' -> (E R4,o') + +-- | General vertex/fragment shader pair. +data a' :-> o' = + forall v' v. ( FromE v', v ~ ExpT v' + , HasType v, HasExpr v, PrettyPrec v ) => + ShaderVF (a' :-^ v') (v' :-* o') + +-- | Vertex/fragment pair with no extra output besides color +type ShaderVF a' = a' :-> () + +-- | Convert loosely structured shaders into single-exp shader +shaders :: forall u' a' o'. + (FromE u', FromE a', FromE o') => + (o ~ ExpT o',a ~ ExpT a',u ~ ExpT u') => + ( HasExpr o, HasType o, Show o) => + (u' -> (a' :-> o')) + -> u :=> (a C.:-> o) +shaders f u = case f (fromE u) of + ShaderVF vert frag -> + C.ShaderVF (toFromE vert) (toFromE frag) + +-- | Compile a parameterized shader program. TODO: generalize to non-() +-- outputs, i.e., to @u :=> a :-> o@. +shaderProgram :: forall u' a' u a. + ( FromE u', u ~ ExpT u', FromE a', a ~ ExpT a') => + ( HasType a, HasExpr a, HasType u, HasExpr u ) => + (u' -> ShaderVF a') -> GLSL u a +shaderProgram = C.shaderProgram . shaders + +{- +-- | Compile a parameterized shader program. Set up a static (for now) +-- vertex mesh, and give a sink for setting uniforms and rendering. +compile :: forall u' a' u a. + ( FromE u', u ~ ExpT u', FromE a', a ~ ExpT a') => + ( HasType a, HasExpr a, HasType u, HasExpr u ) => + (u' -> ShaderVF a') -> IO () -> [a] -> IO (Sink u) +compile = C.compile . shaders +-} diff --git a/src/Shady/Complex.hs b/src/Shady/Complex.hs new file mode 100644 --- /dev/null +++ b/src/Shady/Complex.hs @@ -0,0 +1,265 @@ +{-# LANGUAGE TypeOperators, CPP, DeriveDataTypeable, TypeFamilies #-} +{-# OPTIONS_GHC -Wall #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Complex +-- Copyright : (c) The University of Glasgow 2001, Conal Elliott 2009 +-- License : BSD-style +-- +-- Maintainer : conal@conal.net +-- Stability : provisional +-- Portability : portable +-- +-- Complex numbers. This version is modified from Data.Complex in base. +-- It eliminates the RealFloat requirement by using a more naive +-- definition of 'magnitude'. Also, defines instances for vector-space classes. +-- +----------------------------------------------------------------------------- + +module Shady.Complex + ( + -- * Rectangular form + Complex((:+)) + + , realPart -- :: Complex a -> a + , imagPart -- :: Complex a -> a + -- * Polar form + , mkPolar -- :: a -> a -> Complex a + , cis -- :: a -> Complex a + , polar -- :: Complex a -> (a,a) + -- , magnitude -- :: Complex a -> a + , phase -- :: Complex a -> a + -- * Conjugate + , conjugate -- :: Complex a -> Complex a + + -- Complex instances: (Eq,Read,Show,Num,Fractional,Floating) + -- Complex instances: (AdditiveGroup, VectorSpace, InnerSpace) + + -- * Misc interface additions + , onRI, onRI2 + ) where + +import Prelude + +import Data.Typeable +#ifdef __GLASGOW_HASKELL__ +import Data.Data (Data) +#endif + +#ifdef __HUGS__ +import Hugs.Prelude(Num(fromInt), Fractional(fromDouble)) +#endif + +import Data.VectorSpace + +import Shady.Misc (Unop,Binop,FMod(..),Frac(..)) +import Text.PrettyPrint.Leijen.DocExpr + + +infix 6 :+ + +-- ----------------------------------------------------------------------------- +-- The Complex type + +-- | Complex numbers are an algebraic type. +-- +-- For a complex number @z@, @'abs' z@ is a number with the magnitude of @z@, +-- but oriented in the positive real direction, whereas @'signum' z@ +-- has the phase of @z@, but unit magnitude. +data Complex a + = !a :+ !a -- ^ forms a complex number from its real and imaginary + -- rectangular components. +# if __GLASGOW_HASKELL__ + deriving (Eq, Show, Read, Data) +# else + deriving (Eq, Show, Read) +# endif + +-- ----------------------------------------------------------------------------- +-- Functions over Complex + +-- | Extracts the real part of a complex number. +realPart :: Complex a -> a +realPart (x :+ _) = x + +-- | Extracts the imaginary part of a complex number. +imagPart :: Complex a -> a +imagPart (_ :+ y) = y + +-- | The conjugate of a complex number. +{-# SPECIALISE conjugate :: Complex Double -> Complex Double #-} +conjugate :: Num a => Unop (Complex a) +conjugate (x:+y) = x :+ (-y) + +-- | Form a complex number from polar components of magnitude and phase. +{-# SPECIALISE mkPolar :: Double -> Double -> Complex Double #-} +mkPolar :: Floating a => a -> a -> Complex a +mkPolar r theta = r * cos theta :+ r * sin theta + +-- | @'cis' t@ is a complex value with magnitude @1@ +-- and phase @t@ (modulo @2*'pi'@). +{-# SPECIALISE cis :: Double -> Complex Double #-} +cis :: Floating a => a -> Complex a +cis theta = cos theta :+ sin theta + + +-- | The function 'polar' takes a complex number and +-- returns a (magnitude, phase) pair in canonical form: +-- the magnitude is nonnegative, and the phase in the range @(-'pi', 'pi']@; +-- if the magnitude is zero, then so is the phase. +{-# SPECIALISE polar :: Complex Double -> (Double,Double) #-} +polar :: Floating a => Complex a -> (a,a) +polar z = (magnitude z, phase z) + + +-- | Operate on the real & imaginary components +onRI :: Unop a -> Unop (Complex a) +onRI f (x :+ y) = f x :+ f y + +-- | Operate on the real & imaginary components +onRI2 :: Binop a -> Binop (Complex a) +onRI2 f (x :+ y) (x' :+ y') = f x x' :+ f y y' + +instance Floating a => AdditiveGroup (Complex a) where + { zeroV = 0 ; negateV = negate ; (^+^) = (+) } + +instance Floating a => VectorSpace (Complex a) where + type Scalar (Complex a) = a + -- s *^ (x :+ y) = s * x :+ s * y + (*^) s = onRI (s *) + +instance Floating a => InnerSpace (Complex a) where + (x :+ y) <.> (x' :+ y') = x*x' + y*y' + + +{- + +-- | The nonnegative magnitude of a complex number. +{-# SPECIALISE magnitude :: Complex Double -> Double #-} +magnitude :: Floating a => Complex a -> a +magnitude = sqrt . magSq + +magnitudeSq :: Floating a => Complex a -> a + +-- magnitude (x:+y) = scaleFloat k +-- (sqrt (sqr (scaleFloat mk x) + sqr (scaleFloat mk y))) +-- where k = max (exponent x) (exponent y) +-- mk = - k +-- sqr z = z * z + +-} + +-- | The phase of a complex number, in the range @(-'pi', 'pi']@. +-- If the magnitude is zero, then so is the phase. +{-# SPECIALISE phase :: Complex Double -> Double #-} +phase :: Floating a => Complex a -> a +-- The zero case requires a real EQ instance +-- phase (0 :+ 0) = 0 -- SLPJ July 97 from John Peterson +phase (x:+y) = atan2' y x + +-- To avoid reliance on 'RealFloat'. +atan2' :: (Floating a) => a -> a -> a +atan2' y x = atan (y/x) + +-- ----------------------------------------------------------------------------- +-- Instances of Complex + +#include "Typeable.h" +INSTANCE_TYPEABLE1(Complex,complexTc,"Complex") + +instance Floating a => Num (Complex a) where + {-# SPECIALISE instance Num (Complex Float) #-} + {-# SPECIALISE instance Num (Complex Double) #-} + (x:+y) + (x':+y') = (x+x') :+ (y+y') + (x:+y) - (x':+y') = (x-x') :+ (y-y') + (x:+y) * (x':+y') = (x*x'-y*y') :+ (x*y'+y*x') + negate (x:+y) = negate x :+ negate y + abs z = magnitude z :+ 0 + signum (0:+0) = 0 + signum z@(x:+y) = x/r :+ y/r where r = magnitude z + fromInteger n = fromInteger n :+ 0 +#ifdef __HUGS__ + fromInt n = fromInt n :+ 0 +#endif + +instance Floating a => Fractional (Complex a) where + {-# SPECIALISE instance Fractional (Complex Float) #-} + {-# SPECIALISE instance Fractional (Complex Double) #-} + + (x:+y) / v@(x':+y') = ((x*x'+y*y') :+ (y*x'-x*y')) ^/ magnitudeSq v + +-- (x:+y) / (x':+y') = (x*x''+y*y'') / d :+ (y*x''-x*y'') / d +-- where x'' = scaleFloat k x' +-- y'' = scaleFloat k y' +-- k = - max (exponent x') (exponent y') +-- d = x'*x'' + y'*y'' + + fromRational a = fromRational a :+ 0 +#ifdef __HUGS__ + fromDouble a = fromDouble a :+ 0 +#endif + +instance Floating a => Floating (Complex a) where + {-# SPECIALISE instance Floating (Complex Float) #-} + {-# SPECIALISE instance Floating (Complex Double) #-} + pi = pi :+ 0 + exp (x:+y) = expx * cos y :+ expx * sin y + where expx = exp x + log z = log (magnitude z) :+ phase z + +-- x ** y = exp (log x * y) +-- sqrt = (** 0.5) + + -- Use default sqrt (** 0.5) + +-- sqrt (0:+0) = 0 +-- sqrt z@(x:+y) = u :+ (if y < 0 then -v else v) +-- where (u,v) = if x < 0 then (v',u') else (u',v') +-- v' = abs y / (u'*2) +-- u' = sqrt ((magnitude z + abs x) / 2) + + sin (x:+y) = sin x * cosh y :+ cos x * sinh y + cos (x:+y) = cos x * cosh y :+ (- sin x * sinh y) + tan (x:+y) = (sinx*coshy:+cosx*sinhy)/(cosx*coshy:+(-sinx*sinhy)) + where sinx = sin x + cosx = cos x + sinhy = sinh y + coshy = cosh y + + sinh (x:+y) = cos y * sinh x :+ sin y * cosh x + cosh (x:+y) = cos y * cosh x :+ sin y * sinh x + tanh (x:+y) = (cosy*sinhx:+siny*coshx)/(cosy*coshx:+siny*sinhx) + where siny = sin y + cosy = cos y + sinhx = sinh x + coshx = cosh x + + asin z@(x:+y) = y':+(-x') + where (x':+y') = log (((-y):+x) + sqrt (1 - z*z)) + acos z = y'':+(-x'') + where (x'':+y'') = log (z + ((-y'):+x')) + (x':+y') = sqrt (1 - z*z) + atan z@(x:+y) = y':+(-x') + where (x':+y') = log (((1-y):+x) / sqrt (1+z*z)) + + asinh z = log (z + sqrt (1+z*z)) + acosh z = log (z + (z+1) * sqrt ((z-1)/(z+1))) + atanh z = log ((1+z) / sqrt (1-z*z)) + + +{-------------------------------------------------------------------- + Pretty printing +--------------------------------------------------------------------} + +-- infix 6 :+ + +instance HasExpr a => HasExpr (Complex a) where + expr (x :+ y) = op Infix 6 ":+" (expr x) (expr y) + + +{-------------------------------------------------------------------- + Misc +--------------------------------------------------------------------} + +instance Frac s => Frac (Complex s) where frac = onRI frac +instance FMod s => FMod (Complex s) where fmod = onRI2 fmod diff --git a/src/Shady/Language/Cse.hs b/src/Shady/Language/Cse.hs new file mode 100644 --- /dev/null +++ b/src/Shady/Language/Cse.hs @@ -0,0 +1,190 @@ +{-# LANGUAGE GADTs, KindSignatures, TypeFamilies, MultiParamTypeClasses + , ScopedTypeVariables, PatternGuards + #-} +{-# OPTIONS_GHC -Wall -fno-warn-unused-imports -fno-warn-orphans -fno-warn-missing-signatures #-} +---------------------------------------------------------------------- +-- | +-- Module : Shady.Language.Cse +-- Copyright : (c) Conal Elliott 2009 +-- License : AGPLv3 +-- +-- Maintainer : conal@conal.net +-- Stability : experimental +-- +-- Common subexpression elimination. +-- +-- TODO: Improve variable names (now \"x8\" etc). +---------------------------------------------------------------------- + +module Shady.Language.Cse (cse) where + +import Control.Applicative (pure,(<$>),(<*>)) +import Data.Maybe (fromMaybe) +import qualified Data.IntMap as I + +import System.IO.Unsafe (unsafePerformIO) + +import Shady.Misc +import Shady.Language.Type +import Shady.Language.Operator +import Shady.Language.Exp + +import Shady.Language.Graph +import Shady.Language.Reify + +-- V from Tid +ev :: Tid a -> V a +ev (Tid i t) = V ('x':show i) t + +children :: N a -> [NodeId] +children (VN _) = [] +children (ON _) = [] +children (App (Tid a _) (Tid b _)) = [a,b] + +childrenB :: Bind -> [NodeId] +childrenB (Bind _ n) = children n + +-- Number of references for each node. Important: partially apply, so +-- that the binding list can be converted just once into an efficiently +-- searchable representation. +uses :: [Bind] -> (NodeId -> Int) +uses = fmap (fromMaybe 0) . + flip I.lookup . + histogram . + concatMap childrenB + +-- histogram :: Ord k => [k] -> I.Map k Int +-- histogram = foldr (\ k -> I.insertWith (+) k 1) I.empty + +histogram :: [Int] -> I.IntMap Int +histogram = foldr (\ k -> I.insertWith (+) k 1) I.empty + +-- Fast version, using an IntMap. Important: partially apply. +bindsF :: forall a. [Bind] -> (Tid a -> N a) +bindsF binds = \ (Tid i' a') -> extract a' (I.lookup i' m) + where + m :: I.IntMap Bind + m = I.fromList [(i,b) | b@(Bind i _) <- binds] + extract :: Type a' -> Maybe Bind -> N a' + extract _ Nothing = error "bindsF: variable not found" + extract a' (Just (Bind _ n)) + | Just Refl <- typeOf1 n `tyEq` a' = n + | otherwise = + error $ "bindsF: wrong type. " ++ show (typeOf1 n) ++ " vs " ++ show a' + +tid :: HasType a => NodeId -> Tid a +tid i = Tid i typeT + +letI :: (HasType a, HasType b) => NodeId -> E a -> E b -> E b +letI i = letE (ev (tid i)) + +unGraph :: HasType a => Graph a -> E a +unGraph (Graph binds root) = foldr llet (var' root) (reverse binds) + where + -- Wrap a let if non-trivial + llet :: HasType b => Bind -> E b -> E b + llet bind | trivial bind = id + llet (Bind i n) = letI i (nodeE' n) + -- How many uses of variable + count :: NodeId -> Int + count = uses binds + -- Bindings as IntMap lookup + psf :: Tid a -> N a + psf = bindsF binds + -- Too trivial to bother abstracting. + trivial :: Bind -> Bool + trivial (Bind _ (VN _)) = True + trivial (Bind _ (ON (Lit a))) = not (abstractable a) + trivial (Bind _ (ON _)) = True + trivial (Bind i _) | count i < 2 = True + trivial _ = False + -- Like nodeE but with inlining of trivial bindings + nodeE' :: N a -> E a + nodeE' (VN v) = Var v + nodeE' (ON o) = Op o + nodeE' (App a b) = var' a :^ var' b + -- Variable reference or inline + var' :: HasType a => Tid a -> E a + var' t@(Tid i _) | trivial (Bind i n) = nodeE' n + | otherwise = Var (ev t) + where + n = psf t + +-- Possible and worthwhile to abstract. +abstractable :: forall a. HasType a => a -> Bool +abstractable a = + case (typeOf a :: Type a) of + VecT (VectorT n _) -> natToZ n > 1 + _ -> False + +-- | Common subexpression elimination. Use with care, since it breaks +-- referential transparency on the /representation/ of expressions, but +-- not on their meaning. +cse :: HasType a => E a -> E a +cse = unsafePerformIO . fmap unGraph . reifyGraph + +{- + +-- Remove the comment braces to use the testing code + +{-------------------------------------------------------------------- + Testing +--------------------------------------------------------------------} + +-- Simpler version of unGraph. No inlining. +unGraph' :: HasType a => Graph a -> E a +unGraph' (Graph binds root) = foldr f (Var (ev root)) (reverse binds) + where + f :: Bind -> (forall b. HasType b => E b -> E b) + f (Bind i n) = letE (ev (Tid i (typeOf1 n))) (nodeE n) + nodeE (VN v) = Var v + nodeE (ON o) = Op o + nodeE (App u v) = Var (ev u) :^ Var (ev v) + +-- Convert expressions to simple SSA forms +ssa :: HasType a => E a -> IO (E a) +ssa = fmap unGraph' . reifyGraph + + +-- type-specialize +reify :: HasType a => E a -> IO (Graph a) +reify = reifyGraph + +type I1 = One Int + +va, vb :: E I1 +va = Var (var "a") +vb = Var (var "b") + + +-- test expressions +e1 = va + vb :: E I1 +e2 = e1 * e1 +e3 = va + va :: E I1 + +-- For instance, + + +-- > e2 +-- (a + b) * (a + b) +-- +-- > reify e2 +-- let [0 = App x1 x3,1 = App x2 x3,3 = App x4 x7,7 = VN b,4 = App x5 x6,6 = VN a,5 = ON (+),2 = ON (*)] in x0 +-- +-- > ssa e2 +-- let x2 = (*) in +-- let x5 = (+) in +-- let x6 = a in +-- let x4 = x5 x6 in +-- let x7 = b in +-- let x3 = x4 x7 in +-- let x1 = x2 x3 in +-- let x0 = x1 x3 in +-- x0 +-- +-- > cse e2 +-- let x3 = a + b in +-- x3 * x3 + + +-} diff --git a/src/Shady/Language/Exp.hs b/src/Shady/Language/Exp.hs new file mode 100644 --- /dev/null +++ b/src/Shady/Language/Exp.hs @@ -0,0 +1,1127 @@ +{-# LANGUAGE GADTs, RankNTypes, KindSignatures, TypeOperators + , StandaloneDeriving, GeneralizedNewtypeDeriving + , PatternGuards, ScopedTypeVariables + , FlexibleContexts, FlexibleInstances + , TypeFamilies, TypeSynonymInstances + , MultiParamTypeClasses, UndecidableInstances + , EmptyDataDecls, CPP + #-} +{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} +---------------------------------------------------------------------- +-- | +-- Module : Shady.Language.Exp +-- Copyright : (c) Conal Elliott 2009 +-- License : AGPLv3 +-- +-- Maintainer : conal@conal.net +-- Stability : experimental +-- +-- Expressions. +---------------------------------------------------------------------- + +module Shady.Language.Exp + ( + -- * Variables + Id, V(..), var, genVar + -- * Patterns + , Pat, patT, pat + -- * Type paths + , TPath, emptyP, fstP, sndP, namePath + -- * Expressions + , E(..), (:=>), (:=>*) + -- , Es, exps, (:>-), (:>-*) + -- * n-ary operator application + , op1, op2, op3, op4 + -- * Optimizing expression-builders + , pureE, fmapE, liftE2, liftE3, liftE4 + -- * Operations + , notE +-- , true, false +-- , (&&*), (||*) +-- , (<*), (<=*), (>=*), (>*) +-- , (==*), (/=*) + , (==^), (/=^) + , truncateE, roundE, ceilingE, floorE -- , fmod, fmodE, fracE + , allV, anyV + , SamplerE, texture + , lit + , BoolE, FloatE, R1E, R2E, R3E, R4E, VecE + , vec2, vec3, vec4 + , un2, un3, un4 + , getX, getY, getZ, getW, get, (<+>) + , unitE, pairE, fstE, sndE, unPairE, uniform, uniformV + , ComplexE + -- * Conversion to expressions + , ToE(..), toE, FromE(..), toFromE, patE -- , ToEs, EsT, exps + , module Shady.Language.Type + -- , module Shady.Cat + -- * Temporary + , letE + ) + where + +import Data.Monoid (Monoid(..),First(..)) +import Data.Maybe (fromMaybe) +import Control.Applicative (Applicative(pure),(<$>)) +import Control.Monad (liftM2) +import Control.Arrow ((&&&),second) + +import Text.PrettyPrint.Leijen hiding ((<$>),(<+>)) +import Text.PrettyPrint.Leijen.PrettyPrec +import Text.PrettyPrint.Leijen.DocExpr hiding (var,apply) +import qualified Text.PrettyPrint.Leijen.DocExpr as X + +import Control.Compose (result,(~>)) + +import Data.Boolean + +import Data.VectorSpace + +import Data.NameM +import Shady.Language.Type hiding ((<+>),vec2,vec3,vec4,un2,un3,un4,get) +import Shady.Language.Glom +import qualified Shady.Vec as V +import Shady.Language.Operator +import Shady.Misc +import Shady.Complex + + +{-------------------------------------------------------------------- + Strays +--------------------------------------------------------------------} + +deriving instance Functor First +deriving instance Applicative First +deriving instance Monad First + +fromFirst :: a -> First a -> a +fromFirst a = fromMaybe a . getFirst + + +{-------------------------------------------------------------------- + Variables +--------------------------------------------------------------------} + +-- | Variable name +type Id = String + +-- | Typed variables +data V a = V { varName :: Id, varType :: Type a } deriving Show + +instance SynEq V where V a _ =-= V b _ = a == b + +-- TODO: consider replacing the VectorT a with a constraint: IsVector a => + +-- instance Show (V a) where show = varName + +instance HasExprU V where + exprU = X.var . show + -- exprU (V i ty) = op InfixL 0 "::" (X.var ('x':show i)) (exprU ty) + +instance HasExpr a => HasExpr (V a) where expr = exprU + +-- Or: +-- +-- instance HasExpr a => HasExpr (V a) where +-- expr (V name ty) = op InfixL 0 "::" (X.var name) (expr ty) +-- +-- instance HasExprU V where exprU = expr + +instance HasExpr a => PrettyPrec (V a) where prettyPrec = prettyExpr +instance HasExpr a => Pretty (V a) where pretty = prettyPrec 0 + +-- instance HasExpr a => Show (V a) where showsPrec = showsPrettyPrec + +-- -- | Equality on variables, ignoring type. +-- vEq :: V a -> V b -> Bool +-- V n _ `vEq` V n' _ = n == n' + +-- | Make a variable, inferring the type from context. +var :: HasType a => Id -> V a +var = flip V typeT + +-- TODO: maybe split var into uvar and avar + +genVar :: HasType a => NameM (V a) +genVar = var <$> genName + + +{-------------------------------------------------------------------- + Type paths +--------------------------------------------------------------------} + +-- | Type path +newtype TPath = TPath String + +-- | Empty type path +emptyP :: TPath +emptyP = TPath "" + +-- | Extend a type path +fstP, sndP :: TPath -> TPath +fstP (TPath p) = TPath ('F' : p) +sndP (TPath p) = TPath ('S' : p) + +-- | Augment a variable name with a type path +namePath :: String -> TPath -> String +namePath vname (TPath "") = vname +namePath vname (TPath p) = vname ++ "_" ++ reverse p + +-- TODO: use a safer separator than "_" (avoiding real variable names). +-- With "__", I get "OpenGL reserves names containing '__'" + + +{-------------------------------------------------------------------- + Patterns +--------------------------------------------------------------------} + +-- | Variable patterns +type Pat = Glom V + +-- | The type of a pattern +patT :: Pat a -> Type a +patT (BaseG (V _ t)) = t +patT UnitG = UnitT +patT (a :* b) = patT a :*: patT b + + +-- | Make a variable pattern, inferring the type from context. +pat :: HasType a => String -> Pat a +pat vname = divvy emptyP typeT + where + divvy :: TPath -> Type s -> Pat s + divvy _ UnitT = UnitG + divvy path (a :*: b) = divvy (fstP path) a :* divvy (sndP path) b + divvy _ (_ :->: _) = error "pat: function type not handled" + divvy path t = BaseG (V (namePath vname path) t) + +-- Note divvy is not quite a fmapU, because of the path accumulation. +-- Look out for similar definitions. + + +{-------------------------------------------------------------------- + Simple expressions +--------------------------------------------------------------------} + +infixl 9 :^ + +-- | Simple expressions (no 'Let'). Statically typed. +-- Constructors for operator/constant ('Op'), variable ('Var'), +-- application ('(:^)'), and abstraction ('Lam'). +data E :: * -> * where + Op :: Op a -> E a -- -- ^ operator/constant + Var :: V a -> E a -- -- ^ variable + (:^) :: HasType a => + E (a -> b) -> E a -> E b -- -- ^ application + Lam :: HasType a => + V a -> E b -> E (a -> b) -- -- ^ abstraction + +-- TODO: when haddock is fixed, reinstate per-ctor haddock comments and +-- remove the constructor comments in the data doc. + +instance SynEq E where + Op o =-= Op o' = o =-= o' + Var v =-= Var v' = v =-= v' + f :^ x =-= g :^ y = f === g && x === y + _ =-= _ = False + +-- TODO: what about lambdas? False negatives are okay for our use, which +-- is optimization. + +-- | Short-hand for beta-redex +letE :: (HasType a, HasType b) => + V a -> E a -> E b -> E b +letE v a b = Lam v b :^ a + + +instance HasExpr (E a) where + expr (Op oper) = X.var (show oper) + expr (Var (V n _)) = X.var n + expr e@(_ :^ _) = appExpr e [] + expr (Lam (V n _) f) = lambdaX n (expr f) + + +-- Application expr, passing in argument exprs. +appExpr :: forall a. E a -> [Expr] -> Expr +appExpr (Op o) xs = opExpr o xs +appExpr (Op Not :^ (Op (Lt n) :^ a :^ b)) xs = appExpr (Op (Le n) :^ b :^ a) xs +appExpr (Op Mul :^ a :^ (Op Recip :^ b)) xs = appExpr (Op Divide :^ a :^ b) xs +appExpr (Op Add :^ a :^ (Op Negate :^ b)) xs = appExpr (Op Sub :^ a :^ b) xs +appExpr e@(Op (Cat _ _ _) :^ _ :^ _) xs + | First (Just e') <- catFix e = appExpr e' xs +appExpr (Op (Swizzle ixs) :^ v) xs + | Just e' <- swizzleOpt ixs v = appExpr e' xs +appExpr (Lam v b :^ a) xs = foldl ($$) (letExpr v a b) xs +appExpr (f :^ e) xs = appExpr f (expr e : xs) +appExpr f xs = foldl ($$) (expr f) xs + + +-- Flatten stacked cats. +catFix :: a :=>? a +catFix (Op (Cat (Succ Zero) (Succ Zero) _) :^ a :^ b) = + pure (Op VVec2 :^ a :^ b) +catFix (Op (Cat (Succ Zero) _ _) :^ a :^ b) = catFix b >>= consV a +catFix _ = mempty + +consV :: One a :=> Vec n a :=>? (Vec (S n) a) +consV a (Op VVec2 :^ b :^ c) = pure (Op VVec3 :^ a :^ b :^ c) +consV a (Op VVec3 :^ b :^ c :^ d) = pure (Op VVec4 :^ a :^ b :^ c :^ d) +consV _ _ = mempty + +-- e.g., foo.xyz --> foo if foo is 3D +swizzleOpt :: forall n m a. (IsNat m, IsNat n) => + Vec n (Index m) -> E (Vec m a) -> Maybe (E (Vec n a)) +swizzleOpt ixs v | Just Refl <- m `natEq` n, ixs == indices n = Just v + | otherwise = Nothing + where + m = nat :: Nat m + n = nat :: Nat n + + + +-- Let expression +letExpr :: HasType a => V a -> E a -> E b -> Expr +letExpr (V n _) a b = letX n (expr a) (expr b) + +-- exprFun :: (HasExpr c, HasType a) => +-- (E a -> c) -> Id -> Expr +-- exprFun f = expr . f . Var . var . idName + +instance PrettyPrec (E a) where prettyPrec = prettyExpr +instance Pretty (E a) where pretty = prettyPrec 0 +instance Show (E a) where show = show . pretty + + +infixr 7 :=>, :=>* + +-- | Function from expressions. Nestable. +type a :=> b = E a -> b + +-- | Expression to expression. Ends a chain of '(:=>)' +type a :=>* b = a :=> E b + + +infixr 7 :=>? +-- | Expression to possible expression. Ends a chain of '(:=>)'. +type a :=>? b = a :=> First (E b) + + +{-------------------------------------------------------------------- + Convenient n-ary operator application +--------------------------------------------------------------------} + +-- | Convenient operator application +op1 :: (HasType a, HasType b) => + Op (a -> b) -> a :=>* b +op1 o a = Op o :^ a + +-- | Convenient operator application +op2 :: (HasType a, HasType b, HasType c) => + Op (a -> b -> c) -> a :=> b :=>* c +op2 o a b = op1 o a :^ b + +-- | Convenient operator application +op3 :: (HasType a, HasType b, HasType c, HasType d) => + Op (a -> b -> c -> d) -> a :=> b :=> c :=>* d +op3 o a b c = op2 o a b :^ c + +-- | Convenient operator application +op4 :: (HasType a, HasType b, HasType c, HasType d, HasType e) => + Op (a -> b -> c -> d -> e) -> a :=> b :=> c :=> d :=>* e +op4 o a b c d = op3 o a b c :^ d + + +{-------------------------------------------------------------------- + Simplification / optimization +--------------------------------------------------------------------} + +infix 0 @> +-- | Simplification result with fall-back value. +(@>) :: First a -> a -> a +(@>) = flip fromFirst + + + +-- | Left identity: @i `op` a == a@ +identityL :: Eq a => a -> a :=> b :=>? b +identityL i (Op (Lit u)) b | u == i = pure b +identityL _ _ _ = mempty + +-- | Right identity: @a `op` i == a@ +identityR :: Eq b => b -> a :=> b :=>? a +identityR i a (Op (Lit v)) | v == i = pure a +identityR _ _ _ = mempty + +-- | Symmetric identity, combining 'identityL' and 'identityR'. +identity :: Eq a => a -> a :=> a :=>? a +identity = identityL `mappend` identityR + +-- Will GHC optimize 'identity' to the following? + +-- identity i (Op (Lit u)) b | u == i = pure b +-- identity i a (Op (Lit v)) | v == i = pure a +-- identity _ _ _ = mempty + +-- | Annihilator: @z * a == z@ +annihilator :: Eq a => a -> a :=> a :=>? a +annihilator z (Op (Lit u)) _ | u == z = pure (pureE z) +annihilator z _ (Op (Lit v)) | v == z = pure (pureE z) +annihilator _ _ _ = mempty + + +-- | Inverse-related properties +inverse :: Op (a -> a -> a) -> a :=> a :=>? a +inverse Add a (Op Negate :^ b) | a =-= b = pure 0 +inverse Add (Op Negate :^ b) a | a =-= b = pure 0 +inverse Mul a (Op Recip :^ b) | a =-= b = pure 1 +inverse Mul (Op Recip :^ b) a | a =-= b = pure 1 +inverse Mul a (Op (Lit (-1))) = pure (negate a) +inverse Mul (Op (Lit (-1))) a = pure (negate a) +inverse _ _ _ = mempty + + +-- | Commute, to get literals together: @3 + a == a + 3@, +-- @(a + 3) + b == (a + b) + 3@. +-- +-- Might be a bad idea, as it can break sharing. Think through. +-- Not really effective without associate, which breaks even more sharing. +commute :: a :=> a :=>? a +-- commute a@(Op (Lit _)) b = pure (b + a) +-- commute (Op Add :^ a :^ b@(Op (Lit _))) c = pure ((a + c) + b) +commute _ _ = mempty + + +#define SIMPLIFY + +-- | Operator-specific simplifation (unary) +simple1 :: Op (a -> b) -> a :=>? b +#ifdef SIMPLIFY +simple1 Negate (Op Negate :^ a) = pure a +simple1 Negate (Op Mul :^ a :^ b) = pure (negate a * b) -- see note +simple1 Negate (Op Add :^ a :^ b) = pure (negate a + negate b) -- see note +simple1 Recip (Op Recip :^ a) = pure a +simple1 Fst (Op Pair :^ a :^ _) = pure a +simple1 Snd (Op Pair :^ _ :^ b) = pure b +simple1 Cos (Op Negate :^ a) = pure (cos a) +simple1 Sin (Op Negate :^ a) = pure (- sin a) + +-- Note: pushing the negate inward increases opportunities for vectorization, +-- but can break sharing. For Add, it also increases cost a bit. + +-- TODO: more +#endif +simple1 _ _ = mempty + +-- | Operator-specific simplifation (binary) +simple2 :: Op (a -> b -> c) -> a :=> b :=>? c +#ifdef SIMPLIFY +simple2 Add = identity 0 `mappend` addMul `mappend` + inverse Add `mappend` commute +simple2 Mul = annihilator 0 `mappend` identity 1 `mappend` + inverse Mul `mappend` commute `mappend` mulNegNeg +simple2 (Cat _ _ _) = (<+?>) +#endif +simple2 _ = mempty + +-- TODO: Change identity and annihilator to take Add and Mul as +-- arguments. Then refactor for more reuse between Add & Mul and perhaps +-- all binary ops well. + +-- simple2 Pair = pairFstSnd + +-- | Operator-specific simplifation (ternary) +simple3 :: Op (a -> b -> c -> d) -> a :=> b :=> c :=>? d +#ifdef SIMPLIFY +simple3 If (Op (Lit c)) a b = pure $ if un1 c then a else b +simple3 If _ a b | a =-= b = pure a +-- TODO: more +#endif +simple3 _ _ _ _ = mempty + + +-- | Operator-specific simplifation (quaternary) +simple4 :: Op (a -> b -> c -> d -> e) -> a :=> b :=> c :=> d :=>? e + +#ifdef SIMPLIFY +-- TODO: more +#endif +simple4 _ = mempty +{- +-} + + +-- Vectorization + +infix 1 <+?> +(<+?>) :: forall n m a. + (IsNat n, IsNat m, IsScalar a, + IsNat (m :+: n), Show a) => + Vec m a :=> Vec n a :=>? Vec (m :+: n) a + +-- Comment out the first rule as a temp work-around for glsl 1.2 + +-- a <+> a = a.(all<+>all) +a <+?> b | n' > 1 -- for glsl 1.2, which doesn't allow swizzling scalars. + , Just Refl <- a =:= b = pure (Op (Swizzle (is V.<+> is)) :^ a) + where + -- With -XNoMonomorphismRestriction, we get an Ambiguous type variable. + -- If I then add ":: n", ghc doesn't terminate. + n :: Nat n + n = nat + n' = natToZ n + is = indices n + +-- a <+> a.js = a.(all<+>js) +a <+?> Op (Swizzle js) :^ b | Just Refl <- a =:= b = + pure (Op (Swizzle (indices nat V.<+> js)) :^ a) +-- a.is <+> a = a.(is<+>all) +Op (Swizzle is) :^ a <+?> b | Just Refl <- a =:= b = + pure (Op (Swizzle (is V.<+> indices nat)) :^ a) +-- a.is <+> a.js = a.(is<+>js) +Op (Swizzle is) :^ a <+?> Op (Swizzle js) :^ b + | Just Refl <- a =:= b + = pure (Op (Swizzle (is V.<+> js)) :^ a) + +Op Min :^ a :^ a' <+?> Op Min :^ b :^ b' = pure ((a <+> b) `min` (a' <+> b')) +Op Max :^ a :^ a' <+?> Op Max :^ b :^ b' = pure ((a <+> b) `max` (a' <+> b')) +Op Add :^ a :^ a' <+?> Op Add :^ b :^ b' = pure ((a <+> b) + (a' <+> b')) +Op Sub :^ a :^ a' <+?> Op Sub :^ b :^ b' = pure ((a <+> b) - (a' <+> b')) +Op Mul :^ a :^ a' <+?> Op Mul :^ b :^ b' = pure ((a <+> b) * (a' <+> b')) +Op Quot :^ a :^ a' <+?> Op Quot :^ b :^ b' = pure ((a <+> b) `quot` (a' <+> b')) +Op Rem :^ a :^ a' <+?> Op Rem :^ b :^ b' = pure ((a <+> b) `rem` (a' <+> b')) +Op Div :^ a :^ a' <+?> Op Div :^ b :^ b' = pure ((a <+> b) `div` (a' <+> b')) +Op Mod :^ a :^ a' <+?> Op Mod :^ b :^ b' = pure ((a <+> b) `mod` (a' <+> b')) +Op FMod :^ a :^ a' <+?> Op FMod :^ b :^ b' = pure ((a <+> b) `fmod` (a' <+> b')) + +Op Divide :^ a :^ a' <+?> Op Divide :^ b :^ b' = pure ((a <+> b) / (a' <+> b')) + +Op Negate :^ a <+?> Op Negate :^ b = pure (negate (a <+> b)) +Op Recip :^ a <+?> Op Recip :^ b = pure (recip (a <+> b)) +Op Abs :^ a <+?> Op Abs :^ b = pure (abs (a <+> b)) +Op Signum :^ a <+?> Op Signum :^ b = pure (signum (a <+> b)) +Op Sqrt :^ a <+?> Op Sqrt :^ b = pure (sqrt (a <+> b)) +Op Exp :^ a <+?> Op Exp :^ b = pure (exp (a <+> b)) +Op Log :^ a <+?> Op Log :^ b = pure (log (a <+> b)) +Op Sin :^ a <+?> Op Sin :^ b = pure (sin (a <+> b)) +Op Cos :^ a <+?> Op Cos :^ b = pure (cos (a <+> b)) +Op Asin :^ a <+?> Op Asin :^ b = pure (asin (a <+> b)) +Op Acos :^ a <+?> Op Acos :^ b = pure (acos (a <+> b)) +Op Sinh :^ a <+?> Op Sinh :^ b = pure (sinh (a <+> b)) +Op Asinh :^ a <+?> Op Asinh :^ b = pure (asinh (a <+> b)) +Op Atanh :^ a <+?> Op Atanh :^ b = pure (atanh (a <+> b)) +Op Acosh :^ a <+?> Op Acosh :^ b = pure (acosh (a <+> b)) +Op Truncate :^ a <+?> Op Truncate :^ b = pure (truncateE (a <+> b)) +Op Round :^ a <+?> Op Round :^ b = pure (roundE (a <+> b)) +Op Ceiling :^ a <+?> Op Ceiling :^ b = pure (ceilingE (a <+> b)) +Op Floor :^ a <+?> Op Floor :^ b = pure (floorE (a <+> b)) +Op Not :^ a <+?> Op Not :^ b = pure (notE (a <+> b)) + +-- I'm using @^ on the RHSs in order to get CSE. If I used the smart +-- constructors (min etc), I'd get more operator-specific optimization. +-- For now, I assume there won't be any. If I'm wrong, revisit. + +-- The next three are trickier, because the result scalar type (Bool) does +-- not determine the argument types, which could thus differ. Hence the +-- compatibility check. + +Op (EqualV _) :^ a :^ a' <+?> Op (EqualV _) :^ b :^ b' + | Just Refl <- a `compatible1` b + = pure ((a <+> b) ==* (a' <+> b')) + +Op (Lt _) :^ a :^ a' <+?> Op (Lt _) :^ b :^ b' + | Just Refl <- a `compatible1` b + = pure ((a <+> b) <* (a' <+> b')) + +Op (Le _) :^ a :^ a' <+?> Op (Le _) :^ b :^ b' + | Just Refl <- a `compatible1` b + = pure ((a <+> b) <=* (a' <+> b')) + +_ <+?> _ = mempty + +-- TODO: Eliminate the nat arguments to EqualV etc if they're now unused + +-- | Undistribute: @a*b + a*b' == a*(b+b')@. Also, dot products +-- @a*b + a'*b' == (a,a') <.> (b,b')@ +addMul :: forall n a. + (IsNat n, IsScalar a, Num a) => + Vec n a :=> Vec n a :=>? Vec n a +-- (Op Mul :^ a :^ b) `addMul` (Op Mul :^ a' :^ b') +-- | a =-= a' = pure (a * (b + b')) +-- | b =-= b' = pure ((a + a') * b) + +(Op Mul :^ a :^ b) `addMul` (Op Mul :^ a' :^ b') + | Just Refl <- (typeT :: Type (Vec n a)) `tyEq` (typeT :: Type R1) + = pure $ (a <+> a') <.> (b <+> b') + +(Op Dot :^ a :^ b) `addMul` (Op Mul :^ a' :^ b') + | Just Refl <- (typeT :: Type (Vec n a)) `tyEq` (typeT :: Type R1) + , Just CanExtend <- canExtendE a + = pure $ (a <+> a') <.> (b <+> b') + +_ `addMul` _ = mempty + +-- Proof that an n-vector can be extened by one element +data CanExtend :: * -> * where + CanExtend :: IsNat (n :+: OneT) => CanExtend n + +canExtend :: forall n. IsNat n => Maybe (CanExtend n) +canExtend = + case (nat :: Nat n) of + Zero -> j + Succ Zero -> j + Succ (Succ Zero) -> j + Succ (Succ (Succ Zero)) -> j + _ -> Nothing + where + j :: IsNat (m :+: OneT) => Maybe (CanExtend m) + j = Just CanExtend + +-- Pull in the type parameter +canExtendE :: IsNat n => f (Vec n a) -> Maybe (CanExtend n) +canExtendE = const canExtend + + +-- -a * -b == a * b +mulNegNeg :: (IsNat n, IsScalar a, Num a) => + Vec n a :=> Vec n a :=>? Vec n a +mulNegNeg (Op Negate :^ a) (Op Negate :^ b) = pure (a * b) +mulNegNeg _ _ = mempty + + + +-- I don't know how to get the following simplification to type-check: + +-- -- Surjectivity of pairs: (fst c, snd c) == c +-- pairFstSnd :: -- forall a b. (HasType a, HasType b) => +-- a :=> b :=>? (a,b) +-- pairFstSnd (Op Fst :^ c) (Op Snd :^ c') +-- | Just Refl <- tyEq (typeT :: c) (typeT :: c'), +-- c =-= c' = pure c +-- surjectivePair _ _ = mempty + +{- +-- -a * b == - (a * b) ; a * -b == - (a * b) +mulNegUp, negMul :: (IsNat n, IsScalar a, Num a) => + (Vec n a) :=> (Vec n a) :=>? (Vec n a) +mulNegUp (Op Negate :^ a) b = negMul a b +mulNegUp a (Op Negate :^ b) = negMul a b +mulNegUp _ _ = mempty + +negMul a b = pure (Op Negate :^ (Op Mul :^ a :^ b)) +-} + + +{-------------------------------------------------------------------- + 'E' Lifters +--------------------------------------------------------------------} + +-- Basic lifters. I've named them suggestively of 'Functor' and +-- 'Applicative' methods. They fit generalized versions of these classes +-- with the arrows being operators. + +-- | Literal expression +pureE :: Show a => a -> E a +pureE = Op . Lit + +-- | Apply a unary operator, with constant-folding and simplifications +fmapE :: (HasType a, HasType b {-, Show b-}) => + Op (a -> b) -> a :=>* b +#ifdef SIMPLIFY +fmapE o (Op (Lit x)) = Op (Lit (opVal o x)) +#endif +fmapE o a = simple1 o a @> op1 o a + +-- | Apply a binary operator, with constant-folding and simplifications +liftE2 :: (HasType a, HasType b, HasType c {-, Show c-}) => + Op (a -> b -> c) -> a :=> b :=>* c +#ifdef SIMPLIFY +liftE2 o (Op (Lit x)) (Op (Lit y)) = Op (Lit (opVal o x y)) +#endif +liftE2 o a b = simple2 o a b @> op2 o a b + +-- | Apply a ternary operator, with constant-folding and simplifications +liftE3 :: (HasType a, HasType b, HasType c, HasType d {-, Show d-}) => + Op (a -> b -> c -> d) -> a :=> b :=> c :=>* d +#ifdef SIMPLIFY +liftE3 o (Op (Lit x)) (Op (Lit y)) (Op (Lit z)) = Op (Lit (opVal o x y z)) +#endif +liftE3 o a b c = simple3 o a b c @> op3 o a b c + +-- | Apply an quaternary operator, with constant-folding and simplifications +liftE4 :: (HasType a, HasType b, HasType c, HasType d, HasType e {-, Show e-}) => + Op (a -> b -> c -> d -> e) -> a :=> b :=> c :=> d :=>* e +#ifdef SIMPLIFY +liftE4 o (Op (Lit w)) (Op (Lit x)) (Op (Lit y)) (Op (Lit z)) = + Op (Lit (opVal o w x y z)) +#endif +liftE4 o a b c d = simple4 o a b c d @> op4 o a b c d + + +{-------------------------------------------------------------------- + E Instances +--------------------------------------------------------------------} + +-- The types of some methods prevent them from being lifted to expressions +noOv :: String -> a +noOv meth = error $ meth ++ ": No overloading for E" + +instance Eq (E a) where + (==) = noOv "(==)" + (/=) = noOv "(/=)" + +instance (IsNat n, IsScalar a, Ord a, Show a) => Ord (E (Vec n a)) where + min = liftE2 Min + max = liftE2 Max + (<) = noOv "(<)" + +instance IsNat n => Boolean (VecE n Bool) where + false = pureU False + true = pureU True + notB = fmapE Not + (&&*) = liftE2 And + (||*) = liftE2 Or + +pureU :: (IsNat n, IsScalar a) => a -> VecE n a +pureU x = uniformV' (pureE (vec1 x)) + +-- Here's the weird deal: if pureU uses uniformV instead of uniformV', +-- then we trigger a bug in ghc 6.10.3: +-- +-- ghc: panic! (the 'impossible' happened) +-- (GHC version 6.10.3 for i386-unknown-linux): +-- initC: srt_lbl +-- +-- The definitions of uniformV and uniformV' are identical. If I +-- change the definition of uniform to use uniformV' instead of +-- uniformV, then uniformV' becomes the fatal choice in pureU. + +uniformV' :: (IsNat n, IsScalar a, Show a) => + One a :=>* Vec n a +uniformV' = fmapE (UniformV vectorT) + +-- Does GLSL have conjunction and disjunction on boolean vectors? If so, +-- then I can generalize this instance (using uniformV for false & true). +-- Even if GLSL doesn't have it, I could generate code. Then I can keep +-- EqB and OrdB deriving from Boolean. + +-- | Transitional synonym for notB +notE :: IsNat n => Vec n Bool :=>* Vec n Bool +notE = notB + +-- TODO: Eliminate notE + +instance (IsNat n, IsScalar a, Show a) => IfB BoolE (VecE n a) where + ifB = liftE3 If + +-- -- | Synonym for 'ifB' (transitional) +-- ifE :: IfB b a => b -> a -> a -> a +-- ifE = ifB + +-- -- | Expression-lifted conditional with condition last +-- ifE' :: IfB b a => a -> a -> b -> a +-- ifE' = boolean + + +instance (IsNat n, IsScalar a, Eq a, Show a) => EqB (VecE n Bool) (VecE n a) where + (==*) = liftE2 (EqualV nat) + +instance (IsNat n, IsScalar a, Ord a, Show a) => + OrdB (VecE n Bool) (VecE n a) where + (<*) = liftE2 (Lt nat) + +infix 4 ==^, /=^ + +-- | Vector equality, resulting in a single Bool. See also '(==*)'. +(==^) :: (IsNat n, IsScalar a, Eq a, Show a) => + Vec n a :=> Vec n a :=>* B1 +(==^) = liftE2 Equal + +-- | Vector inequality, resulting in a single Bool. See also '(/=*)'. +(/=^) :: (IsNat n, IsScalar a, Eq a, Show a) => + Vec n a :=> Vec n a :=>* B1 +(/=^) = (result.result) notE (==^) + + +instance Enum a => Enum (E a) where + succ = noOv "succ" + pred = noOv "pred" + toEnum = noOv "toEnum" + fromEnum = noOv "fromEnum" + enumFrom = noOv "enumFrom" + enumFromThen = noOv "enumFromThen" + enumFromTo = noOv "enumFromTo" + enumFromThenTo = noOv "enumFromThenTo" + +instance (IsNat n, IsScalar a, Num a) => + Num (E (Vec n a)) where + fromInteger = pureE . fromInteger + negate = fmapE Negate + (+) = liftE2 Add + (*) = liftE2 Mul + abs = fmapE Abs + signum = fmapE Signum + +instance (IsNat n, IsScalar a, Ord a, Num a) => + Real (E (Vec n a)) where + toRational = noOv "toRational" + +instance (IsNat n, IsScalar b, Integral b) => + Integral (E (Vec n b)) where + quot = liftE2 Quot + rem = liftE2 Rem + div = liftE2 Div + mod = liftE2 Mod + quotRem = both quot rem + divMod = both div mod + toInteger = noOv "toInteger" + +both :: (a -> b -> c) -> (a -> b -> c') -> (a -> b -> (c,c')) +both f g a b = (f a b, g a b) + +instance (IsNat n, IsScalar b, Fractional b) => Fractional (E (Vec n b)) where + recip = fmapE Recip + fromRational = pureE . fromRational + +instance (IsNat n, IsScalar b, Floating b) => Floating (E (Vec n b)) where + pi = pureE pi + sqrt = fmapE Sqrt + exp = fmapE Exp + log = fmapE Log + sin = fmapE Sin + cos = fmapE Cos + asin = fmapE Asin + atan = fmapE Atan + acos = fmapE Acos + + -- GLSL 1.2 doesn't support hyperbolic trig. Substitute these + -- definitions. TODO: two paths, depending on GLSL version. + + sinh x = (exp x - exp (-x)) / 2 + cosh x = (exp x + exp (-x)) / 2 + asinh x = log (x + sqrt (x*x + 1)) + acosh x = log (x + sqrt (x*x - 1)) + atanh x = (log (1 + x) - log (1 - x)) / 2 + +-- sinh = fmapE Sinh +-- cosh = fmapE Cosh +-- asinh = fmapE Asinh +-- atanh = fmapE Atanh +-- acosh = fmapE Acosh + +instance (IsNat n, IsScalar b, RealFrac b) => RealFrac (E (Vec n b)) where + properFraction = noOv "properFraction" + truncate = noOv "truncate" + round = noOv "round" + ceiling = noOv "ceiling" + floor = noOv "floor" + +-- truncateE, roundE, ceilingE, floorE :: (RealFrac a, Integral b) => a :=>* b + +-- Funky types, to match GLSL: +truncateE, roundE, ceilingE, floorE :: IsNat n => Vec n R :=>* Vec n R + +truncateE = fmapE Truncate +roundE = fmapE Round +ceilingE = fmapE Ceiling +floorE = fmapE Floor + +instance (IsNat n, IsScalar a, FMod a) => FMod (E (Vec n a)) where + fmod = liftE2 FMod + +instance (IsNat n, IsScalar a, FMod a, RealFrac a) => Frac (E (Vec n a)) where + frac = fracViaFmod + + +{-------------------------------------------------------------------- + Boolean vector operations +--------------------------------------------------------------------} + +-- -- | Component-wise 'not' +-- notV :: (IsNat n) => (Vec n Bool) :=>* (Vec n Bool) +-- -- Vec n Bool :=>* Vec n Bool +-- notV = fmapE NotV + +-- | Are all of the 'Bool's true? +allV :: IsNat n => Vec n Bool :=>* B1 +allV = fmapE AllV + +-- | Is all of the 'Bool's true? +anyV :: IsNat n => Vec n Bool :=>* B1 +anyV = fmapE AnyV + + + +{-------------------------------------------------------------------- + Misc operations +--------------------------------------------------------------------} + +type SamplerE n = E (Sampler n) + +-- | Texturing +texture :: IsNat n => Sampler n :=> Vec n R :=>* R4 +texture = liftE2 (Texture nat) + +-- | Literal value +lit :: Show a => a -> E a +lit = Op . Lit + + +-- | 'Bool' +type BoolE = E B1 + +-- | 'Float' expression +type FloatE = E R1 + +type R1E = E R1 +type R2E = E R2 +type R3E = E R3 +type R4E = E R4 + +-- | Expression vector +type VecE n a = E (Vec n a) + + +-- vec1 :: (IsScalar a, Show a) => a :=>* (Vec1 a) +-- vec1 = fmapE VVec1 + +vec2 :: (IsScalar a, Show a) => One a :=> One a :=>* Two a +vec3 :: (IsScalar a, Show a) => One a :=> One a :=> One a :=>* Three a +vec4 :: (IsScalar a, Show a) => One a :=> One a :=> One a :=> One a :=>* Four a + +vec2 a b = a <+> b +vec3 a b c = a <+> vec2 b c +vec4 a b c d = a <+> vec3 b c d + +-- vec2 = liftE2 VVec2 +-- vec3 = liftE3 VVec3 +-- vec4 = liftE4 VVec4 + +un2 :: IsScalar a => Two a :=> (E (One a), E (One a)) +un2 u = (getX u, getY u) + +un3 :: IsScalar a => Three a :=> (E (One a), E (One a), E (One a)) +un3 u = (getX u, getY u, getZ u) + +un4 :: IsScalar a => Four a :=> (E (One a), E (One a), E (One a), E (One a)) +un4 u = (getX u, getY u, getZ u, getW u) + + +-- | Extract X component +getX :: (IsNat n, IsScalar a, Show a) => + Vec (S n) a :=>* One a +getX = get index0 +-- | Extract Y component +getY :: (IsNat n, IsScalar a, Show a) => + Vec (S (S n)) a :=>* One a +getY = get index1 +-- | Extract Z component +getZ :: (IsNat n, IsScalar a, Show a) => + Vec (S (S (S n))) a :=>* One a +getZ = get index2 +-- | Extract W component +getW :: (IsNat n, IsScalar a, Show a) => + Vec (S (S (S (S n)))) a :=>* One a +getW = get index3 + +-- | Extract vector component +get :: (IsNat n, IsScalar a, Show a) => + Index n -> (Vec n a) :=>* One a +get i = fmapE (Swizzle (vec1 i)) + + +infixl 1 <+> +-- | Concatenation of vectors +(<+>) :: (IsNat m, IsNat n, IsNat (m :+: n), IsScalar a, Show a) => + Vec m a :=> Vec n a :=>* Vec (m :+: n) a +(<+>) = liftE2 (Cat nat nat vectorT) + + + +-- | Expression-lifted '()' +unitE :: E () +unitE = pureE () + + +-- | Expression-lifted '(,)' +pairE :: (HasType a, HasType b{-, HasExpr a, HasExpr b-}) => + -- (Show a, Show b) => + E a -> E b -> E (a,b) +pairE = liftE2 Pair + +-- | Expression-lifted 'fst' +fstE :: (HasType a, HasType b {-, Show b -} {-, HasExpr a, HasExpr b-}) => + Show a => E (a,b) -> E a +fstE = fmapE Fst + +-- | Expression-lifted 'snd' +sndE :: (HasType a, HasType b {-, Show a-} {-, HasExpr a, HasExpr b-}) => + Show b => E (a,b) -> E b +sndE = fmapE Snd + +-- | Unpack a pair +unPairE :: (HasType a, HasType b{-, HasExpr a, HasExpr b-}) => + -- (Show a, Show b) => + E (a,b) -> (E a, E b) +unPairE = fstE &&& sndE + +instance UnitF E where unit = unitE +instance PairF E where (#) = pairE + +-- | Uniform version of a function on vectors +uniform :: (IsNat n, IsScalar a, Show a) => + (E (Vec n a) -> b) -> (E (One a) -> b) +uniform = (. uniformV) + +-- | Uniform vector +uniformV :: (IsNat n, IsScalar a, Show a) => + One a :=>* Vec n a +uniformV = fmapE (UniformV vectorT) + + +{-------------------------------------------------------------------- + AdditiveGroup and VectorSpace +--------------------------------------------------------------------} + +instance (IsNat n, IsScalar a, Num a) => + AdditiveGroup (E (Vec n a)) where + zeroV = pureE 0 + (^+^) = liftE2 Add + negateV = fmapE Negate + +-- Hm. Odd tension between Num & AdditiveGroup. I'm avoiding adding +-- operators for AdditiveGroup and VectorSpace, so I won't have to add +-- rules for them. Maybe just add the rules. + +instance (IsNat n, IsScalar a, Num a) => + VectorSpace (E (Vec n a)) where + type Scalar (E (Vec n a)) = E (One a) + s *^ u = uniformV s * u + -- (*^) = liftE2 Scale + +instance IsNat n => InnerSpace (E (Vec n R)) where + -- (<.>) = liftE2 (Dot nat) + (<.>) = case (nat :: Nat n) of + Succ Zero -> liftE2 Mul + _ -> liftE2 Dot + +-- Alternatively, I could eliminate the Scale operator and do a +-- scalar-to-vector expansion here, and maybe optimize away during code +-- generation. Revisit. + + + + +{-------------------------------------------------------------------- + Conversion to expressions +--------------------------------------------------------------------} + +-- | Turn a pattern into an expression. +patE :: Pat a -> E a +patE (BaseG v) = Var v +patE UnitG = unitE +patE (p :* q) = patE p # patE q + + + +-- | Value convertible to an expression +class ToE w where + type ExpT w + toEN :: w -> NameM (E (ExpT w)) + +-- | Convert to an expression, using fresh name supply +toE :: ToE w => w -> E (ExpT w) +toE = runNameM . toEN + +-- | Value convertible from an expression +class ToE w => FromE w where + fromE :: E (ExpT w) -> w + +instance ToE (E a) where + type ExpT (E a) = a + toEN = return +instance FromE (E a) where + fromE = id + +instance ToE () where + type ExpT () = () + toEN () = return unit + +instance FromE () where fromE = const () + +infixr 1 ## + +(##) :: (PairF f, HasType a, HasType b {-, Show a, Show b -}) => + NameM (f a) -> NameM (f b) -> NameM (f (a,b)) +(##) = liftM2 (#) + +instance ( ToE u, Show (ExpT u), HasType (ExpT u) + , ToE v, Show (ExpT v), HasType (ExpT v) + ) => ToE (u,v) where + type ExpT (u,v) = (ExpT u, ExpT v) + toEN (u,v) = liftM2 (#) (toEN u) (toEN v) + -- toEN u ## toEN v + +instance ( FromE u {-, Show (ExpT u)-}, HasType (ExpT u) + , FromE v {-, Show (ExpT v)-}, HasType (ExpT v) + ) => FromE (u,v) where + fromE e = (fromE eu, fromE ev) where (eu,ev) = unPairE e + +instance ( ToE u {-, Show (ExpT u)-}, HasType (ExpT u) + , ToE v {-, Show (ExpT v)-}, HasType (ExpT v) + , ToE w {-, Show (ExpT w)-}, HasType (ExpT w) + ) => ToE (u,v,w) where + type ExpT (u,v,w) = ExpT u :# ExpT v :# ExpT w + toEN (u,v,w) = toEN u ## toEN v ## toEN w + +instance ( FromE u {-, Show (ExpT u)-}, HasType (ExpT u) + , FromE v {-, Show (ExpT v)-}, HasType (ExpT v) + , FromE w {-, Show (ExpT w)-}, HasType (ExpT w) + ) => FromE (u,v,w) where + fromE e = (fromE eu, fromE ev, fromE ew) + where (eu,(ev,ew)) = (second unPairE . unPairE) e + +instance (FromE u, ToE v, HasType (ExpT u)) => ToE (u -> v) where + type ExpT (u -> v) = ExpT u -> ExpT v + toEN f = do u <- genVar -- p <- genPat + b <- toEN (f (fromE (Var u))) -- patE p, or toE p + return $ Lam u b + +-- Hm. Here I wish Lam allowed a Pat. I'd then use genPat. Revisit Lam. + +{- +-- | Generate a pattern of the given type with new variable names +genPat :: HasType a => NameM (Pat a) +genPat = get' typeT + where + get' :: forall b. HasType b => Type b -> NameM (Pat b) + get' UnitT = return unit + get' (a :*: b) = liftM2 (#) (get' a) (get' b) + get' t = fmap (BaseG . flip V t) genName + +-- TODO: Give genPat a [Name] argument. Use runNameMWith. + +-} + +-- Patterns +instance ToE (Pat a) where + type ExpT (Pat a) = a + toEN = return . patE + + +-- | Construct an 'E' transformer from an 'ExpT' transformer +toFromE :: (FromE v, FromE w) => (v -> w) -> (E (ExpT v) -> E (ExpT w)) +toFromE = fromE ~> toE + +-- TODO: Check uses of toFromE and consider whether the fresh name supply +-- could be problematic. + + +-- | Complex-valued expressions +type ComplexE a = Complex (E (One a)) + +instance (Show a, IsScalar a) => ToE (ComplexE a) where + type ExpT (ComplexE a) = Two a + toEN (x :+ y) = return $ x <+> y +instance (Show a, IsScalar a) => FromE (ComplexE a) where + fromE c = getX c :+ getY c + diff --git a/src/Shady/Language/GLSL.hs b/src/Shady/Language/GLSL.hs new file mode 100644 --- /dev/null +++ b/src/Shady/Language/GLSL.hs @@ -0,0 +1,302 @@ +{-# LANGUAGE ExistentialQuantification, GADTs #-} +{-# OPTIONS_GHC -Wall #-} +---------------------------------------------------------------------- +-- | +-- Module : Shady.Language.GLSL +-- Copyright : (c) Conal Elliott 2009 +-- License : GPLv3 +-- +-- Maintainer : conal@conal.net +-- Stability : experimental +-- +-- Abstract syntax for GLSL. Evolving. +---------------------------------------------------------------------- + +-- Experimenting with typed syntax. + +module Shady.Language.GLSL + ( + -- * Syntax types + Program(..), Shader(..), Declaration(..), Definition(..) + , VectorT(..), ScalarT(..), Param(..), Id, Bind(..) + , Statement(..), Qualifier(..) + -- * Handy for building bindings + , BindO, (=::), closeB + -- * Utilities + , (=:) + , glPosition, glFragColor, vTrans, nTrans, mainDef + ) + where + +import Data.Monoid (Monoid(..)) +-- import Data.Maybe (maybe) +import Data.Char (toLower) + +import Data.VectorSpace (normalized) + +import Text.PrettyPrint.Leijen +import Text.PrettyPrint.Leijen.PrettyPrec (showsPretty) +import Text.PrettyPrint.Leijen.DocExpr (expr) + +import Control.Compose (result) + +import Shady.Language.Operator (Op(Pair,Lit)) +import Shady.Language.Exp hiding ((<+>),get) +import Shady.Language.Glom +import Shady.Misc (padTo) + +-- Common sub-expression elimination. Work in progress. The Cse module is +-- fast but misses some sharing. Share is slow and thorough. +-- +-- TODO: combine the two approaches, using the Cse implementation as a +-- first pass and the Share implementation as a second. + +import Shady.Language.Cse (cse) +-- import Shady.Language.Share (cse) + +{-------------------------------------------------------------------- + Syntax types +--------------------------------------------------------------------} + +-- data Exists f = forall a. Exists (f a) + +-- | Variable binding +data Bind = forall a. B (Pat a) (E a) + +-- | Statement +data Statement + = Assign Bind + | LetS Bind Statement + | SkipS + | ThenS Statement Statement + +-- | Storage qualifier +data Qualifier = Uniform | Attribute | Varying deriving (Show, Eq) + +-- | Variable declaration/initialization. +data Declaration = forall a. D [Qualifier] (Pat a) + +-- | formal parameter +data Param = forall n a. M (VectorT n a) Id + +-- | Top-level definition +data Definition = forall n a. F (Maybe (VectorT n a)) Id [Param] Statement + +-- | Shader +data Shader = Sh [Declaration] [Definition] + +-- | Program: Vertex shader and Fragment shader +data Program = P { pVertex :: Shader, pFragment :: Shader } + + +instance Monoid Statement where { mempty = SkipS ; mappend = ThenS } + + +{-------------------------------------------------------------------- + Utilities +--------------------------------------------------------------------} + +-- | The standard gl_Position variable, which must be set in a vertex shader +glPosition :: Pat R4 +glPosition = pat "gl_Position" + +-- | The standard gl_FragColor variable, which must be set in a fragment shader +glFragColor :: Pat R4 +glFragColor = pat "gl_FragColor" + +-- Transform +trans :: IsNat n => String -> VecE n R -> VecE n R +trans vname p = Var (var vname) * p + +-- Transform and normalize +transNz :: IsNat n => String -> VecE n R -> VecE n R +transNz = (result.result) normalized trans + +-- transNz vname p = normalized (trans vname p) + +-- | Transform a vertex using the standard model/view matrix +vTrans :: E R4 -> E R4 +vTrans = trans "gl_ModelViewProjectionMatrix" + +-- | Transform a normal using the standard normal matrix +nTrans :: E R3 -> E R3 +nTrans = transNz "gl_NormalMatrix" + +-- HACK: the type of the view matrix above is inferred to be vec4 instead of +-- mat4x4. This lie saves me from having to introduce matrices to +-- the representation. If I use them elswhere, get honest. + +-- | @main@ in a shader program. +mainDef :: Statement -> Definition +mainDef = F Nothing "main" [] + + +{-------------------------------------------------------------------- + Generate code for an assigment. May introduce new names and generate + local bindings. +--------------------------------------------------------------------} + +-- Because GLSL doesn't have expression-level "let", float all lets to the +-- top level before generating code. There may be a more efficient way to +-- use locals. + +infix 0 =: +-- | Assignment statement +(=:) :: HasType a => Pat a -> E a -> Statement +p =: e = p <-- cse e + +(<--) :: Pat a -> E a -> Statement + +-- p =: let v::t=a in b[v]; +-- --> +-- { var t v=a ; p =: b[v] } +p <-- (Lam v b :^ a) = letS v a (p <-- b) + +p <-- e = Assign (B p e) + + +letS :: V a -> E a -> Statement -> Statement +letS v e = LetS (B (BaseG v) e) + + +{-------------------------------------------------------------------- + Pretty-printing / code generation +--------------------------------------------------------------------} + +-- TODO: Consider changing Assign to use Pat and E instead of Bind, since +-- they have different concrete syntax. Hm. What's the concrete syntax +-- for a variable, "vec v" or "v"? Maybe accept context-dependent +-- concrete syntax. + +-- TODO: CSE-friendly splitting for p :* q, e.g., a Let. + +instance Pretty Bind where + pretty = prettyB True + +-- Pretty-print a binding, showing types if @withTypes@ is true +prettyB :: Bool -> Bind -> Doc +prettyB withTypes = pret + where + pret :: Bind -> Doc + pret (B UnitG _) = empty + pret (B (p :* q) e) = pret (B p a) <$> pret (B q b) + where (a,b) = unPair' e + pret (B (BaseG (V name ty)) e) = + mbty ty <> text name <+> equals <+> pretty e <> semi + mbty :: Type t -> Doc + mbty ty | withTypes = prettyTy ty <> space + | otherwise = empty + +-- Variant that pads types for variable alignment +prettyTy :: Type t -> Doc +prettyTy = text . padTo (length "float") . show + + +unPair' :: (Show a, Show b) => E (a,b) -> (E a, E b) +unPair' (Op (Lit (a,b))) = (Op (Lit a), Op (Lit b)) +unPair' (Op Pair :^ a :^ b) = (a,b) +unPair' p = error $ "unPair': " ++ show (expr p) + +-- TODO: Sort out & eliminate this error situation. + + +instance Pretty Statement where + pretty (Assign bind) = prettyB False bind + pretty (LetS bind stat) = pretty bind <$> pretty stat + pretty SkipS = empty + pretty (s `ThenS` t) = pretty s <$> pretty t + +instance Pretty Qualifier where pretty = lshowPad qMax + +qMax :: Int +qMax = length "attribute" + +instance Pretty Declaration where + pretty (D quals patt) = prettyD patt + where + prettyD :: Pat t -> Doc + prettyD UnitG = empty + prettyD (p :* q) = prettyD p <$> prettyD q + prettyD (BaseG (V name ty)) = vcat' quals <+> pretty ty <+> text name <> semi + +instance Pretty Param where + pretty (M ty name) = pretty ty <+> pretty name + +instance Pretty Definition where + pretty (F mbty name params body) = + maybe (text "void") pretty mbty <+> text name <+> + tupled' params <+> scoped (pretty body) + +instance Pretty Shader where + pretty (Sh decls funs) = vcat' decls <$> vcat' funs + +instance Pretty Program where + pretty (P v f) = line <> announce "vertex " v <$> announce "fragment" f + where + announce l sh = text (l ++ ": ") <+> align (pretty sh) + +-- The initial 'line' is just so that a 'show'n (not 'pretty'd) tuple with +-- 'Program' starts at column 0. + + +{-------------------------------------------------------------------- + +--------------------------------------------------------------------} + +-- | Binding with open (exposed) type. Build with '(=::)' and '(#)'. +data BindO a = BindO (Pat a) (E a) + +-- | 'V' specialization of '(=:)'. +(=::) :: HasType a => V a -> E a -> BindO a +v =:: e = BindO (BaseG v) e + +instance PairF BindO where + BindO p u # BindO q v = BindO (p # q) (u # v) + +-- | Close an open binding +closeB :: HasType a => BindO a -> Statement +closeB (BindO p e) = p =: e + +-- TODO: Swap names '(=:)' and '(=::)' if '(=:)' becomes more popular. + +{-------------------------------------------------------------------- + Show instances +--------------------------------------------------------------------} + +instance Show Bind where showsPrec = showsPretty +instance Show Statement where showsPrec = showsPretty +instance Show Declaration where showsPrec = showsPretty +instance Show Param where showsPrec = showsPretty +instance Show Definition where showsPrec = showsPretty +instance Show Shader where showsPrec = showsPretty +instance Show Program where showsPrec = showsPretty + +{-------------------------------------------------------------------- + Utility belt +--------------------------------------------------------------------} + +-- Show, lower-casing the first char and padding +lshowPad :: Show a => Int -> a -> Doc +lshowPad n = text . onHead toLower . padTo n . show + +-- handy variants +vcat', tupled' :: Pretty a => [a] -> Doc +vcat' = vcat . map pretty +tupled' = tupled . map pretty + +-- Doc in a scope +scoped :: Doc -> Doc +scoped d = braces (nest 4 (line <> d) <> line) + +-- The following alternative doesn't quite work, since the nesting happens +-- after the first line break and so doesn't apply to the first line. +-- +-- scoped = braces . newlines . nest 4 +-- where +-- -- Like braces, parens, ... +-- newlines :: Doc -> Doc +-- newlines = enclose line line + +onHead :: (a -> a) -> [a] -> [a] +onHead f (a:as) = f a : as +onHead _ _ = error "onHead: empty list" diff --git a/src/Shady/Language/Glom.hs b/src/Shady/Language/Glom.hs new file mode 100644 --- /dev/null +++ b/src/Shady/Language/Glom.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE GADTs, FlexibleContexts, Rank2Types, KindSignatures + , MultiParamTypeClasses, FunctionalDependencies + , FlexibleInstances, UndecidableInstances + , TypeFamilies + , EmptyDataDecls -- temporary + #-} +{-# OPTIONS_GHC -Wall #-} +---------------------------------------------------------------------- +-- | +-- Module : Shady.Language.Glom +-- Copyright : (c) Conal Elliott 2009 +-- License : AGPLv3 +-- +-- Maintainer : conal@conal.net +-- Stability : experimental +-- +-- Typed conglomerate of values +---------------------------------------------------------------------- + +module Shady.Language.Glom + ( FunctorU(..), MonadU(..) + , Glom(..), foldG, mapAG + -- , Glommable(..), Unglommable(..) + ) where + +import Control.Applicative (Applicative(..),liftA2) + +import Text.PrettyPrint.Leijen +import Text.PrettyPrint.Leijen.PrettyPrec +import Text.PrettyPrint.Leijen.DocExpr + +import Shady.Language.Type (HasType,PairF(..),UnitF(..)) + +infixr 7 :* + +-- | Map a polymorphic function over a conglomerate (preserving +-- structure). The required laws are the same as with 'Functor'. +class FunctorU q where + fmapU :: (forall a. f a -> g a) + -> (forall a. q f a -> q g a) + +-- TODO: fill in ApplicativeU + +class FunctorU m => MonadU m where + returnU :: f a -> m f a + extendU :: (forall a. f a -> m g a) + -> (forall a. m f a -> m g a) + +-- TODO: does FunctorU already have a name? + +-- | A typed conglomerate of values +data Glom f a where + BaseG :: f a -> Glom f a + UnitG :: Glom f () + (:*) :: (HasType a, HasType b, Show a, Show b) => + Glom f a -> Glom f b -> Glom f (a,b) + +instance UnitF (Glom f) where unit = UnitG +instance PairF (Glom f) where (#) = (:*) + +instance FunctorU Glom where + fmapU h (BaseG x) = BaseG (h x) + fmapU _ UnitG = UnitG + fmapU h (p :* q) = fmapU h p :* fmapU h q + +-- | Applicative/monadic map over a 'Glom'. +mapAG :: Applicative m => + (forall a. f a -> m ( g a)) -> + (forall a. Glom f a -> m (Glom g a)) +mapAG h (BaseG x) = fmap BaseG (h x) +mapAG _ UnitG = pure UnitG +mapAG h (p :* q) = liftA2 (:*) (mapAG h p) (mapAG h q) + +-- Like the tree/substitution monad +instance MonadU Glom where + returnU = BaseG + extendU h (BaseG x) = h x + extendU _ UnitG = UnitG + extendU h (p :* q) = extendU h p :* extendU h q + +-- | Fold over a 'Glom', given handlers for '(:*)', 'UnitG', and 'BaseG', +-- respectively. +foldG :: (c -> c -> c) -> c -> (forall b. f b -> c) + -> Glom f a -> c +foldG k e f (a :* b) = foldG k e f a `k` foldG k e f b +foldG _ e _ UnitG = e +foldG _ _ f (BaseG x) = f x + + +-- Convert a type to an 'Expr' for unparsing +instance HasExprU f => HasExprU (Glom f) where + exprU (BaseG x) = exprU x + exprU UnitG = var "()" + exprU (t :* t') = op InfixR 1 ":*" (exprU t) (exprU t') + +instance (HasExpr a, HasExprU f) => HasExpr (Glom f a) where expr = exprU + +-- Idea: convert a glom into a Doc glom. + +instance (HasExpr a, HasExprU f) => PrettyPrec (Glom f a) where + prettyPrec p = prettyPrec p . expr +instance (HasExpr a, HasExprU f) => Pretty (Glom f a) where + pretty = prettyPrec 0 +instance (HasExpr a, HasExprU f) => Show (Glom f a) where + show = show . pretty + + +-- Examples: + +-- newtype Sink a = Sink { sink :: a -> IO () } + +-- type Type = Glom VectorT +-- type Pat = Glom V +-- type Sinks = Glom Sink +-- type UniformsE = Glom E + +{- + +{-------------------------------------------------------------------- + Composing & decomposing Gloms +--------------------------------------------------------------------} + +class Glommable u f a | u f -> a where + glom :: u -> Glom f a + +instance Glommable () f () where glom () = UnitG + +instance (Glommable ua f a, Glommable ub f b, HasExpr a, HasExpr b) => + Glommable (ua,ub) f (a,b) where + glom (ua,ub) = glom ua :* glom ub + +-- Template to specialize per f: +-- +-- instance Glommable (f a) f a where glom = BaseG + +class Unglommable u f a | a f -> u where + unglom :: Glom f a -> u + +instance Unglommable () f () where unglom _ = () + +instance (Unglommable ua f a, Unglommable ub f b) => + Unglommable (ua,ub) f (a,b) where + unglom (ga :* gb) = (unglom ga, unglom gb) + unglom _ = error "unglom: oops" -- :( + +-- Template to specialize per (non-unit, non-pair) t: +-- +-- instance Unglommable (f t) f t where unglom = unglomId + +-- | Unglom a non-unit, non-pair +unglomId :: Glom f a -> f a +unglomId (BaseG ea) = ea +unglomId _ = error "unglomId: not BaseG. wtf?" + +instance Unglommable (f Int ) f Int where unglom = unglomId +instance Unglommable (f Bool ) f Bool where unglom = unglomId +instance Unglommable (f Float) f Float where unglom = unglomId + +instance Unglommable (f (Vec1 a)) f (Vec1 a) where unglom = unglomId +instance Unglommable (f (Vec2 a)) f (Vec2 a) where unglom = unglomId +instance Unglommable (f (Vec3 a)) f (Vec3 a) where unglom = unglomId +instance Unglommable (f (Vec4 a)) f (Vec4 a) where unglom = unglomId + +-} diff --git a/src/Shady/Language/Graph.hs b/src/Shady/Language/Graph.hs new file mode 100644 --- /dev/null +++ b/src/Shady/Language/Graph.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE GADTs, KindSignatures, ExistentialQuantification, Rank2Types #-} +{-# OPTIONS_GHC -Wall #-} +---------------------------------------------------------------------- +-- | +-- Module : Shady.Language.Graph +-- Copyright : (c) Conal Elliott 2009 +-- License : AGPLv3 +-- +-- Maintainer : conal@conal.net +-- Stability : experimental +-- +-- Based on a typed variant of Andy Gill's data-reify. After several +-- tries, I wasn't able to reuse data-reify or my typed variant of it. +-- The problem was that I need my 'HasType' class and 'Type' type, but I +-- couldn't parameterize data-reify by the /class/ 'HasType'. +---------------------------------------------------------------------- + +module Shady.Language.Graph + ( + -- * Typed identifiers + NodeId, Tid(..) + -- * Graph nodes + , N(..), mapDeRef + -- * Bindings + , Bind(..) + -- * Graphs + , Graph(..) + ) where + +import Control.Applicative (Applicative(..),liftA2) + +import Shady.Language.Operator +import Shady.Language.Exp + + +{-------------------------------------------------------------------- + Typed identifiers +--------------------------------------------------------------------} + +-- | Node Identifiers +type NodeId = Int + +-- | Typed variables +data Tid a = Tid NodeId (Type a) + +instance Eq (Tid a) where Tid i _ == Tid j _ = i == j + +instance Show (Tid a) where show (Tid i _) = 'x' : show i + + +{-------------------------------------------------------------------- + Graph nodes +--------------------------------------------------------------------} + +data N :: * -> * where + VN :: V a -> N a + ON :: Op a -> N a + App :: (HasType a, HasType b) => + Tid (a -> b) -> Tid a -> N b + + +instance Show (N a) where + show (VN v) = unwords ["VN" ,show v] + show (ON o) = unwords ["ON" ,show o] + show (App a b) = unwords ["App",show a,show b] + + + +mapDeRef :: Applicative m + => (forall a. HasType a => E a -> m NodeId) + -> (forall a. HasType a => E a -> m (N a)) +mapDeRef _ (Var v) = pure $ VN v +mapDeRef _ (Op o) = pure $ ON o +mapDeRef f (u :^ v) = liftA2 App (app f u) (app f v) + -- liftA2 App (f u) (f v) +mapDeRef _ Lam{} = notSupp "Lam" + +notSupp :: String -> a +notSupp meth = error $ "mapDeRef on E: "++meth++" not supported" + +app :: (Functor m, HasType a) => (E a -> m NodeId) -> E a -> m (Tid a) +app f u = fmap (flip Tid (typeOf1 u)) (f u) + + +{-------------------------------------------------------------------- + Bindings +--------------------------------------------------------------------} + +-- | Binding pair +data Bind = forall a. HasType a => Bind NodeId (N a) + +instance Show Bind where + show (Bind v n) = show v ++" = "++ show n + + +{-------------------------------------------------------------------- + Graphs +--------------------------------------------------------------------} + +-- | Graph, described by bindings and a root variable +data Graph a = Graph [Bind] (Tid a) + + +instance Show (Graph a) where + show (Graph netlist start) = "let " ++ show netlist ++ " in " ++ show start diff --git a/src/Shady/Language/Operator.hs b/src/Shady/Language/Operator.hs new file mode 100644 --- /dev/null +++ b/src/Shady/Language/Operator.hs @@ -0,0 +1,335 @@ +{-# LANGUAGE KindSignatures, GADTs, PatternGuards, TypeOperators + , FlexibleContexts + #-} +{-# OPTIONS_GHC -Wall #-} +---------------------------------------------------------------------- +-- | +-- Module : Shady.Language.Operator +-- Copyright : (c) Conal Elliott 2009 +-- License : GPLv3 +-- +-- Maintainer : conal@conal.net +-- Stability : experimental +-- +-- Known constants +---------------------------------------------------------------------- + +module Shady.Language.Operator + ( Op(..), OpInfo(..), info + , opExpr, opVal, opEq + ) where + +import Prelude hiding (all,any) + +import Control.Applicative (liftA2) +import Data.Foldable (all,any) + +import Text.PrettyPrint.Leijen.DocExpr + +import Control.Compose (result) + +import Data.VectorSpace (VectorSpace(..),InnerSpace(..)) + +-- import Shady.Language.Equality +import Shady.Language.Type +-- import Shady.Vec +import Shady.Misc + + +{-------------------------------------------------------------------- + Operators +--------------------------------------------------------------------} + +data Op :: * -> * where + -- Literal + Lit :: Show a => a -> Op a + -- Booleans + -- Hack: say that And/Or work on bool vectors. Later, revert and + -- implement the vector versions via the scalar versions. + And :: IsNat n => Op (Binop (Vec n Bool)) + -- Op (Binop B1) + Or :: IsNat n => Op (Binop (Vec n Bool)) + -- Op (Binop B1) + Not :: IsNat n => Op (Unop (Vec n Bool)) + EqualV :: (IsNat n, IsScalar a, Eq a) => + Nat n -> Op (Vec n a -> Vec n a -> Vec n Bool) + AllV :: IsNat n => Op (Vec n Bool -> B1) + AnyV :: IsNat n => Op (Vec n Bool -> B1) + -- Eq + Equal :: Eq (Vec n a) => Op (Pred2 (Vec n a)) + -- Ord + Lt :: (IsNat n, IsScalar a, Ord a) => Nat n -> Op (Vec n a -> Vec n a -> Vec n Bool) + Le :: (IsNat n, IsScalar a, Ord a) => Nat n -> Op (Vec n a -> Vec n a -> Vec n Bool) + Min :: (IsNat n, IsScalar a, Ord a) => Op (Binop (Vec n a)) + Max :: (IsNat n, IsScalar a, Ord a) => Op (Binop (Vec n a)) + -- Num + Negate :: (IsNat n, IsScalar a, Num a) => Op (Unop (Vec n a)) + Add :: (IsNat n, IsScalar a, Num a) => Op (Binop (Vec n a)) + Sub :: (IsNat n, IsScalar a, Num a) => Op (Binop (Vec n a)) + Mul :: (IsNat n, IsScalar a, Num a) => Op (Binop (Vec n a)) + Abs :: (IsNat n, IsScalar a, Num a) => Op (Unop (Vec n a)) + Signum :: (IsNat n, IsScalar a, Num a) => Op (Unop (Vec n a)) + -- Integral + Quot :: (IsNat n, IsScalar a, Integral a) => Op (Binop (Vec n a)) + Rem :: (IsNat n, IsScalar a, Integral a) => Op (Binop (Vec n a)) + Div :: (IsNat n, IsScalar a, Integral a) => Op (Binop (Vec n a)) + Mod :: (IsNat n, IsScalar a, Integral a) => Op (Binop (Vec n a)) + -- Fractional + Recip :: (IsNat n, IsScalar a, Fractional a) => Op (Unop (Vec n a)) + Divide :: (IsNat n, IsScalar a, Fractional a) => Op (Binop (Vec n a)) + -- Floating + Sqrt :: (IsNat n, IsScalar a, Floating a) => Op (Unop (Vec n a)) + Exp :: (IsNat n, IsScalar a, Floating a) => Op (Unop (Vec n a)) + Log :: (IsNat n, IsScalar a, Floating a) => Op (Unop (Vec n a)) + Sin :: (IsNat n, IsScalar a, Floating a) => Op (Unop (Vec n a)) + Cos :: (IsNat n, IsScalar a, Floating a) => Op (Unop (Vec n a)) + Asin :: (IsNat n, IsScalar a, Floating a) => Op (Unop (Vec n a)) + Atan :: (IsNat n, IsScalar a, Floating a) => Op (Unop (Vec n a)) + Acos :: (IsNat n, IsScalar a, Floating a) => Op (Unop (Vec n a)) + Sinh :: (IsNat n, IsScalar a, Floating a) => Op (Unop (Vec n a)) + Cosh :: (IsNat n, IsScalar a, Floating a) => Op (Unop (Vec n a)) + Asinh :: (IsNat n, IsScalar a, Floating a) => Op (Unop (Vec n a)) + Atanh :: (IsNat n, IsScalar a, Floating a) => Op (Unop (Vec n a)) + Acosh :: (IsNat n, IsScalar a, Floating a) => Op (Unop (Vec n a)) + -- RealFrac + Truncate :: IsNat n => Op (Unop (Vec n R)) + Round :: IsNat n => Op (Unop (Vec n R)) + Ceiling :: IsNat n => Op (Unop (Vec n R)) + Floor :: IsNat n => Op (Unop (Vec n R)) + FMod :: (IsNat n, IsScalar a, FMod a) => Op (Binop (Vec n a)) + -- Vector + -- VVec1 :: IsScalar a => Op (One a -> One a) + VVec2 :: IsScalar a => Op (One a -> One a -> Two a) + VVec3 :: IsScalar a => Op (One a -> One a -> One a -> Three a) + VVec4 :: IsScalar a => Op (One a -> One a -> One a -> One a -> Four a) + Dot :: IsNat n => Op (Vec n R -> Vec n R -> R1) + Swizzle :: (IsNat n, IsNat m, IsScalar a) => + Vec n (Index m) -> Op (Vec m a -> Vec n a) + -- Nestable pairs + Unit :: Op () + Pair :: Op (a -> b -> (a,b)) + Fst :: Op ((a,b) -> a) + Snd :: Op ((a,b) -> b) + -- Misc + If :: HasType a => Op (B1 -> Binop a) + Cat :: (IsNat m, IsNat n, IsNat (m :+: n), IsScalar a) => + Nat m -> Nat n -> VectorT (m :+: n) a + -> Op (Vec m a -> Vec n a -> Vec (m :+: n) a) + UniformV :: IsNat n => VectorT n a -> Op (One a -> Vec n a) + Scale :: (IsNat n, Num a, IsScalar a) => Op (One a -> Unop (Vec n a)) + -- Misc graphics-specific + Texture :: IsNat n => Nat n -> Op (Sampler n -> Vec n R -> R4) + +-- TODO: eliminate Scale? unsure. +instance Show (Op t) where show = oiName . info + + +{-------------------------------------------------------------------- + Fixity/precedence info +--------------------------------------------------------------------} + +type Fixity = Maybe (Associativity, Int) + +infixA :: Associativity -> Int -> Fixity +infixA ass n = Just (ass, n) + +nofix :: Fixity +nofix = Nothing + +infixL, infixR, infixN :: Int -> Fixity + +infixL = infixA InfixL +infixR = infixA InfixR +infixN = infixA Infix + +one1 :: (a -> b) -> a -> One b +one1 = result vec1 + +one2 :: (a -> b -> c) -> a -> b -> One c +one2 = result one1 + +-- in1 :: (a -> b) -> One a -> One b +-- in1 = un1 ~> vec1 -- or fmap + +-- in2 :: (a -> b -> c) -> One a -> One b -> One c +-- in2 = un1 ~> in1 + +-- in1, in2 subsumed by fmap & liftA2. + + +{-------------------------------------------------------------------- + Operator info +--------------------------------------------------------------------} + +data OpInfo a = OpInfo { oiName :: String, oiVal :: a, oiFix :: Fixity } + +info :: Op a -> OpInfo a + +info (Lit a) = OpInfo (show a) a nofix + +info And = OpInfo "(&&)" (liftA2 (&&)) (infixR 3) +info Or = OpInfo "(||)" (liftA2 (||)) (infixR 2) +info Not = OpInfo "not" (fmap not) nofix +info Equal = OpInfo "(==)" (one2 (==)) (infixN 4) + +info (EqualV n) = condN "(==)" "equal" (liftA2 (==)) (infixN 4) n + +info AllV = OpInfo "all" all' nofix +info AnyV = OpInfo "any" any' nofix + +info (Lt n) = condN "(<)" "lessThan" (liftA2 (<) ) (infixN 4) n +info (Le n) = condN "(<=)" "lessThanEqual" (liftA2 (<=)) (infixN 4) n +info Min = OpInfo "min" min nofix +info Max = OpInfo "max" max nofix + +info Negate = OpInfo "negate" negate nofix +info Add = OpInfo "(+)" (+) (infixL 6) +info Sub = OpInfo "(-)" (-) (infixL 6) +info Mul = OpInfo "(*)" (*) (infixL 7) +info Abs = OpInfo "abs" abs nofix +info Signum = OpInfo "sign" signum nofix + +info Quot = OpInfo "quot" quot nofix +info Rem = OpInfo "rem" rem nofix +info Div = OpInfo "div" div nofix +info Mod = OpInfo "mod" mod nofix + +info Recip = OpInfo "recip" recip nofix +info Divide = OpInfo "(/)" (/) (infixL 7) +info FMod = OpInfo "mod" fmod nofix + +info Sqrt = OpInfo "sqrt" sqrt nofix +info Exp = OpInfo "exp" exp nofix +info Log = OpInfo "log" log nofix +info Sin = OpInfo "sin" sin nofix +info Cos = OpInfo "cos" cos nofix +info Asin = OpInfo "asin" asin nofix +info Atan = OpInfo "atan" atan nofix +info Acos = OpInfo "acos" acos nofix +info Sinh = OpInfo "sinh" sinh nofix +info Cosh = OpInfo "cosh" cosh nofix +info Asinh = OpInfo "asinh" asinh nofix +info Atanh = OpInfo "atanh" atanh nofix +info Acosh = OpInfo "acosh" acosh nofix + +info Truncate = OpInfo "truncate" (i2f . truncate) nofix +info Round = OpInfo "round" (i2f . round) nofix +info Ceiling = OpInfo "ceiling" (i2f . ceiling) nofix +info Floor = OpInfo "floor" (i2f . floor) nofix + +info VVec2 = OpInfo "vec2" vvec2 nofix +info VVec3 = OpInfo "vec3" vvec3 nofix +info VVec4 = OpInfo "vec4" vvec4 nofix +info Dot = OpInfo "dot" (<.>) nofix +-- info (Dot n) = condN "(*)" "dot" (<.>) (infixL 7) n + +info (Swizzle ixs) = OpInfo (swizzleName ixs) (swizzle ixs) nofix + +info Unit = OpInfo "()" () nofix +info Pair = OpInfo "(#)" (,) (infixR 1) +info Fst = OpInfo "fst" fst nofix +info Snd = OpInfo "snd" snd nofix + +info If = OpInfo "cond" if' nofix +info (Cat _ _ t) = OpInfo (show t) (<+>) nofix +info (UniformV t) = OpInfo (show t) (pureV . un1) nofix +info Scale = OpInfo "(*)" (*^) (infixR 7) + +info (Texture n) = OpInfo ("texture" ++ show n ++ "D") texture nofix + +opVal :: Op a -> a +opVal = oiVal . info + +-- Will compile-time texture sampling happen? If so, implement it. +texture :: IsNat n => Sampler n -> Vec n R -> R4 +texture = error "texture: no constant fold" + +i2f :: Vec n Int -> Vec n Float +i2f = fmap fromIntegral + +-- opFix :: Op a -> Fixity +-- opFix = oiFix . info + +-- Pick one info for n==1 and another for other n. For instance, +-- "(==)" vs "equal". +condN :: String -> String -> a -> Fixity -> Nat n -> OpInfo a +condN name1 _ val fixity (Succ Zero) = OpInfo name1 val fixity +condN _ namen val _ _ = OpInfo namen val nofix + +vvec2 :: One a -> One a -> Two a +vvec2 a b = un1 a :< b + +vvec3 :: One a -> One a -> One a -> Three a +vvec3 a b c = un1 a :< vvec2 b c + +vvec4 :: One a -> One a -> One a -> One a -> Four a +vvec4 a b c d = un1 a :< vvec3 b c d + +all', any' :: Vec n Bool -> B1 +all' = vec1 . all id +any' = vec1 . any id + +-- Part name +part :: Index m -> Char +part (Index _ m) = "xyzw" !! fromIntegral (natToZ m) + +parts :: Vec n (Index m) -> String +parts ixs = map part (vElems ixs) + +-- getName :: Index m -> String +-- getName ix = "GET" ++ [part ix] + +swizzleName :: Vec n (Index m) -> String +swizzleName ixs = "GET" ++ parts ixs + + +{-------------------------------------------------------------------- + Pretty printing +--------------------------------------------------------------------} + +-- | Operator application +opExpr :: Op z -> [Expr] -> Expr +opExpr Not [e] = fun "!" e +opExpr Negate [e] = fun "-" e +opExpr If [c,t,e] = ifExpr c t e +opExpr (Swizzle ixs) [e] = dotX (map part (vElems ixs)) e +opExpr Recip [e] = lift (1.0 :: Float) / e +opExpr (UniformV (VectorT (Succ Zero) _)) [e] = e +opExpr oper [x,y] | Just (ass,p) <- fixity + = op ass p (infixize name) x y + where + OpInfo name _ fixity = info oper +opExpr oper xs = ccall (oiName (info oper)) xs + + +-- Make a name infix-ready. "(+)" --> "+", and "div" --> "`div`" +infixize :: String -> String +infixize ('(':cs) = init cs +infixize n = "`" ++ n ++ "`" + +if' :: B1 -> Binop a +if' c t e = if un1 c then t else e + +ifExpr :: Expr -> Expr -> Expr -> Expr +ifExpr c t e = op Infix 0 "?" c $ + op Infix 1 ":" t e + +-- TODO: Better formatting for ?: I'd like to align ":" with "?", and I +-- don't know how (elegantly). + + +{-------------------------------------------------------------------- + Operator equality +--------------------------------------------------------------------} + +-- Operator equality, including differently typed operators. +opEq :: Op a -> Op b -> Bool + +-- This implementation assumes that different operators look different. +oper `opEq` oper' = oiName (info oper) == oiName (info oper') + +-- A polymorphism variant doesn't work: +-- +-- opEq = (==) `on` (oiName . info) + +instance SynEq Op where (=-=) = opEq diff --git a/src/Shady/Language/Reify.hs b/src/Shady/Language/Reify.hs new file mode 100644 --- /dev/null +++ b/src/Shady/Language/Reify.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE UndecidableInstances, TypeFamilies, BangPatterns, Rank2Types + , ExistentialQuantification, PatternGuards, ScopedTypeVariables + , MultiParamTypeClasses, GADTs + #-} +{-# OPTIONS_GHC -Wall #-} + +---------------------------------------------------------------------- +-- | +-- Module : Shady.Language.Reify +-- Copyright : (c) Conal Elliott 2009 +-- License : AGPLv3 +-- +-- Maintainer : conal@conal.net +-- Stability : experimental +-- +-- Discover representation sharing in expressions +-- Variation on Andy Gill's Data.Reify. +---------------------------------------------------------------------- + + + +module Shady.Language.Reify (reifyGraph) where + +import Control.Concurrent.MVar +-- import Control.Monad +import System.Mem.StableName +import Data.IntMap as M + +import Shady.Language.Exp +import Shady.Language.Graph + + +data StableBind = forall a. HasType a => StableBind NodeId (StableName (E a)) + + +-- | 'reifyGraph' takes a data structure that admits 'MuRef', and returns +-- a 'Graph' that contains the dereferenced nodes, with their children as +-- integers rather than recursive values. +reifyGraph :: HasType a => E a -> IO (Graph a) +reifyGraph e = do rt1 <- newMVar M.empty + rt2 <- newMVar [] + root <- findNodes rt1 rt2 e + binds <- readMVar rt2 + return (Graph binds (Tid root typeT)) + + +findNodes :: HasType a => + MVar (IntMap [StableBind]) + -> MVar [Bind] + -> E a -> IO NodeId +findNodes rt1 rt2 ea = + do nextI <- newMVar 0 + let newIndex = modifyMVar nextI (\ n -> return (n+1,n)) + loop :: HasType b => E b -> IO NodeId + loop !eb = do + st <- makeStableName eb + tab <- takeMVar rt1 + case mylookup st tab of + Just i -> do putMVar rt1 tab + return $ i + Nothing -> + do i <- newIndex + putMVar rt1 $ + M.insertWith (++) (hashStableName st) [StableBind i st] tab + res <- mapDeRef loop eb + tab' <- takeMVar rt2 + putMVar rt2 $ Bind i res : tab' + return i + in loop ea + +mylookup :: forall a. HasType a => + StableName (E a) -> IntMap [StableBind] -> Maybe NodeId +mylookup sta tab = + M.lookup (hashStableName sta) tab >>= llookup + where + tya :: Type a + tya = typeT + llookup :: [StableBind] -> Maybe NodeId + llookup [] = Nothing + llookup (StableBind i stb : binds') + | Just Refl <- tya `tyEq` typeOf2 stb, sta == stb = Just i + | otherwise = llookup binds' diff --git a/src/Shady/Language/Share.lhs b/src/Shady/Language/Share.lhs new file mode 100644 --- /dev/null +++ b/src/Shady/Language/Share.lhs @@ -0,0 +1,280 @@ + + +Experiments with sharing recovery on GADT-based expression representations. + +> module Shady.Language.Share (cse) where + +Imports +======= + +> import Prelude hiding (foldr) +> +> import Data.Function (on) +> import Data.Ord (comparing) +> import Data.List (sortBy) +> import Control.Applicative (Applicative(..),liftA2,(<$>)) +> import Control.Arrow (first,second,(&&&)) +> import Data.Foldable (foldr) +> +> import qualified Control.Monad.State as S +> +> import Data.Map (Map) +> import qualified Data.Map as Map +> import Data.Set (Set) +> import qualified Data.Set as Set +> +> import Data.Proof.EQ + +> import Shady.Language.Exp + +< import Debug.Trace + + +Common subexpression elimination +================================ + +To elimination common subexpressions, convert from expression to graph (dag) and back to expression. +The final expression will use `let` (as beta redexes) to abstract out expressions that appear more than once. + +> cse :: HasType a => E a -> E a +> cse = undagify . dagify + + +Graphs +====== + +A graph is a map from expressions to variable names, plus a root expression (typically a variable). + +> type Graph a = (E a, Map TExp Id) + +A `TExp` wraps an expression, encapsulating the type. +I'll also include the result of `show`, since I use it in comparisons, which I expect to cause it to be accessed repeatedly. + +> data TExp = forall a. HasType a => TExp (E a) String + +> tExp :: HasType a => E a -> TExp +> tExp e = TExp e (show e) + +> instance Show TExp where show (TExp _ s) = s + +The reason for mapping from an expression to index instead of vice versa is just that it's more efficient to build in this direction. +We'll invert the map later when we convert back from `Graph` to `E`. + +> invertMap :: Ord v => Map k v -> Map v k +> invertMap = Map.fromList . map (\ (n,i) -> (i,n)) . Map.toList + +To use `TExp` as a map key, it'll have to be ordered. +For simplicity, I'll just use the printed form of the `E`. + +> instance Eq TExp where +> TExp _ s == TExp _ t = s == t +> +> instance Ord TExp where +> TExp _ s `compare` TExp _ t = s `compare` t + + +Conversion from E to Graph (dag) +================================== + +I'll structure conversion from `E` to Graph (dag) around a monad for computations that accumulate +an exp map and a list of unused names. +The names are guaranteed to be in ascending order so that we can trivially top-sort the graph later. + +> type ExpMap = Map TExp Id + +> type GraphM = S.State (ExpMap, [Id]) + +> dagify :: HasType a => E a -> Graph a +> dagify e = second fst $ S.runState (dagifyExp e) (Map.empty, ids) +> where +> allIds, ids :: [Id] +> allIds = "" : [c:name | name <- allIds, c <- ['a'..'z']] +> ids = filter (not . (`Set.member` eVars)) (map reverse (tail allIds)) +> eVars :: Set Id +> eVars = vars e + +The name list is not alphabetized and moreover could not be alpabetized. +Define a comparison function, which could be compare length/string pairs. + +> compareIds :: String -> String -> Ordering +> compareIds = comparing (length &&& id) + +Graph construction works by recursively constructing and inserting expression/name pairs: + +> dagifyExp :: HasType a => E a -> GraphM (E a) +> dagifyExp e = dagN e >>= insertG +> +> dagN :: HasType a => E a -> GraphM (E a) +> dagN (Var v) = pure $ Var v +> dagN (Op o) = pure $ Op o +> dagN (f :^ a) = liftA2 (:^) (dagifyExp f) (dagifyExp a) +> -- dagN (Lam v b) = Lam v <$> dagifyExp b +> dagN (Lam _ _) = error "dagN: Can't yet perform CSE on Lam" + +If the given expression is already in the graph, reuse the existing identifier. +Otherwise, insert insert it, giving it a new identifier. + +> insertG :: HasType a => E a -> GraphM (E a) +> insertG e | not (abstractable e) = return e +> | otherwise = maybe (addExp e) return +> =<< findExp e <$> S.gets fst +> +> addExp :: HasType a => E a -> GraphM (E a) +> addExp e = do name <- genId +> S.modify (first (Map.insert (tExp e) name)) +> return (Var (var name)) + +Needing `HasType` in `insertG` forced me to add it several other places, including in the `E` constructor types. + +An expression is abstractable if it has base type and is non-trivial. + +< abstractable :: HasType a => E a -> Bool +< abstractable e = nonTrivial e && isBaseType (typeOf1 e) + +< nonTrivial :: Exp a -> Bool +< nonTrivial (_ :^ _) = True +< nonTrivial _ = False + +> isBaseType :: Type a -> Bool +> isBaseType (VecT _) = True +> isBaseType _ = False + +On second thought, omit the `nonTrivial` condition. +With GLSL, it's worthwhile even abstracting literals. + +> abstractable :: HasType a => E a -> Bool +> abstractable e = isBaseType (typeOf1 e) + + +Identifier generation is as usual, accessing and incrementing the counter state: + +> genId :: GraphM Id +> genId = do (m,name:names) <- S.get +> S.put (m,names) +> return name + +To search for an exp in the accumulated map, + +> findExp :: HasType a => E a -> ExpMap -> Maybe (E a) +> findExp e = fmap (Var . var) . Map.lookup (tExp e) + + +Free variables +============== + +Count all variables occurrences in an expression: + +> countOccs :: E a -> Map Id Int +> countOccs (Var (V n _)) = Map.singleton n 1 +> countOccs (Op _) = Map.empty +> countOccs (f :^ a) = Map.unionWith (+) (countOccs f) (countOccs a) +> countOccs (Lam (V n _) b) = Map.delete n (countOccs b) + +> tCountOccs :: TExp -> Map Id Int +> tCountOccs (TExp e _) = countOccs e + +Also handy will be extracting all variables free & bound: + +> vars :: E a -> Set Id +> vars (Var (V n _)) = Set.singleton n +> vars (Op _) = Set.empty +> vars (f :^ a) = vars f `Set.union` vars a +> vars (Lam (V n _) b) = Set.insert n (vars b) + + +Conversion from Graph (dag) to E +================================== + +Given a `Graph`, let's now build an `E`, with sharing. + +Recall the `Graph` type and map inversion, defined above: + +< type Graph a = (E a, ExpMap) + +To rebuild an `E`, walk through the inverted map in order, generating a `let` for each binding. + +< undagify :: forall a. HasType a => Graph a -> E a +< undagify (root,expToId) = +< foldr bind root (sortedBinds (invertMap expToId)) +< where +< bind :: (Id,TExp) -> E a -> E a +< bind (name, TExp rhs) = lett name rhs + +> sortedBinds :: Map Id TExp -> [(Id,TExp)] +> sortedBinds = sortBy (compareIds `on` fst) . Map.toList + + +Inlining +-------- + +To minimize the `let` bindings, let's re-inline all bindings that are used only once. +To know how which bindings are used only once, count them. + +> inlinables :: HasType a => Graph a -> Set Id + + > inlinables = const Set.empty -- temp + +> inlinables g = asSet $ (== 1) <$> countUses g + +> countUses :: HasType a => Graph a -> Map Id Int +> countUses (e,m) = Map.unionsWith (+) (map tCountOccs (tExp e : Map.keys m)) + +Turn a boolean map (characteristic function) into a set: + +> asSet :: Ord k => Map k Bool -> Set k +> asSet = Set.fromList . Map.keys . Map.filter id + +Now revisit `undagify`, performing some inlining along the way. + +> undagify :: forall a. HasType a => Graph a -> E a +> undagify g@(root,expToId) = foldr bind (inline root) (sortedBinds texps) +> where +> texps :: Map Id TExp +> texps = invertMap expToId +> ins :: Set Id +> ins = inlinables g +> bind :: (Id,TExp) -> E a -> E a +> bind (name, TExp rhs _) = lett' name (inline rhs) +> -- Inline texps in an expression +> inline :: E b -> E b +> inline (Var v@(V name _)) | Set.member name ins, Just e' <- tLookup v texps = inline e' +> inline (f :^ a) = inline f :^ inline a +> inline (Lam v b) = Lam v (inline b) -- assumes no shadowing +> inline e = e +> -- Make a let binding unless an inlined variable. +> lett' :: (HasType b, HasType c) => +> Id -> E b -> E c -> E c +> lett' n rhs | Set.member n ins = id +> | otherwise = letE (var n) rhs + +For the inlining step, we'll have to look up a variable in the map, and check that it has the required type. + +> tLookup :: V a -> Map Id TExp -> Maybe (E a) +> tLookup (V name tya) m = fromTExp tya <$> Map.lookup name m + +> fromTExp :: Type a -> TExp -> E a +> fromTExp tya (TExp e _) | Just Refl <- typeOf1 e `tyEq` tya = e +> | otherwise = error "fromTExp type fail" + +I'm not satisfied having to deal the type check explicitly here. +Maybe a different abstraction would help; perhaps a type-safe homogeneous map instead of `Map Id TExp`. + + + + + [semantic editor combinator]: http://conal.net/blog/posts/semantic-editor-combinators/ "blog post" diff --git a/src/Shady/Language/Type.hs b/src/Shady/Language/Type.hs new file mode 100644 --- /dev/null +++ b/src/Shady/Language/Type.hs @@ -0,0 +1,378 @@ +{-# LANGUAGE GADTs, KindSignatures, FlexibleInstances, FlexibleInstances + , MultiParamTypeClasses, FunctionalDependencies + , UndecidableInstances, TypeOperators, ScopedTypeVariables + , FlexibleContexts, CPP + #-} +{-# LANGUAGE StandaloneDeriving #-} + +{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} + +---------------------------------------------------------------------- +-- | +-- Module : Shady.Language.Type +-- Copyright : (c) Conal Elliott 2009 +-- License : GPLv3 +-- +-- Maintainer : conal@conal.net +-- Stability : experimental +-- +-- Types +---------------------------------------------------------------------- + +module Shady.Language.Type + ( + -- * Type values + ScalarT(..), VectorT(..), Type(..) + , TextureId, Sampler(..), sampler1, sampler2, sampler3, Sampler1, Sampler2, Sampler3 + -- * Generating type values + , IsScalar(..), vectorT, HasType(..) + , typeOf, typeOf1, typeOf2, compatible, compatible1 + , IsVec(..),checkVec, checkVec' + -- * Type equality + , (:=:)(..), ptyEq, vtyEq, tyEq + , (=:=), (===) + -- * Vector operations + -- , Vector(..) + -- * Convenient type synonyms + , R, R1, R2, R3, R4, B1, Pred1, Pred2 + -- * Notions of equality + , SynEq(..),SynEq2(..) + -- * Pairing and unit + , PairF(..), (:#), UnitF(..) + -- * Re-export + , module Shady.Vec + ) where + +import Control.Applicative (pure,liftA2,Const(..)) +import Data.Maybe (isJust) +import Data.List (intercalate) +import Control.Monad.Instances () +import Foreign.Storable + +import Data.Typeable (Typeable) + +import Text.PrettyPrint.Leijen +import Text.PrettyPrint.Leijen.PrettyPrec +import Text.PrettyPrint.Leijen.DocExpr + +import Shady.Misc (FMod(..),R) +import Shady.Vec +import Data.Proof.EQ +-- import Shady.Language.Equality +-- import Shady.MechanicsGL (GlTexture) + + +{-------------------------------------------------------------------- + Type values +--------------------------------------------------------------------} + +-- Primitive types +data ScalarT :: * -> * where + Bool :: ScalarT Bool + Int :: ScalarT Int + Float :: ScalarT Float + +instance Show (ScalarT a) where + show Bool = "bool" + show Int = "int" + show Float = "float" + +instance HasExprU ScalarT where + exprU Bool = var "bool" + exprU Int = var "int" + exprU Float = var "float" + +instance Pretty (ScalarT a) where pretty = text . show + +vshow :: Show a => a -> Expr +vshow = var . show + +instance HasExpr (ScalarT a) where expr = vshow + +data VectorT n a = VectorT (Nat n) (ScalarT a) + +instance Show (VectorT n a) where + show (VectorT n t) = showVectorN (natToZ n) t + +-- instance HasExpr a => HasExpr (VectorT a) where expr = expr1 +-- instance HasExpr1 VectorT where expr1 = var . show + +instance HasExprU (VectorT n) where exprU = expr +instance HasExpr (VectorT n a) where expr = var . show + +showVectorN :: Integer -> ScalarT a -> String +showVectorN 1 p = show p +showVectorN n p = pref p ++ "vec" ++ show n + where + pref :: ScalarT b -> String + pref Bool = "b" + pref Int = "i" + pref Float = "" + +instance Pretty (VectorT n a) where pretty = text . show + +-- | Encoding of texture ids in values. I'm using 'Int' instead of +-- @GLuint@ here to avoid depending on OpenGL in this module & package. +type TextureId = Int + +-- | An @n@-dimensional GLSL sampler. +data Sampler n = + Sampler { samplerDim :: Nat n, samplerTexture :: TextureId } + +type Sampler1 = Sampler OneT +type Sampler2 = Sampler TwoT +type Sampler3 = Sampler ThreeT + +instance Show (Sampler n) where + show (Sampler n tex) = "" + +instance Pretty (Sampler n) where + pretty = text . show + +sampler1 :: TextureId -> Sampler1 +sampler1 = Sampler one -- or Sampler nat + +sampler2 :: TextureId -> Sampler2 +sampler2 = Sampler two -- or Sampler nat + +sampler3 :: TextureId -> Sampler3 +sampler3 = Sampler three -- or Sampler nat + +-- | Extended types. Vector types, samplers, unit, pairing, and functions. +data Type :: * -> * where + VecT :: (IsNat n, IsScalar a {-, Storable (Vec n a) -}) => + VectorT n a -> Type (Vec n a) + SamplerT :: IsNat n => Nat n -> Type (Sampler n) + UnitT :: Type () + (:*:) :: (HasType a, HasType b {-, Show a, Show b -}) => + Type a -> Type b -> Type (a , b) + (:->:) :: (HasType a, HasType b {-, Show a, Show b -}) => + Type a -> Type b -> Type (a -> b) + +instance HasExpr (Type t) where + expr (VecT t) = expr t + expr (SamplerT n) = var $ "sampler" ++ show n ++ "D" + expr UnitT = var "()" + expr (a :*: b) = op InfixR 1 ":*" (expr a) (expr b) + expr (a :->: b) = op InfixR 0 "->" (expr a) (expr b) + +instance HasExprU Type where exprU = expr + +instance PrettyPrec (Type t) where prettyPrec = prettyExpr +instance Pretty (Type t) where pretty = prettyPrec 0 +instance Show (Type t) where show = show . expr + + +{-------------------------------------------------------------------- + Generating type values +--------------------------------------------------------------------} + +-- EXPERIMENTAL: Typeable constraints + +-- | Has scalar type +class (Storable a, Typeable a, Show a) => IsScalar a where scalarT :: ScalarT a + +-- The Storable and Show prereqs simplify explicit constraints at uses. + +instance IsScalar Bool where scalarT = Bool +instance IsScalar Int where scalarT = Int +instance IsScalar Float where scalarT = Float + + +vectorT :: (IsNat n, IsScalar a) => VectorT n a +vectorT = VectorT nat scalarT + +-- | Known types +class Show t => HasType t where typeT :: Type t + +-- Sorry about that Show constraint. It's ultimately motivated by +-- the constant folding optimization and from there creeps into *lots* of contexts. + +-- The Show t is experimental. If it works out, remove Show from a lot of contexts. + +instance (IsNat n, IsScalar a {-, Storable (Vec n a)-}) => + HasType (Vec n a) where + typeT = VecT vectorT + +instance HasType () where typeT = UnitT +instance (HasType a, HasType b {-, Show a, Show b -}) => + HasType (a, b) where typeT = typeT :*: typeT +instance (HasType a, HasType b {-, Show a, Show b -}) => + HasType (a->b) where typeT = typeT :->: typeT + +instance IsNat n => HasType (Sampler n) where + typeT = SamplerT nat + +-- | Reify a type +typeOf :: HasType a => a -> Type a +typeOf = const typeT + +-- | Reify a type argument +typeOf1 :: HasType a => f a -> Type a +typeOf1 = const typeT + +-- | Reify a type argument's argument +typeOf2 :: HasType a => g (f a) -> Type a +typeOf2 = const typeT + + +-- | Demonstration that a type argument is a vector type. +data IsVec :: * -> * where + IsVec :: (IsNat n, IsScalar a) => IsVec (Vec n a) + +-- | Check for a vector type +checkVec :: forall t. HasType t => Maybe (IsVec t) +checkVec = + case (typeT :: Type t) of + VecT _ -> Just IsVec + _ -> Nothing + +-- | Convenient wrapper around 'checkVec'. Ignores argument. +checkVec' :: forall f t. HasType t => f t -> Maybe (IsVec t) +checkVec' = const checkVec + + + +{-------------------------------------------------------------------- + Type equality +--------------------------------------------------------------------} + +-- | Try to prove equality of primitive types +ptyEq :: ScalarT a -> ScalarT b -> Maybe (a :=: b) +ptyEq Bool Bool = Just Refl +ptyEq Int Int = Just Refl +ptyEq Float Float = Just Refl +ptyEq _ _ = Nothing + +-- | Try to prove equality of types +vtyEq :: VectorT m a -> VectorT n b -> Maybe (Vec m a :=: Vec n b) +vtyEq (VectorT m a) (VectorT n b) = liftA2 liftEq2 (m `natEq` n) (a `ptyEq` b) + +-- | Try to prove equality of types +tyEq :: Type c -> Type c' -> Maybe (c :=: c') +tyEq (VecT a) (VecT a') = vtyEq a a' +tyEq (SamplerT n) (SamplerT n') = fmap liftEq (natEq n n') +tyEq UnitT UnitT = Just Refl +tyEq (a :*: b) (a' :*: b') = liftA2 liftEq2 (tyEq a a') (tyEq b b') +tyEq (a :->: b) (a' :->: b') = liftA2 liftEq2 (tyEq a a') (tyEq b b') +tyEq _ _ = Nothing + +-- TODO: Maybe define a class & method for the various typed equality +-- functions, with a nice infix method name. + +-- | Yields 'Just' 'Refl' if type-compatible /and/ equal. Otherwise 'Nothing'. +(=:=) :: forall f a b. (HasType a, HasType b, SynEq f) => + f a -> f b -> Maybe (a :=: b) +fa =:= fb = + case typeOf1 fa `tyEq` typeOf1 fb of + Just Refl -> if fa =-= fb then Just Refl else Nothing + Nothing -> Nothing + +-- | Same type and syntactically equal +(===) :: forall f a b. (HasType a, HasType b, SynEq f) => + f a -> f b -> Bool +fa === fb = isJust (fa =:= fb) + +-- | Do two values have the same type. If so, return a proof. +compatible :: (HasType a, HasType b) => a -> b -> Maybe (a :=: b) +x `compatible` y = typeOf x `tyEq` typeOf y + +-- | Do two values have the same argument type. If so, return a proof. +compatible1 :: (HasType a, HasType b) => f a -> g b -> Maybe (a :=: b) +x `compatible1` y = typeOf1 x `tyEq` typeOf1 y + + +{-------------------------------------------------------------------- + Convenient type synonyms +--------------------------------------------------------------------} + +-- TODO: Maybe move R to Misc and use in defining EyePos in MechanicsGL + +-- | Convenient short-hand +type R1 = One R +-- | Convenient short-hand +type R2 = Two R +-- | Convenient short-hand +type R3 = Three R +-- | Convenient short-hand +type R4 = Four R + +-- | Single boolean +type B1 = One Bool + +-- | Unary predicate +type Pred1 a = a -> B1 +-- | Binary predicate +type Pred2 a = a -> Pred1 a + + +{-------------------------------------------------------------------- + Notions of equality +--------------------------------------------------------------------} + +infix 4 =-=, =--= + +-- | Syntactic equality. Requires same argument type. +class SynEq f where + (=-=) :: HasType c => f c -> f c -> Bool + +instance Eq x => SynEq (Const x) where (=-=) = (==) + +-- | Higher-order variant of 'SynEq'. Can be defined via '(=-=)', or vice versa. +class SynEq2 f where + (=--=) :: (SynEq v, HasType c) => f v c -> f v c -> Bool + + +deriving instance Eq a => Eq (Const a b) + + +{-------------------------------------------------------------------- + Pairing +--------------------------------------------------------------------} + +infixr 1 #, :# + +class PairF f where + (#) :: (HasType a, HasType b {-, Show a, Show b -}) => + f a -> f b -> f (a :# b) + +-- | Syntactic alternative for pairing. Convenient for right-associative +-- infix use. +type a :# b = (a,b) + +class UnitF f where unit :: f () + + +{-------------------------------------------------------------------- + Orphans +--------------------------------------------------------------------} + +-- Pretty-printing here instead of Vec, so we can use VectorT. Numeric +-- instances here because Show is here. + +instance (IsNat n, IsScalar a, Pretty a) => Pretty (Vec n a) where + pretty v | n == 1 = pretty (head as) + | otherwise = pretty (vectorT :: VectorT n a) <> tupled (map pretty as) + where as = vElems v + n = length as + +instance (IsNat n, IsScalar a, Show a) => Show (Vec n a) where + show v | n == 1 = show (head as) + | otherwise = show (vectorT :: VectorT n a) + ++ "(" ++ intercalate "," (map show as) ++ ")" + where as = vElems v + n = length as + +instance (IsNat n, IsScalar a, Pretty a) => PrettyPrec (Vec n a) +instance (IsNat n, IsScalar a, Show a) => HasExpr (Vec n a) + +-- Generate bogus Enum instance, needed by 'Integral' +#define INSTANCE_Enum + +#define CONSTRAINTS IsNat n, IsScalar applicative_arg, +#define APPLICATIVE (Vec n) +#include "ApplicativeNumeric-inc.hs" + + +instance (IsNat n, IsScalar a, FMod a) => FMod (Vec n a) where + fmod = liftA2 fmod diff --git a/src/Shady/Misc.hs b/src/Shady/Misc.hs new file mode 100644 --- /dev/null +++ b/src/Shady/Misc.hs @@ -0,0 +1,147 @@ +{-# LANGUAGE TypeOperators, FlexibleContexts, TypeFamilies + , UndecidableInstances #-} +-- {-# OPTIONS_GHC -Wall -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wall #-} +---------------------------------------------------------------------- +-- | +-- Module : Shady.Misc +-- Copyright : (c) Conal Elliott 2009 +-- License : AGPLv3 +-- +-- Maintainer : conal@conal.net +-- Stability : experimental +-- +-- Misc useful definitions +---------------------------------------------------------------------- + +module Shady.Misc + ( -- argument, result, (~>), + FMod(..), Frac(..), fmodRF, fracRF, fmodViaFrac, fracViaFmod + , clamp, clampB, smoothStep + , Unop,Binop + , padTo + , flip1, flip2, flip3, flip4 + , Sink, Action, (>+>), forget + , R + -- * Find another home + , EyePos + ) where + +import Control.Applicative ((<$)) + +-- From TypeCompose package +import Control.Compose (result) +import Control.Instances () + +import Data.Maclaurin ((:>)(..)) -- For Frac instance +import Data.Boolean + +type R = Float + +-- | Clamp to a given range +clamp :: Ord a => (a,a) -> a -> a +clamp (lo,hi) = max lo . min hi + +-- | Variation on 'clamp', using 'OrdB' instead of 'Ord' +clampB :: (IfB bool a, OrdB bool a) => (a,a) -> a -> a +clampB (lo,hi) = maxB lo . minB hi + +-- | Smooth, clamped transition +smoothStep :: (Ord a, Num a) => (a,a) -> a -> a +smoothStep loHi val = t*t*(3-2*t) where t = clamp loHi val + + +-- | Unary transformation (endomorphism) +type Unop a = a -> a + +-- | Binary transformation +type Binop a = a -> a -> a + + +-- | Pad a string to the given length, adding spaces on the right as needed. +padTo :: Int -> String -> String +padTo n str = str ++ replicate (n - length str) ' ' + +-- | Move first argument to first place (for style uniformity) +flip1 :: (a -> b) -> (a -> b) +flip1 = id + +-- | Move second argument to first place ('flip' synonym for style uniformity) +flip2 :: (a -> b -> c) -> (b -> a -> c) +flip2 = flip + +-- | Move third argument to first place +flip3 :: (a -> b -> c -> d) -> (c -> a -> b -> d) +flip3 = flip . result flip + +-- | Move fourth argument to first place +flip4 :: (a -> b -> c -> d -> e) -> (d -> a -> b -> c -> e) +flip4 = flip . result flip3 + + +{-------------------------------------------------------------------- + frac & fmod +--------------------------------------------------------------------} + +-- | Take fractional component(s). Always non-negative. You can use +-- 'fracRF' for 'RealFrac' types and 'fracViaFmod' for 'Fmod' types. +class Frac a where frac :: a -> a + +-- | Real-valued modulo. You can use 'fmodRF' for 'RealFrac' types and +-- 'fmodViaFrac' for 'Frac' types. +class FMod a where fmod :: a -> a -> a + +-- | Fractional component. Useful for defining 'frac' on 'RealFrac' types. +fracRF :: RealFrac a => a -> a +fracRF x = x - fromIntegral (floor x :: Int) + + +-- | Fractional modulo. Useful for defining 'fmod' on 'RealFrac' types. +fmodRF :: RealFrac a => a -> a -> a +x `fmodRF` y = x - y * fromIntegral (floor (x/y) :: Int) + +-- | Handy defining 'frac' on a 'FMod' type. +fracViaFmod :: (Num a, FMod a) => a -> a +fracViaFmod = (`fmod` 1) + +-- | Handy defining 'fmod' on a 'Frac' type. +fmodViaFrac :: (Fractional a, Frac a) => a -> a -> a +x `fmodViaFrac` y = frac (x/y) * y + +instance FMod Float where fmod = fmodRF +instance Frac Float where frac = fracRF + +-- 'frac' of a derivative tower is 'frac' of the value and unchanged +-- derivatives. Not quite right, since 'frac' introduces discontinuities, +-- so all-sided derivatives don't really exist at those points. +instance Frac s => Frac (u :> s) where + frac (D s l) = D (frac s) l + + +{-------------------------------------------------------------------- + Information sinks +--------------------------------------------------------------------} + +-- | Synonym for @IO ()@. Obviates some parentheses. +type Action = IO () + +-- | Sink of information +type Sink a = a -> Action + +infixr 1 >+> + +-- | Combine sinks +(>+>) :: Sink a -> Sink b -> Sink (a,b) +(sa >+> sb) (a,b) = sa a >> sb b + +-- | Discard a functor value. +forget :: Functor f => f a -> f () +forget = (() <$) +-- forget = fmap (const ()) + +{-------------------------------------------------------------------- + Find another home +--------------------------------------------------------------------} + +type EyePos = (R,R,R) + diff --git a/src/Shady/Play/CseTest.hs b/src/Shady/Play/CseTest.hs new file mode 100644 --- /dev/null +++ b/src/Shady/Play/CseTest.hs @@ -0,0 +1,165 @@ +-- {-# LANGUAGE #-} +{-# OPTIONS_GHC -Wall -fno-warn-missing-signatures #-} +---------------------------------------------------------------------- +-- | +-- Module : Shady.Play.CseTest +-- Copyright : (c) Conal Elliott 2009 +-- License : AGPLv3 +-- +-- Maintainer : conal@conal.net +-- Stability : experimental +-- +-- Test new CSE stuff +---------------------------------------------------------------------- + +module Shady.Play.CseTest where + +-- import Control.Applicative (liftA2) + +import Data.VectorSpace +-- For testing +import Text.PrettyPrint.Leijen.DocExpr (Expr,HasExpr(expr)) + +import Data.Boolean + +import Shady.Language.Exp +-- import Shady.Color +-- import Shady.Image +import Shady.Complex +import Shady.Misc (frac) + +-- import Shady.Language.Cse +import Shady.Language.Share + +x :: HasExpr a => a -> Expr +x = expr + + +type Point = ComplexE R + + +{- +xc :: Color -> Expr +xc = expr . colorToR4 + +xp :: Point -> Expr +xp = expr . pointToR2 + +-} + +q :: FloatE +q = Var (var "q") + +t1,t2 :: FloatE +t1 = q + q + +-- Was @q * (q + q)@, now @let a = q + q in a * a@. What happened? +t2 = t1 * t1 + +c1 = cse t1 + +t3a = sin q / cos q + +-- let a = sin(q) in +-- let b = cos(q) in +-- b + a / b +-- +t3 = cos q + t3a + +-- cse => cos(q) + sin(q) / cos(q) + + +t3b = cq + sq / cq + where + cq = cos q + sq = sin q + +-- cse => let x3 = cos(q) in x3 + sin(q) / x3 + +-- let a = cos(q) in +-- a - 1.0 / a +-- +t4 = cos q - 1 / cos q + +-- let a = cos(q) in +-- a * (a + sin(q) / a) +-- +t5 = cos q * t3 + +-- let a = cos(q) in +-- (a + sin(q) / a) * (a - 1.0 / a) +-- +t6 = t3 * t4 + + +-- let a = cos(q) in +-- let b = sin(q) in +-- (a + b / a) * (a - 1.0 / a) + (a + b / a) + +t7 = t6 + t3 + +-- let a = sin(q) in +-- a + (1.0 - a) * (a < 3.0 ? 4.0 : 5.0) +-- +t8 = let a = sin q in a + (1 - a) * (ifB (a <* 3) 4 5) + +-- q * sin(q) +r = q * sin q + +-- let a = sin(q) in +-- a * (q * a) +s = sin q * r + +-- let a = sin(q) in +-- let b = q * a in +-- b + a * b +t9a = r + s + + +-- let a = sin(q) in +-- let b = q * a in +-- a * b + b +t9b = s + r + + +w = Var (var "w") :: R2E + +{- + +bw :: BoolE -> Color +bw = boolean white clear + + +ra :: R2E -> Color +ra z = bw (z <.> z <* 1) +-} + +stripes (a :+ _) = frac a <* 0.5 + +a1 :: FloatE +a1 = magnitudeSq (t *^ uv) + +{- +a2 :: BoolE +a2 = uscale2 t udisk uv + +a3 :: R4E +a3 = colorToR4 $ toColor (uscale2 (cos t) udisk uv) +-} + + +t :: FloatE +t = Var (var "t") +u,v :: FloatE +u = Var (var "u") +v = Var (var "v") + + +uv :: Point +uv = u :+ v + +------------- + +ts = [t1,t2,t3a,t3,t4,t5,t6,t8,t9a,t9b] + +main = mapM_ (print.expr) ts diff --git a/src/Shady/Play/VectorTest.hs b/src/Shady/Play/VectorTest.hs new file mode 100644 --- /dev/null +++ b/src/Shady/Play/VectorTest.hs @@ -0,0 +1,154 @@ +-- {-# LANGUAGE #-} +{-# OPTIONS_GHC -Wall -fno-warn-missing-signatures #-} +---------------------------------------------------------------------- +-- | +-- Module : Shady.Play.CseTest +-- Copyright : (c) Conal Elliott 2009 +-- License : AGPLv3 +-- +-- Maintainer : conal@conal.net +-- Stability : experimental +-- +-- Test auto vectorization +---------------------------------------------------------------------- + +module Shady.Play.VectorTest where + +-- For testing +import Text.PrettyPrint.Leijen.DocExpr (Expr,HasExpr(expr)) + +import Data.Boolean + +import Shady.Language.Exp +-- import Shady.Image +import Shady.Misc (fmod) + + +x :: HasExpr a => a -> Expr +x = expr + +-- y :: Point -> Expr +-- y = expr . pointToR2 + + +l,m,n :: FloatE +l = Var (var "l") +m = Var (var "m") +n = Var (var "n") + +q,r :: R2E +q = Var (var "q") +r = Var (var "r") + +t1 = m <+> m + +-- vec2(2.0,3.0) * vec2(m,m) +t2 = 2 * m <+> 3 * m + +-- (vec2(m,m) * vec2(q.x,q.y) +-- + vec2(n,- n) * vec2(q.y,q.x)) +-- * vec2(l,l) + +-- Without vectorization: + +-- vec2((m * q.x + n * q.y) * l +-- ,(m * q.y + - n * q.x) * l) + +t3 = (m * getX q - (- n * getY q)) * l <+> + (m * getY q - ( n * getX q)) * l + +-- bvec2 d = lessThan(vec2(0.5,0.5) +-- ,mod(vec2((c * _varying.x + a * _varying.y) * b +-- ,(c * _varying.y + - a * _varying.x) * b) +-- ,vec2(1.0,1.0))); + + +-- lessThan(vec2(0.5,0.5) +-- ,mod((cos(vec2(_uniform,_uniform)) +-- * vec2(_varying.x,_varying.y) +-- + vec2(sin(_uniform),- sin(_uniform)) +-- * vec2(_varying.y,_varying.x)) +-- / sin(vec2(_uniform,_uniform)) +-- ,vec2(1.0,1.0))).y + +-- TODO: rewrite cos(vec2(x,x)) to vec2(cos(x), cos(x)), i.e., +-- cos . uniformV to uniformV . cos (etc). + + +sm = sin m + +-- let a = sin(m) in +-- vec2((a * q.x + n * q.y) * l +-- ,(a * q.y + - n * q.x) * a) + +t4 = (sm * getX q - (- n * getY q)) * l <+> + (sm * getY q - ( n * getX q)) * sm + +-- I guess CSE interferes with vectorization. Unless I move lets out of +-- the way during general optimization. + +-- let a = sin(m) in +-- vec2(a * a,a * 3.0) +t5 = sm * sm <+> sm * 3 + +-- sin(vec2(m,m)) * vec2(2.0,3.0) +t6 = sm * 2 <+> sm * 3 + +-- let a = sin(m) in +-- vec2(2.0,a) * vec2(a,3.0) +t7 = 2 * sm <+> sm * 3 + +-- let a = sin(m) in +-- vec2(a,n) * vec2(l,a) +t8 = sm * l <+> n * sm + +-- let a = sin(m) in +-- vec2(a,2.0 + n) * vec2(l,a) +t9 = sm * l <+> (2 + n) * sm + +-- let a = sin(m) in +-- vec2(a,a) * vec2(l,a) +ta = sm * l <+> sm * sm + +-- sin m * sin m + +{- +(sin m * l) <+> (let a = sin m in a * a) + +liftE2 Cat (sin m * l) (let a = sin m in a * a) + + +liftE2 o a b = simple2 o a b @> op2 o a b + +liftE2 o (Lam r :^ s) b = Lam (liftE2 o r (down1 b)) ^: s + +liftE2 o (let x = s in r x) b == let x = s in liftE2 o (r x) b + + + + +op2 o a b = op1 o a @^ b + = Op o a :^ a @^ b + +-} + + +tb = q <* ((sm * 3) `fmod` n <+> 2) + +tc = getX tb ==* getY tb + +te = ifB tc 5 6 :: FloatE + + +sqr a = a * a + +ti = getX q + 1 +tj = getY q + 1 + +-- let a = q.x + 1.0 in a * a +tk = sqr ti +-- let a = q.y + 1.0 in a * a +tl = sqr tj + +-- let a = q.xy + vec2(1.0,1.0) in dot(a,a) +tn = tk + tl diff --git a/src/Shady/Vec.hs b/src/Shady/Vec.hs new file mode 100644 --- /dev/null +++ b/src/Shady/Vec.hs @@ -0,0 +1,440 @@ +{-# LANGUAGE TypeFamilies, EmptyDataDecls, TypeOperators + , GADTs, KindSignatures + , FlexibleInstances, FlexibleContexts + , UndecidableInstances + , ScopedTypeVariables, CPP + , RankNTypes + #-} +{-# OPTIONS_GHC -Wall -fno-warn-incomplete-patterns #-} +---------------------------------------------------------------------- +-- | +-- Module : Shady.Vec +-- Copyright : (c) Conal Elliott 2009 +-- License : AGPLv3 +-- +-- Maintainer : conal@conal.net +-- Stability : experimental +-- +-- Experiment in length-typed vectors +---------------------------------------------------------------------- + +module Shady.Vec + ( + -- * Type-level numbers + Z, S, (:+:), ZeroT, OneT, TwoT, ThreeT, FourT + -- * Typed natural numbers + , Nat(..), zero, one, two, three, four + , withIsNat, natSucc, natIsNat + , natToZ, natEq, natAdd, (:<:) + , Index(..), succI, index0, index1, index2, index3 + -- * Vectors + , Vec(..), IsNat(..), (<+>), indices + , Zero, One, Two, Three, Four, vElems + , vec1, vec2, vec3, vec4 + , un1, un2, un3, un4 + , get0, get1, get2, get3 + , get, swizzle + ) where + +import Prelude hiding (foldr,sum) + +-- #include "Typeable.h" + +import Control.Applicative (Applicative(..),liftA2,(<$>)) +import Data.Foldable (Foldable(..),sum) +import Data.Maybe (isJust) +-- import Data.Typeable + +import Foreign.Storable +import Foreign.Ptr (Ptr,plusPtr,castPtr) + +import Control.Compose (result) + +import Data.VectorSpace + + +import Shady.Misc (Sink) +import Data.Proof.EQ + + +{-------------------------------------------------------------------- + Type-level numbers +--------------------------------------------------------------------} + +-- | Type-level representation of zero +data Z +-- | Type-level representation of successor +data S n + +-- INSTANCE_TYPEABLE0(Z,zTC ,"Z") +-- INSTANCE_TYPEABLE1(S,sTC ,"S") + +infixl 6 :+: + +-- | Sum of type-level numbers +type family a :+: b + +type instance Z :+: b = b +type instance S a :+: b = S (a :+: b) + +type ZeroT = Z +type OneT = S ZeroT +type TwoT = S OneT +type ThreeT = S TwoT +type FourT = S ThreeT + + +{-------------------------------------------------------------------- + Typed natural numbers +--------------------------------------------------------------------} + +-- Natural numbers +data Nat :: * -> * where + Zero :: Nat Z + Succ :: IsNat n => Nat n -> Nat (S n) + +instance Show (Nat n) where show = show . natToZ + +withIsNat :: (IsNat n => Nat n -> a) -> (Nat n -> a) +withIsNat p Zero = p Zero +withIsNat p (Succ n) = p (Succ n) + +-- Helper for when we don't have a convenient proof of IsNat n. +natSucc :: Nat n -> Nat (S n) +natSucc = withIsNat Succ + +natIsNat :: Nat n -> (IsNat n => Nat n) +natIsNat Zero = Zero +natIsNat (Succ n) = Succ n + +{- + +-- Another approach (also works): + +data NatIsNat :: * -> * where + NatIsNat :: IsNat n' => Nat n' -> (n :=: n') -> NatIsNat n + +natIsNat' :: Nat n -> NatIsNat n +natIsNat' Zero = NatIsNat Zero Refl +natIsNat' (Succ n) = NatIsNat (Succ n) Refl + +withIsNat' :: (IsNat n => Nat n -> a) -> (Nat n -> a) +withIsNat' p n = case natIsNat' n of + NatIsNat n' Refl -> p n' +-} + +-- | Interpret a 'Nat' as an 'Integer' +natToZ :: Nat n -> Integer +natToZ Zero = 0 +natToZ (Succ n) = (succ . natToZ) n + +-- | Equality test +natEq :: Nat m -> Nat n -> Maybe (m :=: n) +Zero `natEq` Zero = Just Refl +Succ m `natEq` Succ n = liftEq <$> (m `natEq` n) +_ `natEq` _ = Nothing + +-- | Sum of naturals +natAdd :: Nat m -> Nat n -> Nat (m :+: n) +Zero `natAdd` n = n +Succ m `natAdd` n = natSucc (m `natAdd` n) + +zero :: Nat ZeroT +zero = Zero + +one :: Nat OneT +one = Succ zero + +two :: Nat TwoT +two = Succ one + +three :: Nat ThreeT +three = Succ two + +four :: Nat FourT +four = Succ three + + +infix 4 :<: + +-- | Proof that @m < n@ +data m :<: n where + ZLess :: Z :<: S n + SLess :: m :<: n -> S m :<: S n + +-- data Index :: * -> * where +-- Index :: (n :<: lim) -> Nat n -> Index lim + +-- or + +-- | A number under the given limit, with proof +data Index lim = forall n. IsNat n => Index (n :<: lim) (Nat n) + +instance Eq (Index lim) where + Index _ n == Index _ n' = isJust (n `natEq` n') + +succI :: Index m -> Index (S m) +succI (Index p m) = Index (SLess p) (Succ m) + +index0 :: Index (S n) +index0 = Index ZLess Zero + +index1 :: Index (S (S n)) +index1 = succI index0 + +index2 :: Index (S (S (S n))) +index2 = succI index1 + +index3 :: Index (S (S (S (S n)))) +index3 = succI index2 + + +{-------------------------------------------------------------------- + Vectors +--------------------------------------------------------------------} + +infixr 5 :< + +-- | Vectors with type-determined length, having empty vector ('ZVec') and +-- vector cons ('(:<)'). +data Vec :: * -> * -> * where + ZVec :: Vec Z a -- -- ^ zero vector + (:<) :: a -> Vec n a -> Vec (S n) a -- -- ^ vector cons + +-- TODO: when haddock is fixed, reinstate per-ctor haddock comments and +-- remove the constructor comments in the data doc. + +-- INSTANCE_TYPEABLE2(Vec,vecTC ,"Vec") + + +-- instance Show a => Show (Vec n a) where +-- show ZVec = "ZVec" +-- show (a :< v) = show a ++ " :< " ++ show v + +-- | Enumerate the elements of a vector. See also 'elemsV' +-- vElems :: Vec n a -> [a] +-- vElems ZVec = [] +-- vElems (a :< as) = a : vElems as + +-- TODO: Add strictness annotations ("!") to (:<) arguments & compare + +vElems :: Vec n a -> [a] +vElems = foldr (:) [] + +instance Functor (Vec n) where + fmap _ ZVec = ZVec + fmap f (a :< u) = f a :< fmap f u + + +-- | @n@ a vector length. +class {- Typeable n => -} IsNat n where + nat :: Nat n + pureV :: a -> Vec n a + elemsV :: [a] -> Vec n a + peekV :: Storable a => Ptr a -> IO (Vec n a) + pokeV :: Storable a => Ptr a -> Sink (Vec n a) + +{- +-- TODO: remove all but nat from the class. Define the rest outside of the +-- class by using nat. Then break this module into Nat and Vec. For instance, + +pureV :: IsNat n => a -> Vec n a +pureV = pureN nat + +pureN :: Nat n -> a -> Vec n a +pureN Zero _ = ZVec +pureN (Succ n) a = a :< pureN n a +-} + + +instance IsNat Z where + nat = Zero + pureV _ = ZVec + elemsV [] = ZVec + elemsV (_:_) = error "elemsV: too many elements" + peekV = const (return ZVec) + pokeV = const (const (return ())) + +instance IsNat n => IsNat (S n) where + nat = Succ nat + pureV a = a :< pureV a + elemsV [] = error "elemsV: too few elements" + elemsV (a : as) = a :< elemsV as + peekV p = do a <- peek p + as <- peekV (p `plusPtr` sizeOf a) + return (a :< as) + -- liftA2 (:<) (peek p) (peekV (succPtr p)) + -- peekV = (liftA2.liftA2) (:<) peek (peekV . succPtr) + -- TODO: Try these niftier peekV definitions + pokeV p (a :< as) = do poke p a + pokeV (p `plusPtr` sizeOf a) as + +-- -- Experiment toward simplifying away the plusPtr calls. +-- succPtr :: forall a. Storable a => Ptr a -> Ptr a +-- succPtr p = p `plusPtr` sizeOf (undefined :: a) + + +-- TODO: Optimize peekV, pokeV. For instance, unroll the loop in the +-- dictionary, remove the sizeOf dependence on @a@. + +applyV :: Vec n (a -> b) -> Vec n a -> Vec n b +ZVec `applyV` ZVec = ZVec +(f :< fs) `applyV` (x :< xs) = f x :< (fs `applyV` xs) + +instance IsNat n => Applicative (Vec n) where + pure = pureV + (<*>) = applyV + +-- Without -fno-warn-incomplete-patterns above, +-- the previous two instances lead to warnings about non-exhaustive +-- pattern matches, although the other possibilities +-- are type-incorrect. According to SLPJ: +-- +-- The overlap warning checker simply doesn't take account of GADTs. +-- There's a long-standing project suggestion to fix this: +-- http://hackage.haskell.org/trac/ghc/wiki/ProjectSuggestions . +-- Perhaps a good GSoc project. + +instance Foldable (Vec n) where + foldr _ b ZVec = b + foldr h b (a :< as) = a `h` foldr h b as + + +infixl 1 <+> +-- | Concatenation of vectors +(<+>) :: Vec m a -> Vec n a -> Vec (m :+: n) a +ZVec <+> v = v +(a :< u) <+> v = a :< (u <+> v) + +-- | Indices under @n@: 'index0' :< 'index1' :< ... +indices :: Nat n -> Vec n (Index n) +indices Zero = ZVec +indices (Succ n) = index0 :< fmap succI (indices n) + +-- TODO: Try reimplementing many Vec functions via foldr. Warning: some +-- (most?) will fail because they rely on a polymorphic combining function. + +-- Convenient nicknames + +type Zero = Vec ZeroT +type One = Vec OneT +type Two = Vec TwoT +type Three = Vec ThreeT +type Four = Vec FourT + + +vec1 :: a -> One a +vec1 a = a :< ZVec + +vec2 :: a -> a -> Two a +vec2 a b = a :< vec1 b + +vec3 :: a -> a -> a -> Three a +vec3 a b c = a :< vec2 b c + +vec4 :: a -> a -> a -> a -> Four a +vec4 a b c d = a :< vec3 b c d + +-- | Extract element +un1 :: One a -> a +un1 (a :< ZVec) = a + +-- | Extract elements +un2 :: Two a -> (a,a) +un2 (a :< b :< ZVec) = (a,b) + +-- | Extract elements +un3 :: Three a -> (a,a,a) +un3 (a :< b :< c :< ZVec) = (a,b,c) + +-- | Extract elements +un4 :: Four a -> (a,a,a,a) +un4 (a :< b :< c :< d :< ZVec) = (a,b,c,d) + + +{-------------------------------------------------------------------- + Vector space instances +--------------------------------------------------------------------} + +instance (IsNat n, Num a) => AdditiveGroup (Vec n a) where + { zeroV = pure 0; (^+^) = liftA2 (+) ; negateV = fmap negate } + +instance (IsNat n, Num a) => VectorSpace (Vec n a) where + type Scalar (Vec n a) = One a -- note 'One' + (*^) (s :< ZVec) = fmap (s *) + +instance (IsNat n, Num a) => InnerSpace (Vec n a) where + -- u <.> v = vec1 (sum (liftA2 (*) u v)) + (<.>) = (result.result) (vec1 . sum) (liftA2 (*)) + + +{-------------------------------------------------------------------- + Extract elements +--------------------------------------------------------------------} + +-- | General indexing, taking a proof that the index is within bounds. +get :: Index n -> Vec n a -> One a +get (Index ZLess Zero ) (a :< _) = vec1 a +get (Index (SLess p) (Succ m)) (_ :< as) = get (Index p m) as + + +get0 :: Vec (S n) a -> One a +get1 :: Vec (S (S n)) a -> One a +get2 :: Vec (S (S (S n))) a -> One a +get3 :: Vec (S (S (S (S n)))) a -> One a + +get0 = get index0 +get1 = get index1 +get2 = get index2 +get3 = get index3 + + +-- | Swizzling. Extract multiple elements simultaneously. +swizzle :: Vec n (Index m) -> Vec m a -> Vec n a +swizzle ZVec _ = ZVec +swizzle (ix :< ixs) v = un1 (get ix v) :< swizzle ixs v + +{- +-- 'a' :< 'b' :< 'c' :< ZVec +t1 :: Three Char +t1 = elemsV "abc" + -- 'a' :< 'b' :< 'c' :< ZVec + +t2 :: Four (Index ThreeT) +t2 = elemsV [index2, index0 ,index1, index2] + +-- 'c' :< 'a' :< 'b' :< 'c' :< ZVec +t3 :: Four Char +t3 = swizzle t2 t1 +-} + + + +{-------------------------------------------------------------------- + Some instances. More in Type.hs +--------------------------------------------------------------------} + +instance Eq a => Eq (Vec n a) where + ZVec == ZVec = True + a :< as == b :< bs = a==b && as==bs + +instance Ord a => Ord (Vec n a) where + ZVec `compare` ZVec = EQ + (a :< as) `compare` (b :< bs) = + case a `compare` b of + LT -> LT + GT -> GT + EQ -> as `compare` bs + + +{-------------------------------------------------------------------- + Storage +--------------------------------------------------------------------} + +instance (IsNat n, Storable a) => Storable (Vec n a) where + sizeOf = const (fromIntegral (natToZ (nat :: Nat n)) + * sizeOf (undefined :: a)) + alignment = const (alignment (undefined :: a)) + peek = peekV . castPtr + poke = pokeV . castPtr + diff --git a/src/Text/PrettyPrint/Leijen/DocExpr.hs b/src/Text/PrettyPrint/Leijen/DocExpr.hs new file mode 100644 --- /dev/null +++ b/src/Text/PrettyPrint/Leijen/DocExpr.hs @@ -0,0 +1,268 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} +---------------------------------------------------------------------- +-- | +-- Module : Text.PrettyPrint.Leijen.DocExpr +-- Copyright : (c) Conal Elliott 2009 +-- License : BSD +-- +-- Maintainer : conal@conal.net +-- Stability : experimental +-- +-- Variation of Twan van Laarhoven's simple-reflect +-- +-- +-- Differences from Twan's version: +-- + Generates pretty-printings instead of strings +-- + No evaluation +-- + Removed overloadings that disagree with semantic versions (e.g., '(==)') +-- + A few stylistic tweaks +---------------------------------------------------------------------- + +module Text.PrettyPrint.Leijen.DocExpr + ( -- * Construction + Expr(..) + , FromExpr(..) + , lift, var, fun, apply, ($$), Associativity(..), op + , lambdaX, letX, tupleX, ccall, dotX, onDoc + , HasExpr(..), HasExprU(..) + , prettyExpr + -- * Utility + , docParen + ) where + +import Data.Ratio (Ratio) + +import Text.PrettyPrint.Leijen +import Text.PrettyPrint.Leijen.PrettyPrec + + +------------------------------------------------------------------------------ +-- Data type +------------------------------------------------------------------------------ + +-- | A reflected expression +data Expr = Expr + { edoc :: Int -> Doc -- ^ Generate doc, given contextual precedence level + } + +instance Pretty Expr where pretty = prettyPrec 0 +instance PrettyPrec Expr where prettyPrec = flip edoc +instance Show Expr where showsPrec = showsPretty + + +------------------------------------------------------------------------------ +-- Lifting and combining expressions +------------------------------------------------------------------------------ + +-- | A variable with the given name +var :: String -> Expr +-- var s = Expr (const (text s)) +var = lift + +lift :: PrettyPrec a => a -> Expr +lift x = Expr (\ p -> prettyPrec p x) + +-- | This data type specifies the associativity of operators: left, right or none. +data Associativity = InfixL | Infix | InfixR deriving Eq + +-- | Generalization of 'op', taking a flag saying whether to insert spaces +-- around operator. +op' :: Bool -> Associativity -> Int -> String -> Expr -> Expr -> Expr +op' spaces fix prec name a b = + withPrec prec $ + align (bump InfixL a `pre` text name `post` bump InfixR b) + where + bump fix' c = edoc c (if fix == fix' then prec else prec + 1) + pre | spaces = (<+>) + | otherwise = (<>) + post | spaces && not (null name) = () + | otherwise = (<>) + +-- | An infix operator with the given associativity, precedence and name +op :: Associativity -> Int -> String -> Expr -> Expr -> Expr +op = op' True + +-- | Variant of showParen +docParen :: Bool -> Doc -> Doc +docParen True = parens +docParen False = id + +withPrec :: Int -> Doc -> Expr +withPrec n b = Expr $ \ p -> docParen (p > n) b + +-- | A lambda expression +lambdaX :: String -> Expr -> Expr + +lambdaX x body = withPrec 0 $ + char '\\' <+> text x <+> text "->" <+> pretty body + +-- | A \"let\" expression +letX :: String -> Expr -> Expr -> Expr +letX x rhs body = withPrec 0 $ hang 2 $ + text "let" <+> text x <+> equals <+> pretty rhs + <+> text "in " <$$> pretty body + +-- | A tuple expression +tupleX :: [Expr] -> Expr +tupleX = Expr . const . tupled . map (flip edoc 0) + +-- | C-style call +ccall :: String -> [Expr] -> Expr +ccall f args = withPrec 9 $ text f <> edoc (tupleX args) 0 + +-- | e.foo +dotX :: String -> Expr -> Expr +dotX str e = op' False InfixR 10 "." e (var str) + +-- dotX str (Expr d) = withPrec 10 $ d <> char '.' <> text str) + +-- | Altering the generated Doc +onDoc :: (Doc -> Doc) -> (Expr -> Expr) +onDoc f (Expr ed) = Expr (f . ed) + +------------------------------------------------------------------------------ +-- Function types +------------------------------------------------------------------------------ + +-- | Conversion from 'Expr' to other types +class FromExpr a where + fromExpr :: Expr -> a + +instance FromExpr Expr where + fromExpr = id + +instance (PrettyPrec a, FromExpr b) => FromExpr (a -> b) where + fromExpr f a = fromExpr (f $$ lift a) + +-- | A generic, overloaded, function variable +fun :: FromExpr a => String -> a +fun = fromExpr . var + + +infixr 0 $$ + +-- | Function application +apply, ($$) :: Expr -> Expr -> Expr +apply = op InfixL 10 "" + +($$) = apply + +------------------------------------------------------------------------------ +-- Numeric classes +------------------------------------------------------------------------------ + +-- The types of some methods prevent them from being lifted to Expr +noOv :: String -> a +noOv meth = error $ meth ++ ": No overloading for Expr" + +instance Eq Expr where + -- (==) = (==) `on` show + (==) = noOv "(==)" + +instance Ord Expr where + -- compare = compare `on` show + compare = noOv "compare" + min = fun "min" + max = fun "max" + +instance Num Expr where + fromInteger = lift + (+) = op InfixL 6 "+" + (-) = op InfixL 6 "-" + (*) = op InfixL 7 "*" + negate = fun "negate" + abs = fun "abs" + signum = fun "signum" + +instance Real Expr where + toRational = noOv "toRational" + +instance Integral Expr where + toInteger = noOv "toInteger" + quotRem a b = (quot a b, rem a b) + divMod a b = (div a b, mod a b) + quot = op InfixL 7 "`quot`" + rem = op InfixL 7 "`rem`" + div = op InfixL 7 "`div`" + mod = op InfixL 7 "`mod`" + +instance Fractional Expr where + (/) = op InfixL 7 "/" + recip = fun "recip" + fromRational = lift + +instance Floating Expr where + pi = var "pi" + exp = fun "exp" + sqrt = fun "sqrt" + log = fun "log" + (**) = op InfixR 8 "**" + sin = fun "sin" + cos = fun "cos" + sinh = fun "sinh" + cosh = fun "cosh" + asin = fun "asin" + acos = fun "acos" + atan = fun "atan" + asinh = fun "asinh" + acosh = fun "acosh" + atanh = fun "atanh" + +instance Enum Expr where + succ = fun "succ" + pred = fun "pred" + toEnum = fun "toEnum" + fromEnum = noOv "fromEnum" + enumFrom = noOv "enumFrom" + enumFromThen = noOv "enumFromThen" + enumFromTo = noOv "enumFromTo" + enumFromThenTo = noOv "enumFromThenTo" + + + +{-------------------------------------------------------------------- + HasExpr Class: conversion to Expr +--------------------------------------------------------------------} + +-- TODO: sync up names FromExpr and HasExpr + +-- Value that can be converted to an 'Expr'. The 'Show' parent is for +-- convenience. It lets us use a default for 'expr'. +class Show a => HasExpr a where + expr :: a -> Expr + expr = var . show + +-- Grab instances from PrettyPrec: + +instance HasExpr Expr where expr = id + +instance HasExpr Doc where expr = lift +instance HasExpr () where expr = lift +instance HasExpr Bool where expr = lift +instance HasExpr Char where expr = lift +instance HasExpr Int where expr = lift +instance HasExpr Integer where expr = lift +instance HasExpr Float where expr = lift +instance HasExpr Double where expr = lift + +instance (Show a, PrettyPrec a) => HasExpr [a] + where expr = lift +instance (Show a, Show b, Pretty a,Pretty b) => HasExpr (a,b) where + expr = lift +instance (Show a,Show b,Show c,Pretty a,Pretty b,Pretty c) => HasExpr (a,b,c) where + expr = lift +instance (Show a, PrettyPrec a) => HasExpr (Maybe a) where expr = lift +instance Integral a => HasExpr (Ratio a) where expr = lift + + +-- Like 'HasExpr', but for type constructors. +class HasExprU h where + exprU :: forall a. {-HasExpr a => -} h a -> Expr + +-- instance HasExpr a => PrettyPrec (V a) where +-- prettyPrec p v = edoc (expr v) p + +-- | Convenient for defining 'PrettyPrec' when we have a 'HasExpr'. +prettyExpr :: HasExpr a => Int -> a -> Doc +prettyExpr p x = edoc (expr x) p diff --git a/src/Text/PrettyPrint/Leijen/PrettyPrec.hs b/src/Text/PrettyPrint/Leijen/PrettyPrec.hs new file mode 100644 --- /dev/null +++ b/src/Text/PrettyPrint/Leijen/PrettyPrec.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} +---------------------------------------------------------------------- +-- | +-- Module : Text.PrettyPrint.Leijen.PrettyPrec +-- Copyright : (c) Conal Elliott 2009 +-- License : BSD +-- +-- Maintainer : conal@conal.net +-- Stability : experimental +-- +-- Pretty class with precedence +---------------------------------------------------------------------- + +module Text.PrettyPrint.Leijen.PrettyPrec + ( PrettyPrec(..) + -- * 'Show' helpers + , showsPretty, showsPretty' + , showsPrettyPrec, showsPrettyPrec' + ) where + +#if __GLASGOW_HASKELL__ < 612 +import Data.Maybe (maybe) +#endif +import Data.Ratio (Ratio) + +import Text.PrettyPrint.Leijen + +-- | Pretty printing with precedence. A cross between 'Show' and 'Pretty'. +-- The 'prettyPrec' method defaults to discarding the context precedence +-- and invoking 'pretty'. The reason 'PrettyPrec' derives from Pretty is +-- that so that this default is possible. +-- +-- To make a 'Show' instance for a 'PrettyPrec' instance 'Foo', define +-- +-- instance Show Foo where showsPrec p e = showsPrec p (prettyPrec p e) + +class Pretty a => PrettyPrec a where + prettyPrec :: Int -> a -> Doc + prettyPrec = const pretty -- default + +-- Will we need prettyListPrec? +-- +-- prettyList :: [a] -> Doc +-- prettyList = list . map pretty + + +instance PrettyPrec Doc +instance PrettyPrec () +instance PrettyPrec Bool +instance PrettyPrec Char +instance PrettyPrec Int +instance PrettyPrec Integer +instance PrettyPrec Float +instance PrettyPrec Double + +-- Orphan: +instance Integral a => Pretty (Ratio a) where pretty = text . show + +instance Pretty a => PrettyPrec [a] + +instance (Pretty a,Pretty b) => PrettyPrec (a,b) + +instance (Pretty a,Pretty b,Pretty c) => PrettyPrec (a,b,c) + +instance PrettyPrec a => PrettyPrec (Maybe a) where + prettyPrec p = maybe empty (prettyPrec p) + +instance Integral a => PrettyPrec (Ratio a) where + prettyPrec = const (text . show) + + +{-------------------------------------------------------------------- + 'Show' helpers +--------------------------------------------------------------------} + +pageWidth :: Int +pageWidth = 80 + +-- | Convenient definition for 'showsPrec' in a 'Show' instance. Uses +-- ribbon fraction of 0.9 and width of 80. To set these values, use +-- 'showsPrettyPrec'' instead. See also 'showsPretty'. +showsPrettyPrec :: PrettyPrec a => Int -> a -> ShowS +showsPrettyPrec = showsPrettyPrec' 0.9 pageWidth + +-- | Convenient definition for 'showsPrec' in a 'Show' instance. +-- Arguments are ribbon fraction and line width. To get my defaults, use +-- 'showsPrettyPretty' instead. +showsPrettyPrec' :: PrettyPrec a => Float -> Int -> Int -> a -> ShowS +showsPrettyPrec' rfrac w p = showsG (prettyPrec p) rfrac w + +-- | Convenient definition for 'showsPrec' in a 'Show' instance. Uses +-- ribbon fraction of 0.9 and width of 80. To set these values, use +-- 'showsPretty'' instead. If you want to take precedence into account, +-- use 'showsPrettyPrec' instead. +showsPretty :: Pretty a => Int -> a -> ShowS +showsPretty = showsPretty' 0.9 pageWidth + +-- | Convenient definition for 'showsPrec' in a 'Show' instance. +-- Arguments are ribbon fraction and line width. To get my defaults, use +-- 'showsPretty' instead. Ignores precedence, which 'Pretty' doesn't +-- understand. If you have a 'PrettyPrec' instance, you can use +-- 'showsPrettyPrec' instead. +showsPretty' :: Pretty a => Float -> Int -> Int -> a -> ShowS +showsPretty' rfrac w _ = showsG pretty rfrac w + +-- General 'Doc'-friendly helper for 'showsPrec' definitions. +showsG :: (a -> Doc) -> Float -> Int -> a -> ShowS +showsG toDoc rfrac w a = displayS (renderPretty rfrac w (toDoc a))