diff --git a/Changes.md b/Changes.md new file mode 100644 --- /dev/null +++ b/Changes.md @@ -0,0 +1,38 @@ +# Change log for the `synthesizer-llvm` package + +## 1.0 + +* Move from `llvm-dsl` `Parameter` to `Exp` for parameters. + Remove clumsy distinction between simple and parameterized + `Signal`s and `Process`es. + +## 0.9 + +* Clean separation between Haskell's `Storable` memory format + as used in `StorableVector` + and LLVM's memory format, used for parameters. + +* Use of new `llvm-dsl` package. + +## 0.8.3 + +* `Noise`: caused a crash with LLVM-9 + because it called the X86 intrinsic `pmuludq`. + Now use generic multiplication. + +## 0.8.0 + +* Compiled code is now freed by the garbage collector if it is no longer needed. + +* `reverbSimple`: No longer add the original signal. + Every partial comb filter maintains it anyway. + +* In `CausalParameterized.Process`: + `reverb` -> `reverbSimple` + `reverbEfficient` -> `reverb` + +* added many export lists + +* For GHC-7.10 we had to separate `ProcessOf` type functions + from `synthesizer-core:CausalClass`. + We adapt to this change here. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,674 @@ + GNU GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The GNU General Public License is a free, copyleft license for +software and other kinds of works. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +the GNU General Public License is intended to guarantee your freedom to +share and change all versions of a program--to make sure it remains free +software for all its users. We, the Free Software Foundation, use the +GNU General Public License for most of our software; it applies also to +any other work released this way by its authors. You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +them if you wish), that you receive source code or can get it if you +want it, that you can change the software or use pieces of it in new +free programs, and that you know you can do these things. + + To protect your rights, we need to prevent others from denying you +these rights or asking you to surrender the rights. Therefore, you have +certain responsibilities if you distribute copies of the software, or if +you modify it: responsibilities to respect the freedom of others. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must pass on to the recipients the same +freedoms that you received. You must make sure that they, too, receive +or can get the source code. And you must show them these terms so they +know their rights. + + Developers that use the GNU GPL protect your rights with two steps: +(1) assert copyright on the software, and (2) offer you this License +giving you legal permission to copy, distribute and/or modify it. + + For the developers' and authors' protection, the GPL clearly explains +that there is no warranty for this free software. For both users' and +authors' sake, the GPL requires that modified versions be marked as +changed, so that their problems will not be attributed erroneously to +authors of previous versions. + + Some devices are designed to deny users access to install or run +modified versions of the software inside them, although the manufacturer +can do so. This is fundamentally incompatible with the aim of +protecting users' freedom to change the software. The systematic +pattern of such abuse occurs in the area of products for individuals to +use, which is precisely where it is most unacceptable. Therefore, we +have designed this version of the GPL to prohibit the practice for those +products. If such problems arise substantially in other domains, we +stand ready to extend this provision to those domains in future versions +of the GPL, as needed to protect the freedom of users. + + Finally, every program is threatened constantly by software patents. +States should not allow patents to restrict development and use of +software on general-purpose computers, but in those that do, we wish to +avoid the special danger that patents applied to a free program could +make it effectively proprietary. To prevent this, the GPL assures that +patents cannot be used to render the program non-free. + + The precise terms and conditions for copying, distribution and +modification follow. + + TERMS AND CONDITIONS + + 0. Definitions. + + "This License" refers to version 3 of the GNU General Public License. + + "Copyright" also means copyright-like laws that apply to other kinds of +works, such as semiconductor masks. + + "The Program" refers to any copyrightable work licensed under this +License. Each licensee is addressed as "you". "Licensees" and +"recipients" may be individuals or organizations. + + To "modify" a work means to copy from or adapt all or part of the work +in a fashion requiring copyright permission, other than the making of an +exact copy. The resulting work is called a "modified version" of the +earlier work or a work "based on" the earlier work. + + A "covered work" means either the unmodified Program or a work based +on the Program. + + To "propagate" a work means to do anything with it that, without +permission, would make you directly or secondarily liable for +infringement under applicable copyright law, except executing it on a +computer or modifying a private copy. Propagation includes copying, +distribution (with or without modification), making available to the +public, and in some countries other activities as well. + + To "convey" a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user through +a computer network, with no transfer of a copy, is not conveying. + + An interactive user interface displays "Appropriate Legal Notices" +to the extent that it includes a convenient and prominently visible +feature that (1) displays an appropriate copyright notice, and (2) +tells the user that there is no warranty for the work (except to the +extent that warranties are provided), that licensees may convey the +work under this License, and how to view a copy of this License. If +the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + + 1. Source Code. + + The "source code" for a work means the preferred form of the work +for making modifications to it. "Object code" means any non-source +form of a work. + + A "Standard Interface" means an interface that either is an official +standard defined by a recognized standards body, or, in the case of +interfaces specified for a particular programming language, one that +is widely used among developers working in that language. + + The "System Libraries" of an executable work include anything, other +than the work as a whole, that (a) is included in the normal form of +packaging a Major Component, but which is not part of that Major +Component, and (b) serves only to enable use of the work with that +Major Component, or to implement a Standard Interface for which an +implementation is available to the public in source code form. A +"Major Component", in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system +(if any) on which the executable work runs, or a compiler used to +produce the work, or an object code interpreter used to run it. + + The "Corresponding Source" for a work in object code form means all +the source code needed to generate, install, and (for an executable +work) run the object code and to modify the work, including scripts to +control those activities. However, it does not include the work's +System Libraries, or general-purpose tools or generally available free +programs which are used unmodified in performing those activities but +which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for +the work, and the source code for shared libraries and dynamically +linked subprograms that the work is specifically designed to require, +such as by intimate data communication or control flow between those +subprograms and other parts of the work. + + The Corresponding Source need not include anything that users +can regenerate automatically from other parts of the Corresponding +Source. + + The Corresponding Source for a work in source code form is that +same work. + + 2. Basic Permissions. + + All rights granted under this License are granted for the term of +copyright on the Program, and are irrevocable provided the stated +conditions are met. This License explicitly affirms your unlimited +permission to run the unmodified Program. The output from running a +covered work is covered by this License only if the output, given its +content, constitutes a covered work. This License acknowledges your +rights of fair use or other equivalent, as provided by copyright law. + + You may make, run and propagate covered works that you do not +convey, without conditions so long as your license otherwise remains +in force. You may convey covered works to others for the sole purpose +of having them make modifications exclusively for you, or provide you +with facilities for running those works, provided that you comply with +the terms of this License in conveying all material for which you do +not control copyright. Those thus making or running the covered works +for you must do so exclusively on your behalf, under your direction +and control, on terms that prohibit them from making any copies of +your copyrighted material outside their relationship with you. + + Conveying under any other circumstances is permitted solely under +the conditions stated below. Sublicensing is not allowed; section 10 +makes it unnecessary. + + 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + + No covered work shall be deemed part of an effective technological +measure under any applicable law fulfilling obligations under article +11 of the WIPO copyright treaty adopted on 20 December 1996, or +similar laws prohibiting or restricting circumvention of such +measures. + + When you convey a covered work, you waive any legal power to forbid +circumvention of technological measures to the extent such circumvention +is effected by exercising rights under this License with respect to +the covered work, and you disclaim any intention to limit operation or +modification of the work as a means of enforcing, against the work's +users, your or third parties' legal rights to forbid circumvention of +technological measures. + + 4. Conveying Verbatim Copies. + + You may convey verbatim copies of the Program's source code as you +receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice; +keep intact all notices stating that this License and any +non-permissive terms added in accord with section 7 apply to the code; +keep intact all notices of the absence of any warranty; and give all +recipients a copy of this License along with the Program. + + You may charge any price or no price for each copy that you convey, +and you may offer support or warranty protection for a fee. + + 5. Conveying Modified Source Versions. + + You may convey a work based on the Program, or the modifications to +produce it from the Program, in the form of source code under the +terms of section 4, provided that you also meet all of these conditions: + + a) The work must carry prominent notices stating that you modified + it, and giving a relevant date. + + b) The work must carry prominent notices stating that it is + released under this License and any conditions added under section + 7. This requirement modifies the requirement in section 4 to + "keep intact all notices". + + c) You must license the entire work, as a whole, under this + License to anyone who comes into possession of a copy. This + License will therefore apply, along with any applicable section 7 + additional terms, to the whole of the work, and all its parts, + regardless of how they are packaged. This License gives no + permission to license the work in any other way, but it does not + invalidate such permission if you have separately received it. + + d) If the work has interactive user interfaces, each must display + Appropriate Legal Notices; however, if the Program has interactive + interfaces that do not display Appropriate Legal Notices, your + work need not make them do so. + + A compilation of a covered work with other separate and independent +works, which are not by their nature extensions of the covered work, +and which are not combined with it such as to form a larger program, +in or on a volume of a storage or distribution medium, is called an +"aggregate" if the compilation and its resulting copyright are not +used to limit the access or legal rights of the compilation's users +beyond what the individual works permit. Inclusion of a covered work +in an aggregate does not cause this License to apply to the other +parts of the aggregate. + + 6. Conveying Non-Source Forms. + + You may convey a covered work in object code form under the terms +of sections 4 and 5, provided that you also convey the +machine-readable Corresponding Source under the terms of this License, +in one of these ways: + + a) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by the + Corresponding Source fixed on a durable physical medium + customarily used for software interchange. + + b) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by a + written offer, valid for at least three years and valid for as + long as you offer spare parts or customer support for that product + model, to give anyone who possesses the object code either (1) a + copy of the Corresponding Source for all the software in the + product that is covered by this License, on a durable physical + medium customarily used for software interchange, for a price no + more than your reasonable cost of physically performing this + conveying of source, or (2) access to copy the + Corresponding Source from a network server at no charge. + + c) Convey individual copies of the object code with a copy of the + written offer to provide the Corresponding Source. This + alternative is allowed only occasionally and noncommercially, and + only if you received the object code with such an offer, in accord + with subsection 6b. + + d) Convey the object code by offering access from a designated + place (gratis or for a charge), and offer equivalent access to the + Corresponding Source in the same way through the same place at no + further charge. You need not require recipients to copy the + Corresponding Source along with the object code. If the place to + copy the object code is a network server, the Corresponding Source + may be on a different server (operated by you or a third party) + that supports equivalent copying facilities, provided you maintain + clear directions next to the object code saying where to find the + Corresponding Source. Regardless of what server hosts the + Corresponding Source, you remain obligated to ensure that it is + available for as long as needed to satisfy these requirements. + + e) Convey the object code using peer-to-peer transmission, provided + you inform other peers where the object code and Corresponding + Source of the work are being offered to the general public at no + charge under subsection 6d. + + A separable portion of the object code, whose source code is excluded +from the Corresponding Source as a System Library, need not be +included in conveying the object code work. + + A "User Product" is either (1) a "consumer product", which means any +tangible personal property which is normally used for personal, family, +or household purposes, or (2) anything designed or sold for incorporation +into a dwelling. In determining whether a product is a consumer product, +doubtful cases shall be resolved in favor of coverage. For a particular +product received by a particular user, "normally used" refers to a +typical or common use of that class of product, regardless of the status +of the particular user or of the way in which the particular user +actually uses, or expects or is expected to use, the product. A product +is a consumer product regardless of whether the product has substantial +commercial, industrial or non-consumer uses, unless such uses represent +the only significant mode of use of the product. + + "Installation Information" for a User Product means any methods, +procedures, authorization keys, or other information required to install +and execute modified versions of a covered work in that User Product from +a modified version of its Corresponding Source. The information must +suffice to ensure that the continued functioning of the modified object +code is in no case prevented or interfered with solely because +modification has been made. + + If you convey an object code work under this section in, or with, or +specifically for use in, a User Product, and the conveying occurs as +part of a transaction in which the right of possession and use of the +User Product is transferred to the recipient in perpetuity or for a +fixed term (regardless of how the transaction is characterized), the +Corresponding Source conveyed under this section must be accompanied +by the Installation Information. But this requirement does not apply +if neither you nor any third party retains the ability to install +modified object code on the User Product (for example, the work has +been installed in ROM). + + The requirement to provide Installation Information does not include a +requirement to continue to provide support service, warranty, or updates +for a work that has been modified or installed by the recipient, or for +the User Product in which it has been modified or installed. Access to a +network may be denied when the modification itself materially and +adversely affects the operation of the network or violates the rules and +protocols for communication across the network. + + Corresponding Source conveyed, and Installation Information provided, +in accord with this section must be in a format that is publicly +documented (and with an implementation available to the public in +source code form), and must require no special password or key for +unpacking, reading or copying. + + 7. Additional Terms. + + "Additional permissions" are terms that supplement the terms of this +License by making exceptions from one or more of its conditions. +Additional permissions that are applicable to the entire Program shall +be treated as though they were included in this License, to the extent +that they are valid under applicable law. If additional permissions +apply only to part of the Program, that part may be used separately +under those permissions, but the entire Program remains governed by +this License without regard to the additional permissions. + + When you convey a copy of a covered work, you may at your option +remove any additional permissions from that copy, or from any part of +it. (Additional permissions may be written to require their own +removal in certain cases when you modify the work.) You may place +additional permissions on material, added by you to a covered work, +for which you have or can give appropriate copyright permission. + + Notwithstanding any other provision of this License, for material you +add to a covered work, you may (if authorized by the copyright holders of +that material) supplement the terms of this License with terms: + + a) Disclaiming warranty or limiting liability differently from the + terms of sections 15 and 16 of this License; or + + b) Requiring preservation of specified reasonable legal notices or + author attributions in that material or in the Appropriate Legal + Notices displayed by works containing it; or + + c) Prohibiting misrepresentation of the origin of that material, or + requiring that modified versions of such material be marked in + reasonable ways as different from the original version; or + + d) Limiting the use for publicity purposes of names of licensors or + authors of the material; or + + e) Declining to grant rights under trademark law for use of some + trade names, trademarks, or service marks; or + + f) Requiring indemnification of licensors and authors of that + material by anyone who conveys the material (or modified versions of + it) with contractual assumptions of liability to the recipient, for + any liability that these contractual assumptions directly impose on + those licensors and authors. + + All other non-permissive additional terms are considered "further +restrictions" within the meaning of section 10. If the Program as you +received it, or any part of it, contains a notice stating that it is +governed by this License along with a term that is a further +restriction, you may remove that term. If a license document contains +a further restriction but permits relicensing or conveying under this +License, you may add to a covered work material governed by the terms +of that license document, provided that the further restriction does +not survive such relicensing or conveying. + + If you add terms to a covered work in accord with this section, you +must place, in the relevant source files, a statement of the +additional terms that apply to those files, or a notice indicating +where to find the applicable terms. + + Additional terms, permissive or non-permissive, may be stated in the +form of a separately written license, or stated as exceptions; +the above requirements apply either way. + + 8. Termination. + + You may not propagate or modify a covered work except as expressly +provided under this License. Any attempt otherwise to propagate or +modify it is void, and will automatically terminate your rights under +this License (including any patent licenses granted under the third +paragraph of section 11). + + However, if you cease all violation of this License, then your +license from a particular copyright holder is reinstated (a) +provisionally, unless and until the copyright holder explicitly and +finally terminates your license, and (b) permanently, if the copyright +holder fails to notify you of the violation by some reasonable means +prior to 60 days after the cessation. + + Moreover, your license from a particular copyright holder is +reinstated permanently if the copyright holder notifies you of the +violation by some reasonable means, this is the first time you have +received notice of violation of this License (for any work) from that +copyright holder, and you cure the violation prior to 30 days after +your receipt of the notice. + + Termination of your rights under this section does not terminate the +licenses of parties who have received copies or rights from you under +this License. If your rights have been terminated and not permanently +reinstated, you do not qualify to receive new licenses for the same +material under section 10. + + 9. Acceptance Not Required for Having Copies. + + You are not required to accept this License in order to receive or +run a copy of the Program. Ancillary propagation of a covered work +occurring solely as a consequence of using peer-to-peer transmission +to receive a copy likewise does not require acceptance. However, +nothing other than this License grants you permission to propagate or +modify any covered work. These actions infringe copyright if you do +not accept this License. Therefore, by modifying or propagating a +covered work, you indicate your acceptance of this License to do so. + + 10. Automatic Licensing of Downstream Recipients. + + Each time you convey a covered work, the recipient automatically +receives a license from the original licensors, to run, modify and +propagate that work, subject to this License. You are not responsible +for enforcing compliance by third parties with this License. + + An "entity transaction" is a transaction transferring control of an +organization, or substantially all assets of one, or subdividing an +organization, or merging organizations. If propagation of a covered +work results from an entity transaction, each party to that +transaction who receives a copy of the work also receives whatever +licenses to the work the party's predecessor in interest had or could +give under the previous paragraph, plus a right to possession of the +Corresponding Source of the work from the predecessor in interest, if +the predecessor has it or can get it with reasonable efforts. + + You may not impose any further restrictions on the exercise of the +rights granted or affirmed under this License. For example, you may +not impose a license fee, royalty, or other charge for exercise of +rights granted under this License, and you may not initiate litigation +(including a cross-claim or counterclaim in a lawsuit) alleging that +any patent claim is infringed by making, using, selling, offering for +sale, or importing the Program or any portion of it. + + 11. Patents. + + A "contributor" is a copyright holder who authorizes use under this +License of the Program or a work on which the Program is based. The +work thus licensed is called the contributor's "contributor version". + + A contributor's "essential patent claims" are all patent claims +owned or controlled by the contributor, whether already acquired or +hereafter acquired, that would be infringed by some manner, permitted +by this License, of making, using, or selling its contributor version, +but do not include claims that would be infringed only as a +consequence of further modification of the contributor version. For +purposes of this definition, "control" includes the right to grant +patent sublicenses in a manner consistent with the requirements of +this License. + + Each contributor grants you a non-exclusive, worldwide, royalty-free +patent license under the contributor's essential patent claims, to +make, use, sell, offer for sale, import and otherwise run, modify and +propagate the contents of its contributor version. + + In the following three paragraphs, a "patent license" is any express +agreement or commitment, however denominated, not to enforce a patent +(such as an express permission to practice a patent or covenant not to +sue for patent infringement). To "grant" such a patent license to a +party means to make such an agreement or commitment not to enforce a +patent against the party. + + If you convey a covered work, knowingly relying on a patent license, +and the Corresponding Source of the work is not available for anyone +to copy, free of charge and under the terms of this License, through a +publicly available network server or other readily accessible means, +then you must either (1) cause the Corresponding Source to be so +available, or (2) arrange to deprive yourself of the benefit of the +patent license for this particular work, or (3) arrange, in a manner +consistent with the requirements of this License, to extend the patent +license to downstream recipients. "Knowingly relying" means you have +actual knowledge that, but for the patent license, your conveying the +covered work in a country, or your recipient's use of the covered work +in a country, would infringe one or more identifiable patents in that +country that you have reason to believe are valid. + + If, pursuant to or in connection with a single transaction or +arrangement, you convey, or propagate by procuring conveyance of, a +covered work, and grant a patent license to some of the parties +receiving the covered work authorizing them to use, propagate, modify +or convey a specific copy of the covered work, then the patent license +you grant is automatically extended to all recipients of the covered +work and works based on it. + + A patent license is "discriminatory" if it does not include within +the scope of its coverage, prohibits the exercise of, or is +conditioned on the non-exercise of one or more of the rights that are +specifically granted under this License. You may not convey a covered +work if you are a party to an arrangement with a third party that is +in the business of distributing software, under which you make payment +to the third party based on the extent of your activity of conveying +the work, and under which the third party grants, to any of the +parties who would receive the covered work from you, a discriminatory +patent license (a) in connection with copies of the covered work +conveyed by you (or copies made from those copies), or (b) primarily +for and in connection with specific products or compilations that +contain the covered work, unless you entered into that arrangement, +or that patent license was granted, prior to 28 March 2007. + + Nothing in this License shall be construed as excluding or limiting +any implied license or other defenses to infringement that may +otherwise be available to you under applicable patent law. + + 12. No Surrender of Others' Freedom. + + If conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot convey a +covered work so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you may +not convey it at all. For example, if you agree to terms that obligate you +to collect a royalty for further conveying from those to whom you convey +the Program, the only way you could satisfy both those terms and this +License would be to refrain entirely from conveying the Program. + + 13. Use with the GNU Affero General Public License. + + Notwithstanding any other provision of this License, you have +permission to link or combine any covered work with a work licensed +under version 3 of the GNU Affero General Public License into a single +combined work, and to convey the resulting work. The terms of this +License will continue to apply to the part which is the covered work, +but the special requirements of the GNU Affero General Public License, +section 13, concerning interaction through a network will apply to the +combination as such. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new versions of +the GNU General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + + Each version is given a distinguishing version number. If the +Program specifies that a certain numbered version of the GNU General +Public License "or any later version" applies to it, you have the +option of following the terms and conditions either of that numbered +version or of any later version published by the Free Software +Foundation. If the Program does not specify a version number of the +GNU General Public License, you may choose any version ever published +by the Free Software Foundation. + + If the Program specifies that a proxy can decide which future +versions of the GNU General Public License can be used, that proxy's +public statement of acceptance of a version permanently authorizes you +to choose that version for the Program. + + Later license versions may give you additional or different +permissions. However, no additional obligations are imposed on any +author or copyright holder as a result of your choosing to follow a +later version. + + 15. Disclaimer of Warranty. + + THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY +APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT +HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY +OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM +IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF +ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. Limitation of Liability. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS +THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY +GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE +USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF +DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD +PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), +EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF +SUCH DAMAGES. + + 17. Interpretation of Sections 15 and 16. + + If the disclaimer of warranty and limitation of liability provided +above cannot be given local legal effect according to their terms, +reviewing courts shall apply local law that most closely approximates +an absolute waiver of all civil liability in connection with the +Program, unless a warranty or assumption of liability accompanies a +copy of the Program in return for a fee. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +state the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . + +Also add information on how to contact you by electronic and paper mail. + + If the program does terminal interaction, make it output a short +notice like this when it starts in an interactive mode: + + Copyright (C) + This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, your program's commands +might be different; for a GUI interface, you would use an "about box". + + You should also get your employer (if you work as a programmer) or school, +if any, to sign a "copyright disclaimer" for the program, if necessary. +For more information on this, and how to apply and follow the GNU GPL, see +. + + The GNU General Public License does not permit incorporating your program +into proprietary programs. If your program is a subroutine library, you +may consider it more useful to permit linking proprietary applications with +the library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. But first, please read +. 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/alsa/Synthesizer/LLVM/Server.hs b/alsa/Synthesizer/LLVM/Server.hs new file mode 100644 --- /dev/null +++ b/alsa/Synthesizer/LLVM/Server.hs @@ -0,0 +1,86 @@ +module Main where + +import qualified Synthesizer.LLVM.Server.CausalPacked.Test as ServerCausalTest +import qualified Synthesizer.LLVM.Server.CausalPacked.Run as ServerCausal +import qualified Synthesizer.LLVM.Server.Packed.Test as ServerPackedTest +import qualified Synthesizer.LLVM.Server.Packed.Run as ServerPacked +import qualified Synthesizer.LLVM.Server.Scalar.Test as ServerScalarTest +import qualified Synthesizer.LLVM.Server.Scalar.Run as ServerScalar + +import qualified LLVM.Core as LLVM + + +part :: Int +part = 106 + +main :: IO () +main = + LLVM.initializeNativeTarget >> + case part of + 000 -> ServerScalar.pitchBend + 001 -> ServerScalar.frequencyModulation + 002 -> ServerScalar.keyboard + 003 -> ServerScalar.keyboardStereo + 004 -> ServerScalar.keyboardMulti + 005 -> ServerScalar.keyboardStereoMulti + 100 -> ServerPacked.frequencyModulation + 101 -> ServerPacked.keyboard + 102 -> ServerPacked.keyboardStereo + 103 -> ServerPacked.keyboardFM + 104 -> ServerPacked.keyboardFMMulti + 105 -> ServerPacked.keyboardDetuneFM + 106 -> ServerPacked.keyboardFilter -- there is still a leak when playing for a long time with arcStrings + 150 -> ServerCausal.keyboard + 151 -> ServerCausal.keyboardFM + 152 -> ServerCausal.keyboardDetuneFM + 153 -> ServerCausal.keyboardMultiChannel + 154 -> ServerCausal.voderBand + 155 -> ServerCausal.formant + 156 -> ServerCausal.voderMask + 157 -> ServerCausal.voderMaskEnv + 158 -> ServerCausal.voderMaskSeparated + 159 -> ServerCausal.voderMaskMulti + 200 -> ServerScalarTest.pitchBend0 + 201 -> ServerScalarTest.pitchBend1 + 202 -> ServerScalarTest.pitchBend2 + 203 -> ServerScalarTest.sequencePress + 300 -> ServerPackedTest.adsr + 301 -> ServerPackedTest.sequencePlain + 302 -> ServerPackedTest.sequenceLLVM + 303 -> ServerPackedTest.sequencePitchBendCycle + 304 -> ServerPackedTest.sequencePitchBendSimple + 305 -> ServerPackedTest.sequencePitchBend + 306 -> ServerPackedTest.sequenceModulated + 307 -> ServerPackedTest.sequencePress + 308 -> ServerPackedTest.sequenceModulatedLong + 309 -> ServerPackedTest.sequenceModulatedLongFM + 310 -> ServerPackedTest.sequenceModulatedRepeat + 311 -> ServerPackedTest.sequenceSample + 312 -> ServerPackedTest.sequenceSample1 -- leak +-- 313 -> ServerPackedTest.testSequenceSample1a -- leak + 320 -> ServerPackedTest.sequenceSample2 -- leak + 321 -> ServerPackedTest.sequenceSample3 -- leak + 322 -> ServerPackedTest.sequenceSample4 -- leak + 323 -> ServerPackedTest.sequenceFM1 -- leak + 324 -> ServerPackedTest.bellNoiseStereoTest + 400 -> ServerCausalTest.render + 401 -> ServerCausalTest.sequenceNothing + 402 -> ServerCausalTest.sequenceSingleLong + 403 -> ServerCausalTest.sequenceSingleShort + 404 -> ServerCausalTest.sequenceLoop + 405 -> ServerCausalTest.sequenceStaccato + 406 -> ServerCausalTest.sequenceControlled + 407 -> ServerCausalTest.sequenceControlledModulated + 409 -> ServerCausalTest.functional + 410 -> ServerCausalTest.functionalPlug + 411 -> ServerCausalTest.functionalTine >> + ServerCausalTest.functionalPlugTine + 412 -> ServerCausalTest.sampledSound + 413 -> ServerCausalTest.sampledSoundCrash + 414 -> ServerCausalTest.sampledSoundMono + 415 -> ServerCausalTest.frequencyModulation + 416 -> ServerCausalTest.frequencyModulationIO + 417 -> ServerCausalTest.frequencyModulationStrictIO + 418 -> ServerCausalTest.frequencyModulationSawIO + 419 -> ServerCausalTest.envelopeIO + _ -> error "not implemented server part" diff --git a/alsa/Synthesizer/LLVM/Server/ALSA.hs b/alsa/Synthesizer/LLVM/Server/ALSA.hs new file mode 100644 --- /dev/null +++ b/alsa/Synthesizer/LLVM/Server/ALSA.hs @@ -0,0 +1,163 @@ +module Synthesizer.LLVM.Server.ALSA ( + Output, + play, playChunk, + record, + put, + startMessage, + makeNote, + ) where + +import qualified Synthesizer.LLVM.Server.Option as Option + +import qualified Synthesizer.ALSA.CausalIO.Process as PIO + +import qualified Sound.ALSA.Sequencer.Event as Event +import qualified Sound.ALSA.Sequencer.Address as Addr +import qualified Sound.ALSA.Sequencer.Time as Time +import qualified Sound.ALSA.Sequencer.RealTime as RealTime + +import qualified Sound.ALSA.PCM.Node.ALSA as PCM +import qualified Sound.ALSA.PCM.Parameters.Software as SwParam +import qualified Sound.ALSA.PCM.Parameters.Hardware as HwParam + +import qualified Synthesizer.Storable.Signal as SigSt + +import qualified Data.StorableVector.Lazy as SVL +import qualified Data.StorableVector.Base as SVB + +import qualified Algebra.Additive as Additive + +import Control.Functor.HT (void) + +import qualified System.IO as IO + +import Prelude hiding (Real, round) + + +getOptParams :: Option.T -> h -> ((PCM.Size, PCM.SampleFreq), h) +getOptParams opt h = + ((case Option.chunkSize opt of SVL.ChunkSize size -> size, + case Option.sampleRate opt of + Nothing -> 44100 + Just (Option.SampleRate rate) -> rate), + h) + + +type Output handle signal a = Option.T -> PIO.Output handle signal a + +record :: + (PCM.SampleFmt y) => + FilePath -> Output IO.Handle (SigSt.T y) () +record name opt = + (fmap (getOptParams opt) $ IO.openFile name IO.WriteMode, + IO.hClose, + SVL.hPut) + +put :: (Show signal) => Output () signal () +put opt = + (return $ getOptParams opt (), + return, + \() -> print) + + +playChunk :: + (Additive.C y, PCM.SampleFmt y) => + Output (PCM.Handle HwParam.Interleaved y) (SVB.Vector y) () +playChunk opt = + (openPCM opt, closePCM, write) + + +-- ToDo: do not record the empty chunk that is inserted for latency +{-# INLINE play #-} +play :: + (Additive.C y, PCM.SampleFmt y) => + Output (PCM.Handle HwParam.Interleaved y) (SigSt.T y) () +play opt = + (openPCM opt, closePCM, \h -> mapM_ (write h) . SVL.chunks) +{- + Play.auto (Play.makeSink + (Option.device opts) (Option.periodTime opts) (round rate)) . + SigSt.append (SigSt.replicate (Option.chunkSize opts) (Option.latency opts) zero) +-- FiltG.delayPosLazySize (Option.chunkSize opts) (Option.latency opts) +-- FiltG.delayPos (Option.latency opts) +-} + + +putLog :: String -> IO () +putLog = putStrLn + +openPCM :: + (PCM.Access i, PCM.SampleFmt y) => + Option.T -> + IO ((PCM.Size, PCM.SampleFreq), PCM.Handle i y) +openPCM opt = do + putLog "alsaOpen" + (((bufferSize,periodSize),(bufferTime,periodTime),sampleRate), h) <- + PCM.open (PCM.modes []) PCM.StreamPlayback + (setHwParams (Option.sampleRate opt) (Option.chunkSize opt)) + (\q@(sizes,_,_) -> do + uncurry SwParam.setBufferSize sizes + return q) + (Option.device opt) + PCM.prepare h + putLog $ "bufferTime = " ++ show bufferTime + putLog $ "bufferSize = " ++ show bufferSize + putLog $ "periodTime = " ++ show periodTime + putLog $ "periodSize = " ++ show periodSize + return ((periodSize, sampleRate), h) + +closePCM :: PCM.Handle i y -> IO () +closePCM pcm = do + putLog "alsaClose" + PCM.drain pcm + PCM.close pcm + +setHwParams :: + Maybe (Option.SampleRate Int) -> + SVL.ChunkSize -> + HwParam.T i y ((PCM.Size,PCM.Size),(PCM.Time,PCM.Time),PCM.SampleFreq) + -- ^ ((bufferSize,periodSize),(bufferTime,periodTime),sampleRate) +setHwParams mrate (SVL.ChunkSize periodSize) = do + (actualRate,_) <- + case mrate of + Nothing -> do + HwParam.setRateResample False + HwParam.setRateNear 44100 EQ + Just (Option.SampleRate rate) -> do + HwParam.setRateResample True + HwParam.setRateNear rate EQ + (actualPeriodSize,_) <- + HwParam.setPeriodSizeNear periodSize EQ + actualBufferSize <- + HwParam.setBufferSizeNear + (max periodSize (actualPeriodSize*4)) + + (actualBufferTime,_) <- HwParam.getBufferTime + (actualPeriodTime,_) <- HwParam.getPeriodTime + return ((actualBufferSize, actualPeriodSize), + (actualBufferTime, actualPeriodTime), + actualRate) + +write :: + (PCM.SampleFmt y) => + PCM.Handle PCM.Interleaved y -> SVB.Vector y -> IO () +write h xs = + SVB.withStartPtr xs $ \buf -> + void . PCM.writeiRetry h buf . fromIntegral + + + +startMessage :: String +startMessage = + "run 'aconnect' to connect to the MIDI controller" + + +-- cf. synthesizer-alsa:Synthesizer.ALSA.Storable.Server.Test +makeNote :: Event.NoteEv -> Int -> Event.T +makeNote typ pit = + (Event.simple Addr.subscribers $ Event.NoteEv typ $ + Event.simpleNote (Event.Channel 0) + (Event.Pitch $ fromIntegral pit) Event.normalVelocity) + { Event.time = + Time.consAbs $ Time.Real $ RealTime.fromInteger 0 + } diff --git a/alsa/Synthesizer/LLVM/Server/CausalPacked/Run.hs b/alsa/Synthesizer/LLVM/Server/CausalPacked/Run.hs new file mode 100644 --- /dev/null +++ b/alsa/Synthesizer/LLVM/Server/CausalPacked/Run.hs @@ -0,0 +1,212 @@ +module Synthesizer.LLVM.Server.CausalPacked.Run where + +import qualified Synthesizer.LLVM.Server.CausalPacked.Arrange as Arrange +import Synthesizer.LLVM.Server.CausalPacked.Arrange + (StereoVector, controllerExponentialDim, (&+&)) + +import qualified Sound.MIDI.Controller as Ctrl + +import qualified Synthesizer.LLVM.Server.CausalPacked.Speech as Speech +import qualified Synthesizer.LLVM.Server.Option as Option +import Synthesizer.LLVM.Server.ALSA (playChunk, startMessage) +import Synthesizer.LLVM.Server.Common + +import qualified Sound.ALSA.Sequencer.Event as Event +import Sound.MIDI.ALSA.Query () +import Sound.MIDI.ALSA.Construct () + +import qualified Synthesizer.MIDI.CausalIO.ControllerSet as MCS +import qualified Synthesizer.MIDI.CausalIO.Process as MIO +import qualified Synthesizer.ALSA.CausalIO.Process as PAlsa +import qualified Synthesizer.CausalIO.Process as PIO + +import qualified Synthesizer.LLVM.Causal.Render as CausalRender +import qualified Synthesizer.LLVM.Causal.Process as Causal +import qualified Synthesizer.LLVM.Storable.Signal as SigStL + +import qualified Synthesizer.LLVM.Frame.StereoInterleaved as StereoInt +import qualified Synthesizer.LLVM.Frame.Stereo as Stereo + +import qualified Data.StorableVector as SV + +import qualified Synthesizer.Zip as Zip + +import qualified Sound.ALSA.PCM as PCM + +import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg +import qualified Sound.MIDI.Message.Channel as ChannelMsg + +import Control.Arrow (arr, (<<<), (^<<), (<<^)) + +import qualified Number.DimensionTerm as DN + +import qualified Algebra.Additive as Additive + +import Prelude hiding (Real, id) + + + +playFromEvents :: + (PCM.SampleFmt a, Additive.C a) => + Option.T -> + (SampleRate Real -> + PIO.T (MIO.Events Event.T) (SV.Vector a)) -> + IO () +playFromEvents opt process = do + putStrLn startMessage + PAlsa.playFromEventsWithParams (playChunk opt) + (Option.clientName opt) + (\(_size,rate) -> + process (SampleRate $ fromIntegral rate)) + + +keyboard :: IO () +keyboard = do + opt <- Option.get + proc <- Arrange.keyboard + + playFromEvents opt $ \ sampleRate -> + arr SigStL.unpackStrict + <<< + proc (Option.channel opt) sampleRate + + +keyboardFM :: IO () +keyboardFM = do + opt <- Option.get + proc <- + Arrange.keyboardFM + (Causal.map StereoInt.interleave) + (Option.channel opt) + playFromEvents opt $ \ sampleRate -> + SigStL.unpackStereoStrict ^<< proc sampleRate + +keyboardDetuneFMCore :: + Option.T -> + IO (ChannelMsg.Channel -> VoiceMsg.Program -> + SampleRate Real -> + PIO.T (MIO.Events Event.T) (SV.Vector StereoVector)) +keyboardDetuneFMCore opt = + Arrange.keyboardDetuneFMCore + (Causal.map StereoInt.interleave) + (Option.sampleDirectory opt) + +keyboardDetuneFM :: IO () +keyboardDetuneFM = do + opt <- Option.get + proc <- keyboardDetuneFMCore opt + playFromEvents opt $ \ sampleRate -> + arr SigStL.unpackStereoStrict + <<< + proc (Option.channel opt) (VoiceMsg.toProgram 0) sampleRate + +keyboardMultiChannel :: IO () +keyboardMultiChannel = do + opt <- Option.get + proc <- Arrange.keyboardMultiChannel (Option.sampleDirectory opt) + playFromEvents opt proc + + +voderBand :: IO () +voderBand = do + opt <- Option.get + proc <- + Arrange.voderBand + (Causal.map StereoInt.interleave) + (Option.sampleDirectory opt) + + playFromEvents opt $ \ sampleRate -> + arr SigStL.unpackStereoStrict + <<< + proc (Option.channel opt) (VoiceMsg.toProgram 4) sampleRate + +voderMask :: IO () +voderMask = do + opt <- Option.get + proc <- + Arrange.voderMask + (Causal.map StereoInt.interleave) + (Option.sampleDirectory opt) + + playFromEvents opt $ \ sampleRate -> + arr SigStL.unpackStereoStrict + <<< + proc (Option.channel opt) (VoiceMsg.toProgram 4) sampleRate + +voderMaskEnv :: IO () +voderMaskEnv = do + opt <- Option.get + proc <- + Arrange.voderMaskEnv + (Causal.map StereoInt.interleave) + (Option.sampleDirectory opt) + + playFromEvents opt $ \ sampleRate -> + arr SigStL.unpackStereoStrict + <<< + proc (Option.channel opt) (VoiceMsg.toProgram 4) sampleRate + +voderMaskSeparated :: IO () +voderMaskSeparated = do + opt <- Option.get + proc <- + Arrange.voderMaskSeparated + (const $ Causal.map StereoInt.interleave) + (Option.sampleDirectory opt) + + playFromEvents opt $ \ sampleRate -> + arr SigStL.unpackStereoStrict + <<< + proc + (Option.channel opt) (Option.extraChannel opt) + (VoiceMsg.toProgram 4) sampleRate () + +voderMaskMulti :: IO () +voderMaskMulti = do + opt <- Option.get + proc <- Arrange.voderMaskMulti $ Option.sampleDirectory opt + playFromEvents opt proc + + +formant :: IO () +formant = do + opt <- Option.get + proc <- + Arrange.keyboardDetuneFMCore (arr Stereo.multiValue) + (Option.sampleDirectory opt) + form <- Speech.filterFormant + mix <- CausalRender.run Causal.mix + interleave <- + CausalRender.run + (Causal.map StereoInt.interleave <<^ Stereo.unMultiValue) + + playFromEvents opt $ \ sampleRate -> + arr SigStL.unpackStereoStrict + <<< + interleave + <<< + foldl1 + (\x y -> mix <<< Zip.arrowFanout x y) + (zipWith + (\n (freq, amp, reson) -> + form sampleRate + <<< + Zip.arrowFirst + (MCS.controllerExponential (Ctrl.fromInt $ 16+n) (0.01,1) amp + &+& + (MCS.controllerExponential (Ctrl.fromInt $ 26+n) (1,100) reson + &+& + controllerExponentialDim (Ctrl.fromInt $ 21+n) + (DN.frequency 100, DN.frequency 10000) + (DN.frequency freq)))) + [0..] + [( 650, 1.00, 30), + (1080, 0.25, 30), + (2650, 0.20, 30), + (2900, 0.16, 30), + (3250, 0.01, 30) + ]) + <<< + MCS.fromChannel (Option.channel opt) + &+& + proc (Option.channel opt) (VoiceMsg.toProgram 4) sampleRate diff --git a/alsa/Synthesizer/LLVM/Server/CausalPacked/Test.hs b/alsa/Synthesizer/LLVM/Server/CausalPacked/Test.hs new file mode 100644 --- /dev/null +++ b/alsa/Synthesizer/LLVM/Server/CausalPacked/Test.hs @@ -0,0 +1,622 @@ +module Synthesizer.LLVM.Server.CausalPacked.Test where + +import qualified Synthesizer.LLVM.Server.CausalPacked.Speech as Speech +import qualified Synthesizer.LLVM.Server.CausalPacked.InstrumentPlug as InstrFP +import qualified Synthesizer.LLVM.Server.CausalPacked.Instrument as Instr +import qualified Synthesizer.LLVM.Server.SampledSound as Sample +import qualified Synthesizer.LLVM.Server.Option as Option +import qualified Synthesizer.LLVM.Server.Default as Default +import Synthesizer.LLVM.Server.CausalPacked.Common (chopEvents) +import Synthesizer.LLVM.Server.CausalPacked.Arrange + ((&+&), shortTime, controllerExponentialDim) +import Synthesizer.LLVM.Server.CommonPacked (Vector) +import Synthesizer.LLVM.Server.Common hiding (Instrument) + +import qualified Sound.ALSA.Sequencer.Event as Event +-- import qualified Sound.ALSA.Sequencer.Connect as Connect +import qualified Sound.ALSA.Sequencer.Address as Addr +import qualified Synthesizer.MIDI.Generic as Gen + +import qualified Synthesizer.LLVM.Frame.StereoInterleaved as StereoInt +import qualified Synthesizer.LLVM.Frame.Stereo as Stereo +import qualified Synthesizer.LLVM.Frame.SerialVector as Serial + +import qualified Sound.MIDI.Controller as Ctrl +import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg + +import qualified Synthesizer.CausalIO.Gate as Gate +import qualified Synthesizer.Zip as Zip + +import qualified Synthesizer.ALSA.Storable.Play as Play +import qualified Synthesizer.ALSA.CausalIO.Process as PAlsa +import Synthesizer.MIDI.Storable (Instrument) + +import qualified Synthesizer.MIDI.PiecewiseConstant.ControllerSet as PCS +import qualified Synthesizer.MIDI.CausalIO.ControllerSet as MCS +import qualified Synthesizer.MIDI.CausalIO.Process as MIO +import qualified Synthesizer.PiecewiseConstant.Signal as PC +import qualified Synthesizer.CausalIO.Process as PIO + +import qualified Synthesizer.LLVM.Causal.FunctionalPlug as FP +import qualified Synthesizer.LLVM.Causal.Functional as F +import qualified Synthesizer.LLVM.Causal.Render as CausalRender +import qualified Synthesizer.LLVM.Causal.Process as Causal +import qualified Synthesizer.LLVM.Generator.Render as Render +import qualified Synthesizer.LLVM.Generator.Signal as Sig +import qualified Synthesizer.LLVM.Storable.Process as CausalSt +import qualified Synthesizer.LLVM.Storable.Signal as SigStL +import qualified Synthesizer.LLVM.MIDI.BendModulation as BM +import qualified Synthesizer.LLVM.Wave as Wave +import Synthesizer.LLVM.Causal.Process (($*), ($<)) + +import qualified Synthesizer.Generic.Cut as CutG +import qualified Synthesizer.Storable.Cut as CutSt +import qualified Data.StorableVector.Lazy as SVL +import qualified Data.StorableVector as SV + +import qualified Data.EventList.Relative.TimeBody as EventList +import qualified Data.EventList.Relative.TimeTime as EventListTT +import qualified Data.EventList.Relative.TimeMixed as EventListTM +import qualified Data.EventList.Relative.BodyTime as EventListBT + +import qualified LLVM.DSL.Expression as Expr + +import System.Path (()) + +import Control.Arrow (arr, (***), (<<<), (<<^), (^<<)) +import Control.Category (id) +import Control.Applicative (liftA2) +import Control.Monad (when) +import Control.Monad.Trans.State (evalState) + +import qualified Data.Map as Map + +import qualified Numeric.NonNegative.Wrapper as NonNegW + +import qualified Number.DimensionTerm as DN + +import Data.Word (Word8, Word32) +import Data.Int (Int32) + +import qualified System.Unsafe as Unsafe +import qualified System.IO as IO +import Foreign.Storable (Storable) +import Control.Exception (bracket) + +import Prelude hiding (Real, id) + + +sampleRate :: SampleRate Real +sampleRate = Default.sampleRate + +{- | +try to reproduce a space leak +-} +sequencePlain :: IO () +sequencePlain = + SVL.writeFile "/tmp/test.f32" $ +-- print $ last $ SVL.chunks $ + CutSt.arrange Play.defaultChunkSize $ + evalState (Gen.sequence Default.channel (error "no sound" :: Instrument Real Real)) $ + let evs = EventList.cons 10 ([]::[Event.T]) evs + in evs + + +-- see playFromEvents +writeTest :: + (CutG.Read t, Storable a) => + PIO.T t (SV.Vector a) -> [t] -> IO () +writeTest (PIO.Cons next create delete) evsChunky = + IO.withFile "/tmp/test.f32" IO.WriteMode $ \h -> + bracket create delete $ + let loop evs s0 = + case evs of + [] -> return () + chunk : rest -> do + (pcm, s1) <- next chunk s0 + SV.hPut h pcm + when + (CutG.length pcm >= CutG.length chunk) + (loop rest s1) + in loop evsChunky + +render :: IO () +render = do + ping <- Instr.pingRelease $/ 1 $/ 0.1 -- leaky +-- ping <- Instr.ping -- not leaky + + writeTest (ping sampleRate 10 440) $ + replicate 10000 $ Gate.chunk 512 Nothing + +sequenceEvents :: [PAlsa.Events] -> IO () +sequenceEvents evs = do + arrange <- CausalSt.makeArranger + + ping <- Instr.pingRelease $/ 1 $/ 0.1 -- leaky +-- ping <- Instr.ping -- not leaky + + let proc = + arrange + <<< + arr shortTime + <<< + MIO.sequenceCore + Default.channel + (\ _pgm -> ping sampleRate) + + writeTest proc evs + +sequenceNothing :: IO () +sequenceNothing = + sequenceEvents $ + let evs = EventList.cons 10 [] evs + in chopEvents 512 $ EventListTM.takeTime (10^(7::Int)) evs + + +noteEvent :: + Event.NoteEv -> + Word8 -> + Word8 -> + Word8 -> + Event.T +noteEvent mode chan pitch velocity = + -- Event.simple (Connect.toSubscribers Addr.subscribers) $ + Event.simple Addr.subscribers $ Event.NoteEv mode $ + Event.simpleNote + (Event.Channel $ fromIntegral chan) + (Event.Pitch $ fromIntegral pitch) + (Event.Velocity $ fromIntegral velocity) + +ctrlEvent :: + Word8 -> + Word32 -> + Int32 -> + Event.T +ctrlEvent chan cc cval = + -- Event.simple (Connect.toSubscribers Addr.subscribers) $ + Event.simple Addr.subscribers $ + Event.CtrlEv Event.Controller $ + Event.Ctrl + (Event.Channel $ fromIntegral chan) + (Event.Parameter $ fromIntegral cc) + (Event.Value $ fromIntegral cval) + +sequenceSingleLong :: IO () +sequenceSingleLong = do + sequenceEvents $ + let evs = EventList.cons 10 [] evs + in chopEvents 512 $ + EventListTM.takeTime (10^(7::Int)) $ + EventList.cons 0 [noteEvent Event.NoteOn 0 60 64] evs + +sequenceSingleShort :: IO () +sequenceSingleShort = do + sequenceEvents $ + let evs = EventList.cons 10 [] evs + in chopEvents 512 $ + EventListTM.takeTime (10^(7::Int)) $ + EventList.cons 0 [noteEvent Event.NoteOn 0 60 64] $ + EventList.cons 10 [noteEvent Event.NoteOff 0 60 64] evs + +{- +Although it consumes constant memory, +the memory usage is quite high, +e.g. 40MB for chunk size 100000 and peiod 1100. +This might be caused by the large overlapping in the release phases. +You need only 6MB heap for the same chunksize and period 11000. +-} +sequenceLoop :: IO () +sequenceLoop = do + sequenceEvents $ + let evs = + EventList.cons 11001 + [noteEvent Event.NoteOff 0 60 50, + noteEvent Event.NoteOn 0 60 50] evs + in chopEvents 100000 $ + EventListTM.takeTime (10^(7::Int)) $ + EventList.cons 0 [noteEvent Event.NoteOn 0 60 50] evs + +sequenceStaccato :: IO () +sequenceStaccato = do + sequenceEvents $ + let evs = + EventList.cons 551 [noteEvent Event.NoteOff 0 60 50] $ + EventList.cons 550 [noteEvent Event.NoteOn 0 60 50] evs + in chopEvents 100000 $ + EventListTM.takeTime (10^(7::Int)) $ + EventList.cons 0 [noteEvent Event.NoteOn 0 60 50] evs + + + +sequenceControlledEvents :: [PAlsa.Events] -> IO () +sequenceControlledEvents chunkedEvents = do + opt <- Option.get + arrange <- CausalSt.makeArranger + amp <- + CausalRender.run + (Causal.map StereoInt.interleave <<< + Causal.envelopeStereo <<< + Causal.map Serial.upsample *** arr Stereo.unMultiValue) + + ping <- Instr.pingStereoReleaseFM + + let timeControlPercussive = + controllerExponentialDim Ctrl.attackTime + (DN.time 0.1, DN.time 2.5) (DN.time 0.8) + &+& + controllerExponentialDim Ctrl.releaseTime + (DN.time 0.03, DN.time 0.3) (DN.time 0.1) + + frequencyControlPercussive = + MCS.controllerLinear controllerDetune (0,0.005) 0.001 + &+& + MCS.bendWheelPressure 2 0.04 0.03 + + pingProc vel freq = + ping sampleRate vel freq + <<< + Zip.arrowSecond + (timeControlPercussive + &+& + ((MCS.controllerExponential controllerTimbre0 (0.3,10) 0.05 + &+& + controllerExponentialDim controllerTimbre1 + (DN.time 0.01, DN.time 10) (DN.time 5)) + &+& + ((MCS.controllerLinear Ctrl.soundController5 (0,10) 2 + &+& + controllerExponentialDim Ctrl.soundController7 + (DN.time 0.03, DN.time 1) (DN.time 0.5)) + &+& + frequencyControlPercussive))) + + let proc = + arr SigStL.unpackStereoStrict + <<< + amp + <<< + (MCS.controllerExponential controllerVolume (0.001, 1) (0.2::Float) + <<^ Zip.second) + &+& + (arrange + <<< + arr shortTime + <<< + MIO.sequenceModulated + (Option.channel opt) (\ _pgm -> pingProc)) + <<< + id &+& MCS.fromChannel (Option.channel opt) + + writeTest proc chunkedEvents + + +sequenceControlled :: IO () +sequenceControlled = + sequenceControlledEvents $ + let evs = EventList.cons 10 [] evs + in chopEvents 512 $ + EventListTM.takeTime (10^(7::Int)) $ + EventList.cons 0 [noteEvent Event.NoteOn 0 60 64] evs + +sequenceControlledModulated :: IO () +sequenceControlledModulated = + sequenceControlledEvents $ + chopEvents 512 $ + EventListTM.takeTime (10^(7::Int)) $ + EventList.cons 0 [noteEvent Event.NoteOn 0 60 64] $ + EventList.fromPairList $ + map (\ev -> (10,[ev])) $ cycle $ + map (ctrlEvent 0 1) [0..127] + + +makeSampledSounds :: + Option.T -> + IO [SampleRate Real -> Real -> Real -> + PIO.T + (Zip.T MIO.GateChunk Instr.DetuneBendModControl) + Instr.StereoChunk] +makeSampledSounds opt = + liftA2 map Instr.sampledSound $ + Sample.loadRanges (Option.sampleDirectory opt) Sample.tomatensalat + + +sampledSound :: IO () +sampledSound = do + opt <- Option.get + + amp <- + CausalRender.run + (Causal.map StereoInt.interleave <<^ Stereo.unMultiValue) + + tomatoSmps <- makeSampledSounds opt + + let tomato smp vel freq = + smp sampleRate vel freq + <<< + Zip.arrowSecond + (MCS.controllerLinear controllerDetune (0,0.005) 0.001 + &+& + MCS.bendWheelPressure 2 0.04 0.03) + + writeTest + (arr SigStL.unpackStereoStrict + <<< + amp + <<< + tomato (last tomatoSmps) 0 440) $ + map + (\m -> + Zip.consChecked "Test.sampledSound" + (Gate.chunk 512 m) + (PCS.Cons Map.empty (EventListTT.pause 512))) $ + replicate 10 Nothing ++ + Just (100, VoiceMsg.normalVelocity) : + replicate 4 Nothing + +loadTomato :: Option.T -> IO (SVL.Vector Real) +loadTomato opt = + case Sample.tomatensalat of + Sample.Info name _sampleRate _positions -> + Sample.load (Option.sampleDirectory opt name) + +sampledSoundMono :: IO () +sampledSoundMono = do + opt <- Option.get + + case Sample.tomatensalat of + Sample.Info _name rate positions -> do + smp <- loadTomato opt + case Sample.parts (Sample.Cons smp (DN.frequency rate) (last positions)) of + (_attack, _sustain, release) -> + SVL.writeFile "/tmp/release.f32" release + + tomatoSmps <- + liftA2 map Instr.sampledSoundMono $ + Sample.loadRanges (Option.sampleDirectory opt) Sample.tomatensalat + + let tomato smp vel freq = + smp sampleRate vel freq + <<< + Zip.arrowSecond (MCS.bendWheelPressure 2 0.04 0.03) + + writeTest (tomato (last tomatoSmps) 0 220) $ + map + (\m -> + Zip.consChecked "Test.sampledSound" + (Gate.chunk 512 m) + (PCS.Cons Map.empty (EventListTT.pause 512))) $ + replicate 10 Nothing ++ + Just (256, VoiceMsg.normalVelocity) : + replicate 10 Nothing + +{- +This one crashes sometimes in LLVM-3.0 when optimizations are enabled. +-} +sampledSoundCrash :: IO () +sampledSoundCrash = do + opt <- Option.get + + amp <- + CausalRender.run + (Causal.map StereoInt.interleave <<^ Stereo.unMultiValue) + + tomatoSmps <- makeSampledSounds opt + + let tomato smp vel freq = + smp sampleRate vel freq + <<< + Zip.arrowSecond + (MCS.controllerLinear controllerDetune (0,0.005) 0.001 + &+& + MCS.bendWheelPressure 2 0.04 0.03) + + writeTest + (arr SigStL.unpackStereoStrict + <<< + amp + <<< + tomato (head tomatoSmps) 0 440) $ + map + (\m -> + Zip.consChecked "Test.sampledSound" + (Gate.chunk 512 m) + (PCS.Cons Map.empty (EventListTT.pause 512))) $ + replicate 10 Nothing ++ + Just (100, VoiceMsg.normalVelocity) : + replicate 10 Nothing + + +lfo :: SVL.Vector Real +lfo = + Unsafe.performIO $ + fmap ($ SVL.chunkSize 512) $ + Render.run (1 + 0.1 * Sig.osci Wave.approxSine2 Expr.zero 0.0001) + +asMono :: vector Real -> vector Real +asMono = id + +frequencyModulation :: IO () +frequencyModulation = do + opt <- Option.get + smp <- loadTomato opt + + SVL.writeFile "/tmp/test.f32" . + asMono . + (\f -> pioApply (f smp) lfo) =<< + CausalRender.run Causal.frequencyModulationLinear + + +frequencyModulationIO :: IO () +frequencyModulationIO = do + opt <- Option.get + smp <- loadTomato opt + + proc <- CausalRender.run Causal.frequencyModulationLinear + + writeTest (proc smp :: PIO.T (SV.Vector Real) (SV.Vector Real)) $ + SVL.chunks lfo + +frequencyModulationStrictIO :: IO () +frequencyModulationStrictIO = do + opt <- Option.get + smp <- loadTomato opt + + proc <- CausalRender.run Causal.frequencyModulationLinear + + writeTest + (proc (SV.concat $ SVL.chunks smp) :: + PIO.T (SV.Vector Real) (SV.Vector Real)) $ + SVL.chunks lfo + +frequencyModulationSawIO :: IO () +frequencyModulationSawIO = do + proc <- + CausalRender.run $ \freq -> + Causal.frequencyModulationLinear + (Causal.take 50000 $* Sig.osci Wave.saw 0 freq) + + writeTest (proc (0.01::Real) :: PIO.T (SV.Vector Real) (SV.Vector Real)) $ + SVL.chunks lfo + +envelopeIO :: IO () +envelopeIO = do + opt <- Option.get + smp <- loadTomato opt + + proc <- CausalRender.run $ \env -> Causal.envelope $< env + + writeTest (proc smp :: PIO.T (SV.Vector Real) (SV.Vector Real)) $ + SVL.chunks lfo + + +functional :: IO () +functional = do + phaser <- + CausalRender.run $ + wrapped $ \(NoiseReference noiseRef) (SampleRate _sr) -> + F.withArgs $ \ratio -> + let noise = F.fromSignal $ Sig.noise 12 noiseRef + in (1-ratio) * noise + + ratio * (Causal.delayZero 100 F.$& noise) + + writeTest + (phaser sampleRate (200000 :: Real) :: + PIO.T (EventListBT.T NonNegW.Int Float) (SV.Vector Float)) $ + map (\y -> EventListBT.singleton y 10000) + [0, 0.25, 0.5, 0.75, 1.00] + + +functionalPlug :: IO () +functionalPlug = do + phaser <- + FP.withArgs $ \ratio0 pl -> + (\f -> + case Expr.unzip pl of + (sr,noiseRef) -> f (expSampleRate sr) noiseRef) $ + wrapped $ \(NoiseReference noiseRef) (SampleRate _sr) -> + let ratio = FP.plug ratio0 + noise = FP.fromSignal $ Sig.noise 12 noiseRef + in (1-ratio) * noise + + ratio * (Causal.delayZero 100 FP.$& noise) + + writeTest + (phaser () (sampleRate, 200000) :: + PIO.T (EventListBT.T NonNegW.Int Float) (SV.Vector Float)) $ + map (\y -> EventListBT.singleton y 10000) + [0, 0.25, 0.5, 0.75, 1.00] + + +makeUnpackStereoStrict :: + IO (PIO.T (SV.Vector (Stereo.T Vector)) (SV.Vector (Stereo.T Real))) +makeUnpackStereoStrict = + fmap (SigStL.unpackStereoStrict ^<<) $ + CausalRender.run + (Causal.map StereoInt.interleave <<^ Stereo.unMultiValue) +{- +makeUnpackStereoStrict :: + IO (SV.Vector (Stereo.T Vector) -> SV.Vector (Stereo.T Real)) +makeUnpackStereoStrict = + SigStL.makeUnpackGenericStrict +-} + +functionalTineControl :: + Instr.WithEnvelopeControl + (Zip.T + (Zip.T (Instr.Control Real) (Instr.Control Real)) + Instr.DetuneBendModControl) +functionalTineControl = + let cs :: Num a => a + cs = 512 + in Zip.Cons + (Gate.chunk cs Nothing) + (Zip.Cons + (Zip.Cons + (EventListBT.singleton (DN.time 1) cs) + (EventListBT.singleton (DN.time 1) cs)) + (Zip.Cons + (Zip.Cons + (EventListBT.singleton 2 cs) + (EventListBT.singleton 1 cs)) + (Zip.Cons + (EventListBT.singleton 0.001 cs) + (EventListBT.singleton (BM.Cons 1 0.01) cs)))) + +functionalTine :: IO () +functionalTine = do + ping <- Instr.tineStereoFM + unpack <- makeUnpackStereoStrict + writeTest (unpack <<< ping sampleRate 0 440) $ + replicate 100 functionalTineControl + +functionalPlugTine :: IO () +functionalPlugTine = do + ping <- InstrFP.tineStereoFM + unpack <- makeUnpackStereoStrict + writeTest (unpack <<< ping sampleRate 0 440) $ + replicate 100 functionalTineControl + + +stringControl :: + PC.ShortStrictTime -> + Instr.WithEnvelopeControl + (Zip.T (Instr.Control Real) Instr.DetuneBendModControl) +stringControl cs = + Zip.Cons + (Gate.chunk (PC.longFromShortTime cs) Nothing) + (Zip.Cons + (Zip.Cons + (EventListBT.singleton (DN.time 0.5) cs) + (EventListBT.singleton (DN.time 1) cs)) + (Zip.Cons + (EventListBT.singleton 10 cs) + (Zip.Cons + (EventListBT.singleton 0.001 cs) + (EventListBT.singleton (BM.Cons 1 0) cs)))) + +phonemeControl :: + PC.ShortStrictTime -> + (PC.ShortStrictTime -> ctrl) -> + Instr.WithEnvelopeControl ctrl +phonemeControl cs ctrl = + Zip.Cons + (Gate.chunk (PC.longFromShortTime cs) Nothing) + (Zip.Cons + (Zip.Cons + (EventListBT.singleton (DN.time 0.5) cs) + (EventListBT.singleton (DN.time 0.02) cs)) + (ctrl cs)) + +speech :: IO () +speech = do + string <- Instr.softStringShapeFM + unpack <- makeUnpackStereoStrict + when False $ + writeTest (unpack <<< string sampleRate 0 440) $ + replicate 100 $ stringControl 512 + + phoneme <- Speech.phonemeMask + masks <- Speech.loadMasks Speech.maskNamesGrouped + writeTest + (unpack <<< phoneme masks sampleRate 0 (VoiceMsg.toPitch 64) <<< + Zip.arrowSecond (Zip.arrowSecond (string sampleRate 0 440))) $ + replicate 100 $ phonemeControl 512 stringControl diff --git a/alsa/Synthesizer/LLVM/Server/Option.hs b/alsa/Synthesizer/LLVM/Server/Option.hs new file mode 100644 --- /dev/null +++ b/alsa/Synthesizer/LLVM/Server/Option.hs @@ -0,0 +1,72 @@ +module Synthesizer.LLVM.Server.Option ( + T(..), + get, + SampleRate(SampleRate), + ) where + +import qualified Synthesizer.LLVM.Server.OptionCommon as Option +import Synthesizer.LLVM.Server.Common (SampleRate(..)) + +import qualified Synthesizer.ALSA.Storable.Play as Play +import qualified Data.StorableVector.Lazy as SVL +import Synthesizer.ALSA.EventList (ClientName(ClientName)) + +import qualified Sound.MIDI.Message.Channel as ChannelMsg + +import qualified System.Path as Path +import qualified Options.Applicative as OP +import Control.Applicative (pure, (<$>), (<*>)) +import Data.Monoid ((<>)) + +import Prelude hiding (Real) + + +data T = + Cons { + device :: Play.Device, + clientName :: ClientName, + channel, extraChannel :: ChannelMsg.Channel, + sampleDirectory :: Path.AbsRelDir, + sampleRate :: Maybe (SampleRate Int), + chunkSize :: SVL.ChunkSize, + latency :: Int + } + deriving (Show) + + +defaultLatency :: Int +defaultLatency = + -- 0 + -- 256 + 1024 + + + +options :: OP.Parser T +options = + pure Cons + <*> OP.strOption + (OP.short 'd' <> + OP.long "device" <> + OP.metavar "NAME" <> + OP.value Play.defaultDevice <> + OP.help "select ALSA output device") + <*> fmap + (\(Option.ClientName name) -> ClientName name) + (Option.clientName "Name of the ALSA client") + <*> Option.channel + <*> Option.extraChannel + <*> Option.sampleDirectory + <*> Option.sampleRate + <*> Option.blockSize Play.defaultChunkSize + <*> OP.option + (fromInteger <$> + Option.parseNumber "latency" (\n -> 0<=n && n<=Option.maxInt) "non-negative") + (OP.long "latency" <> + OP.metavar "SIZE" <> + OP.value defaultLatency <> + OP.help "latency as number of sample-frames") + + +get :: IO T +get = Option.get options "Live software synthesizer using LLVM and ALSA" diff --git a/alsa/Synthesizer/LLVM/Server/Packed/Run.hs b/alsa/Synthesizer/LLVM/Server/Packed/Run.hs new file mode 100644 --- /dev/null +++ b/alsa/Synthesizer/LLVM/Server/Packed/Run.hs @@ -0,0 +1,500 @@ +module Synthesizer.LLVM.Server.Packed.Run where + +import qualified Synthesizer.LLVM.Server.Packed.Instrument as Instr +import qualified Synthesizer.LLVM.Server.SampledSound as Sample +import qualified Synthesizer.LLVM.Server.Option as Option +import Synthesizer.LLVM.Server.ALSA (Output, play, startMessage) +import Synthesizer.LLVM.Server.CommonPacked + (Vector, VectorSize, vectorSize, stair) +import Synthesizer.LLVM.Server.Common + +import qualified Synthesizer.ALSA.EventList as Ev +import qualified Sound.ALSA.Sequencer.Event as Event + +import qualified Synthesizer.MIDI.EventList as MidiEv +import qualified Synthesizer.MIDI.PiecewiseConstant as PC +import qualified Synthesizer.MIDI.PiecewiseConstant.ControllerSet as PCS +import qualified Synthesizer.MIDI.Generic as Gen + +import qualified Synthesizer.LLVM.Frame.StereoInterleaved as StereoInt +import qualified Synthesizer.LLVM.Frame.Stereo as Stereo + +import qualified Synthesizer.LLVM.Filter.Universal as UniFilterL +import qualified Synthesizer.LLVM.Causal.Render as CausalRender +import qualified Synthesizer.LLVM.Causal.ProcessPacked as CausalPS +import qualified Synthesizer.LLVM.Causal.Process as Causal +import qualified Synthesizer.LLVM.Generator.Render as Render +import qualified Synthesizer.LLVM.Generator.Signal as Sig +import qualified Synthesizer.LLVM.Storable.Signal as SigStL +import qualified Synthesizer.LLVM.Wave as WaveL +import Synthesizer.LLVM.Causal.Process (($<), ($*)) + +import LLVM.DSL.Expression (Exp) + +import qualified Synthesizer.Storable.Signal as SigSt +import qualified Data.StorableVector.Lazy as SVL + +import qualified Synthesizer.Plain.Filter.Recursive as FiltR +import qualified Synthesizer.Plain.Filter.Recursive.Universal as UniFilter + +import qualified Sound.MIDI.Controller as Ctrl +import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg +import qualified Sound.MIDI.Message.Channel as ChannelMsg + +import qualified Data.EventList.Relative.TimeBody as EventList +import qualified Data.EventList.Relative.MixedTime as EventListMT + +import qualified System.Path.PartClass as PathClass +import qualified System.Path as Path + +import qualified Control.Applicative.HT as App +import Control.Arrow (arr, (<<<), (^<<), (<<^)) +import Control.Applicative (pure, liftA2, liftA3, (<*>)) +import Control.Monad.Trans.State (evalState) + +import Control.Exception (bracket) + +import Algebra.IntegralDomain (divUp) + +import NumericPrelude.Numeric (zero, (^?), (+)) +import Prelude hiding (Real, break, (+)) + + + +{-# INLINE withMIDIEventsMono #-} +withMIDIEventsMono :: + Option.T -> + Output handle (SigSt.T Real) a -> + (SigSt.ChunkSize -> SampleRate Real -> + EventList.T Ev.StrictTime [Event.T] -> SigSt.T Vector) -> IO a +withMIDIEventsMono opt output process = do + putStrLn startMessage + case output opt of + (open,close,write) -> + bracket open (close . snd) $ \((chunkSize,rate),h) -> + let rrate = fromIntegral rate :: Double + in Ev.withMIDIEvents + (Option.clientName opt) + (fromIntegral chunkSize / rrate) + (rrate / fromIntegral vectorSize) + (write h . + SigStL.unpack . + process (SigSt.chunkSize $ divUp chunkSize vectorSize) + (Option.SampleRate $ fromIntegral rate)) + +type StereoVector = StereoInt.T VectorSize Real + +{-# INLINE withMIDIEventsStereo #-} +withMIDIEventsStereo :: + Option.T -> + Output handle (SigSt.T (Stereo.T Real)) a -> + (SigSt.ChunkSize -> SampleRate Real -> + EventList.T Ev.StrictTime [Event.T] -> SigSt.T StereoVector) -> + IO a +withMIDIEventsStereo opt output process = do + putStrLn startMessage + case output opt of + (open,close,write) -> + bracket open (close . snd) $ \((chunkSize,rate),h) -> + let rrate = fromIntegral rate :: Double + in Ev.withMIDIEvents + (Option.clientName opt) + (fromIntegral chunkSize / rrate) + (rrate / fromIntegral vectorSize) + (write h . + SigStL.unpackStereo . + process (SigSt.chunkSize $ divUp chunkSize vectorSize) + (Option.SampleRate $ fromIntegral rate)) + + +frequencyModulation :: IO () +frequencyModulation = do + opt <- Option.get + osc <- + Render.run $ + wrapped $ \(Instr.Modulation fm) -> + constant frequency 10 $ \speed _sr -> + ((CausalPS.osci WaveL.triangle $< zero) + $* Instr.frequencyFromBendModulation speed fm) + withMIDIEventsMono opt play $ \vectorChunkSize sampleRate -> + osc vectorChunkSize sampleRate . flip (,) (880::Real) . + evalState (PC.bendWheelPressure (Option.channel opt) 2 0.04 (0.03::Real)) + + + +keyboard :: IO () +keyboard = do + opt <- Option.get + sound <- Instr.pingRelease $/ 0.4 $/ 0.1 + amp <- CausalRender.run CausalPS.amplify + arrange <- SigStL.makeArranger + withMIDIEventsMono opt play $ \vectorChunkSize sampleRate -> + pioApply (amp (0.2::Real)) . + arrange vectorChunkSize . + evalState + (Gen.sequence (Option.channel opt) $ + sound vectorChunkSize sampleRate) + +keyboardStereo :: IO () +keyboardStereo = do + opt <- Option.get + sound <- Instr.pingStereoRelease $/ 0.4 $/ 0.1 + amp <- + CausalRender.run $ \vol -> + Causal.map StereoInt.interleave <<< + CausalPS.amplifyStereo vol <<^ Stereo.unMultiValue + arrange <- SigStL.makeArranger + withMIDIEventsStereo opt play $ \vectorChunkSize sampleRate -> + pioApply (amp (0.2 :: Real)) . + arrange vectorChunkSize . + evalState + (Gen.sequence (Option.channel opt) $ + sound vectorChunkSize sampleRate) + +keyboardFM :: IO () +keyboardFM = do + opt <- Option.get + str <- Instr.softStringFM + amp <- + CausalRender.run $ \vol -> + Causal.map StereoInt.interleave <<< + CausalPS.amplifyStereo vol <<^ Stereo.unMultiValue + arrange <- SigStL.makeArranger + withMIDIEventsStereo opt play $ \vectorChunkSize sampleRate -> + pioApply (amp (0.2 :: Real)) . + arrange vectorChunkSize . + evalState + (do fm <- PC.bendWheelPressure (Option.channel opt) 2 0.04 0.03 + Gen.sequenceModulated + fm (Option.channel opt) (flip str sampleRate)) + +keyboardFMMulti :: IO () +keyboardFMMulti = do + opt <- Option.get + str <- Instr.softStringFM + tin <- Instr.tineStereoFM $/ 0.4 $/ 0.1 + amp <- + CausalRender.run $ \vol -> + Causal.map StereoInt.interleave <<< + CausalPS.amplifyStereo vol <<^ Stereo.unMultiValue + arrange <- SigStL.makeArranger + withMIDIEventsStereo opt play $ \vectorChunkSize sampleRate -> + pioApply (amp (0.2 :: Real)) . + arrange vectorChunkSize . + evalState + (do fm <- PC.bendWheelPressure (Option.channel opt) 2 0.04 0.03 + Gen.sequenceModulatedMultiProgram + fm (Option.channel opt) + (VoiceMsg.toProgram 1) + (map (\sound fmlocal -> sound fmlocal $ sampleRate) + [str, tin vectorChunkSize])) + +controllerFMDepth1, controllerFMDepth2, controllerFMDepth3, controllerFMDepth4, + controllerFMPartial1, controllerFMPartial2, controllerFMPartial3, controllerFMPartial4 + :: VoiceMsg.Controller +controllerFMDepth1 = Ctrl.soundController3 +controllerFMDepth2 = Ctrl.soundController5 +controllerFMDepth3 = Ctrl.soundController7 +controllerFMDepth4 = Ctrl.soundController8 +controllerFMPartial1 = Ctrl.generalPurpose1 +controllerFMPartial2 = Ctrl.generalPurpose2 +controllerFMPartial3 = Ctrl.effect1Depth +controllerFMPartial4 = Ctrl.effect2Depth + +keyboardDetuneFMCore :: + (PathClass.AbsRel ar) => + Path.Dir ar -> + IO (ChannelMsg.Channel -> VoiceMsg.Program -> + SVL.ChunkSize -> SampleRate Real -> + MidiEv.Filter Event.T (SigSt.T StereoVector)) +keyboardDetuneFMCore smpDir = do + str0 <- Instr.softStringDetuneFM + ssh0 <- Instr.softStringShapeFM + css0 <- Instr.cosineStringStereoFM + asw0 <- Instr.arcSawStringStereoFM + asn0 <- Instr.arcSineStringStereoFM + asq0 <- Instr.arcSquareStringStereoFM + atr0 <- Instr.arcTriangleStringStereoFM + wnd0 <- Instr.wind + wnp0 <- Instr.windPhaser + fms0 <- Instr.fmStringStereoFM + tin0 <- Instr.tineStereoFM + tnc0 <- Instr.tineControlledFM + fnd0 <- Instr.fenderFM + tnb0 <- Instr.tineBankFM + rfm0 <- Instr.resonantFMSynth + png0 <- Instr.pingStereoRelease + pngFM0 <- Instr.pingStereoReleaseFM + sqr0 <- Instr.squareStereoReleaseFM + bel0 <- Instr.bellStereoFM + ben0 <- Instr.bellNoiseStereoFM + flt0 <- Instr.filterSawStereoFM + brs0 <- Instr.brass + + syllables <- + liftA2 map Instr.sampledSound $ + fmap concat $ + mapM (Sample.loadRanges smpDir) $ + Sample.tomatensalat : + Sample.hal : + Sample.graphentheorie : + [] + + + arrange <- SigStL.makeArranger + amp <- + CausalRender.run $ \ctrl -> + (Causal.map StereoInt.interleave <<< + Causal.envelopeStereo $< Instr.piecewiseConstantVector ctrl) + <<^ Stereo.unMultiValue + return $ \chan pgm vcsize sr -> do + let + evHead = + fmap (EventListMT.switchBodyL + (error "empty controller stream") const) + flt = evalState $ + App.lift6 (\rel -> flt0 (4*rel) rel) + (evHead $ + PCS.controllerExponential controllerAttack (0.03,0.3) 0.1) + (PCS.controllerLinear controllerDetune (0,0.005) 0.001) + (evHead $ + PCS.controllerExponential controllerTimbre0 (100,10000) 1000) + (evHead $ + PCS.controllerExponential controllerTimbre1 (0.1,1) 0.1) + (pure vcsize) + (PCS.bendWheelPressure 2 0.04 0.03) + png = + (\rel -> png0 (4*rel) rel vcsize) . + evalState + (evHead $ + PCS.controllerExponential controllerAttack (0.03,0.3) 0.1) + pngFM = evalState $ + App.lift6 (\rel det phs shp -> pngFM0 (4*rel) rel det shp 2 phs) + (evHead $ + PCS.controllerExponential controllerAttack (0.03,0.3) 0.1) + (PCS.controllerLinear controllerDetune (0,0.005) 0.001) + (evHead $ + PCS.controllerLinear controllerTimbre0 (0,1) 1) + (PCS.controllerExponential controllerTimbre1 (1/pi,0.001) 0.05) + (pure vcsize) + (PCS.bendWheelPressure 2 0.04 0.03) + sqr = evalState $ + App.lift6 (\rel -> sqr0 (4*rel) rel) + (evHead $ + PCS.controllerExponential controllerAttack (0.03,0.3) 0.1) + (PCS.controllerLinear controllerDetune (0,0.005) 0.001) + (PCS.controllerExponential controllerTimbre0 (1/pi,0.001) 0.05) + (PCS.controllerLinear controllerTimbre1 (0,0.25) 0.25) + (pure vcsize) + (PCS.bendWheelPressure 2 0.04 0.03) + tin = evalState $ + liftA3 (\rel -> tin0 (4*rel) rel) + (evHead $ + PCS.controllerExponential controllerAttack (0.03,0.3) 0.1) + (pure vcsize) + (PCS.bendWheelPressure 2 0.04 0.03) + tnc = evalState $ + App.lift6 (\rel -> tnc0 (4*rel) rel) + (evHead $ + PCS.controllerExponential controllerAttack (0.03,0.3) 0.1) + (PCS.controllerLinear controllerDetune (0,0.005) 0.001) + (fmap (fmap stair) $ + PCS.controllerLinear controllerTimbre0 (0.5,6.5) 2) + (PCS.controllerLinear controllerTimbre1 (0,1.5) 1) + (pure vcsize) + (PCS.bendWheelPressure 2 0.04 0.03) + fnd = evalState $ + pure (\rel -> fnd0 (4*rel) rel) + <*> (evHead $ + PCS.controllerExponential controllerAttack (0.03,0.3) 0.1) + <*> (PCS.controllerLinear controllerDetune (0,0.005) 0.001) + <*> (fmap (fmap stair) $ + PCS.controllerLinear controllerTimbre0 (0.5,20.5) 14) + <*> (PCS.controllerLinear controllerTimbre1 (0,1.5) 0.3) + <*> (PCS.controllerLinear controllerFMDepth1 (0,1) 0.25) + <*> (pure vcsize) + <*> (PCS.bendWheelPressure 2 0.04 0.03) + tnb = evalState $ + pure (\rel -> tnb0 (4*rel) rel) + <*> (evHead $ + PCS.controllerExponential controllerAttack (0.03,0.3) 0.1) + <*> (PCS.controllerLinear controllerDetune (0,0.005) 0.001) + <*> (PCS.controllerLinear controllerFMDepth1 (0,2) 0) + <*> (PCS.controllerLinear controllerFMDepth2 (0,2) 0) + <*> (PCS.controllerLinear controllerFMDepth3 (0,2) 0) + <*> (PCS.controllerLinear controllerFMDepth4 (0,2) 0) + <*> (PCS.controllerLinear controllerFMPartial1 (0,1) 1) + <*> (PCS.controllerLinear controllerFMPartial2 (0,1) 0) + <*> (PCS.controllerLinear controllerFMPartial3 (0,1) 0) + <*> (PCS.controllerLinear controllerFMPartial4 (0,1) 0) + <*> (pure vcsize) + <*> (PCS.bendWheelPressure 2 0.04 0.03) + rfm = evalState $ + pure (\rel -> rfm0 (4*rel) rel) + <*> (evHead $ + PCS.controllerExponential controllerAttack (0.03,0.3) 0.1) + <*> (PCS.controllerLinear controllerDetune (0,0.005) 0.001) + <*> (PCS.controllerExponential controllerTimbre1 (1,100) 30) + <*> (PCS.controllerLinear controllerTimbre0 (1,15) 3) + <*> (PCS.controllerExponential controllerFMDepth1 (0.005,0.5) 0.1) + <*> (pure vcsize) + <*> (PCS.bendWheelPressure 2 0.04 0.03) + bel = evalState $ + App.lift4 (\rel -> bel0 (2*rel) rel) + (evHead $ + PCS.controllerExponential controllerAttack (0.03,1.0) 0.3) + (PCS.controllerLinear controllerDetune (0,0.005) 0.001) + (pure vcsize) + (PCS.bendWheelPressure 2 0.05 0.02) + ben = evalState $ + App.lift5 (\rel -> ben0 (2*rel) rel) + (evHead $ + PCS.controllerExponential controllerAttack (0.03,1.0) 0.3) + (PCS.controllerLinear controllerTimbre0 (0,1) 0.3) + (PCS.controllerExponential controllerTimbre1 (1,1000) 100) + (pure vcsize) + (PCS.bendWheelPressure 2 0.05 0.02) + str = evalState $ + liftA3 str0 + (evHead $ + PCS.controllerExponential controllerAttack (0.02,2) 0.5) + (PCS.controllerLinear controllerDetune (0,0.01) 0.005) + (PCS.bendWheelPressure 2 0.04 0.03) + ssh = evalState $ + App.lift4 ssh0 + (evHead $ + PCS.controllerExponential controllerAttack (0.02,2) 0.5) + (PCS.controllerLinear controllerDetune (0,0.01) 0.005) + (PCS.controllerExponential controllerTimbre0 (1/pi,0.001) 0.05) + (PCS.bendWheelPressure 2 0.04 0.03) + makeArc gen = evalState $ + App.lift4 gen + (evHead $ + PCS.controllerExponential controllerAttack (0.02,2) 0.5) + (PCS.controllerLinear controllerDetune (0,0.01) 0.005) + (PCS.controllerLinear controllerTimbre0 (0.5,9.5) 1.5) + (PCS.bendWheelPressure 2 0.04 0.03) + css = makeArc css0 + asw = makeArc asw0 + asn = makeArc asn0 + asq = makeArc asq0 + atr = makeArc atr0 + fms = evalState $ + App.lift5 fms0 + (evHead $ + PCS.controllerExponential controllerAttack (0.02,2) 0.5) + (PCS.controllerLinear controllerDetune (0,0.01) 0.005) + (PCS.controllerLinear controllerTimbre0 (0,0.5) 0.2) + (PCS.controllerExponential controllerTimbre1 (0.001,10) 0.1) + (PCS.bendWheelPressure 2 0.04 0.03) + wnd = evalState $ + liftA3 wnd0 + (evHead $ + PCS.controllerExponential controllerAttack (0.02,2) 0.5) + (PCS.controllerExponential controllerTimbre1 (1,1000) 100) + (PCS.bendWheelPressure 12 0.8 0) + wnp = evalState $ + App.lift5 wnp0 + (evHead $ + PCS.controllerExponential controllerAttack (0.02,2) 0.5) + (PCS.controllerLinear controllerTimbre0 (0,1) 0.5) + (PCS.controllerExponential controllerDetune (50,5000) 500) + (PCS.controllerExponential controllerTimbre1 (1,1000) 100) + (PCS.bendWheelPressure 12 0.8 0) + brs = evalState $ + App.lift6 + (\rel det t0 peak -> brs0 (rel/2) 1.5 (rel/2) rel rel peak det t0) + (evHead $ + PCS.controllerExponential controllerAttack (0.01,0.1) 0.01) + (PCS.controllerLinear controllerDetune (0,0.01) 0.005) + (PCS.controllerExponential controllerTimbre0 (1/pi,0.001) 0.05) + (evHead $ + PCS.controllerLinear controllerTimbre1 (1,5) 3) + (pure vcsize) + (PCS.bendWheelPressure 2 0.04 0.03) + freqMod = + evalState + (PCS.bendWheelPressure 2 0.04 0.03) + + + volume <- + PC.controllerExponential chan + controllerVolume + (0.001, 1) 0.2 + + ctrls <- PCS.fromChannel chan + + fmap (pioApply (amp volume) . arrange vcsize) $ + Gen.sequenceModulatedMultiProgram + ctrls chan pgm + (map (\sound fm -> sound fm $ sr) $ + [tnc, fnd, pngFM, flt, bel, ben, sqr, brs, + ssh, fms, css, asn, atr, asq, asw, wnp] ++ + map (.freqMod) syllables ++ + [str, wnd, png, rfm, tin, tnb]) + + +keyboardDetuneFM :: IO () +keyboardDetuneFM = do + opt <- Option.get + proc <- keyboardDetuneFMCore (Option.sampleDirectory opt) + withMIDIEventsStereo opt play $ \vectorChunkSize sampleRate -> + evalState + (proc (Option.channel opt) (VoiceMsg.toProgram 0) + vectorChunkSize sampleRate) + +keyboardFilter :: IO () +keyboardFilter = do + opt <- Option.get + proc <- keyboardDetuneFMCore (Option.sampleDirectory opt) + mix <- CausalRender.run $ \xs -> + arr id + + + (Causal.map (StereoInt.amplify 0.5) + <<< + Causal.fromSignal xs) + + lowpass0 <- + CausalRender.run $ \cutoff -> + Causal.map StereoInt.interleave + <<< +-- CausalPS.amplifyStereo 0.1 <<< + CausalPS.pack + (Causal.stereoFromMonoControlled + (UniFilter.lowpass ^<< UniFilterL.causalExp) $< + Sig.interpolateConstant (fromIntegral vectorSize :: Exp Int) + (UniFilterL.unMultiValueParameter <$> piecewiseConstant cutoff)) + <<< + Causal.map StereoInt.deinterleave + let lowpass :: + Option.SampleRate Real -> PC.T Real -> PC.T Real -> + SigSt.T StereoVector -> SigSt.T StereoVector + lowpass (Option.SampleRate sr) resons freqs = + pioApply $ + lowpass0 $ fmap UniFilter.parameter $ + PC.zipWith FiltR.Pole resons $ fmap (/ sr) freqs + + withMIDIEventsStereo opt play $ \vectorChunkSize sampleRate -> + evalState + (do {- + It is important to retrieve the global controllers + before they are filtered out by PCS.fromChannel. + -} + let freqBnd v = 880 * 2^?(v/24) + freq <- + PC.controllerExponential (Option.extraChannel opt) + controllerFilterCutoff + (freqBnd (-64), freqBnd 63) 5000 + resonance <- + PC.controllerExponential (Option.extraChannel opt) + controllerFilterResonance + (1, 100) 1 + filterMusic <- + proc (Option.extraChannel opt) (VoiceMsg.toProgram 8) + vectorChunkSize sampleRate + pureMusic <- + proc (Option.channel opt) (VoiceMsg.toProgram 0) + vectorChunkSize sampleRate + return + (pioApply (mix pureMusic) $ + lowpass sampleRate resonance freq filterMusic)) diff --git a/alsa/Synthesizer/LLVM/Server/Packed/Test.hs b/alsa/Synthesizer/LLVM/Server/Packed/Test.hs new file mode 100644 --- /dev/null +++ b/alsa/Synthesizer/LLVM/Server/Packed/Test.hs @@ -0,0 +1,674 @@ +module Synthesizer.LLVM.Server.Packed.Test where + +import qualified Synthesizer.LLVM.Server.Packed.Instrument as Instr +import qualified Synthesizer.LLVM.Server.Default as Default +import qualified Synthesizer.LLVM.Server.SampledSound as Sample +import Synthesizer.LLVM.Server.Packed.Instrument (InputArg(Modulation)) +import Synthesizer.LLVM.Server.ALSA (makeNote) +import Synthesizer.LLVM.Server.CommonPacked (Vector, vectorSize) +import Synthesizer.LLVM.Server.Common hiding (Instrument) + +import qualified Sound.ALSA.Sequencer.Event as Event +import qualified Synthesizer.MIDI.PiecewiseConstant as PC +import qualified Synthesizer.MIDI.Generic as Gen + +import qualified Synthesizer.LLVM.Frame.Stereo as Stereo +import qualified Synthesizer.LLVM.Frame.SerialVector.Plain as Serial + +import qualified Synthesizer.ALSA.Storable.Play as Play +import Synthesizer.MIDI.Storable (Instrument, chunkSizesFromLazyTime) + +import qualified Synthesizer.LLVM.MIDI.BendModulation as BM +import qualified Synthesizer.LLVM.Causal.ProcessPacked as CausalPS +import qualified Synthesizer.LLVM.Causal.Render as CausalRender +import qualified Synthesizer.LLVM.Causal.Process as Causal +import qualified Synthesizer.LLVM.Generator.SignalPacked as SigPS +import qualified Synthesizer.LLVM.Generator.Render as Render +import qualified Synthesizer.LLVM.Storable.Signal as SigStL +import Synthesizer.LLVM.Causal.Process (($*)) + +import qualified Synthesizer.Storable.Cut as CutSt +import qualified Synthesizer.Storable.Signal as SigSt +import qualified Data.StorableVector.Lazy.Pattern as SVP +import qualified Data.StorableVector.Lazy as SVL + +import qualified Data.EventList.Relative.TimeBody as EventList +import qualified Data.EventList.Relative.BodyTime as EventListBT + +import Control.Arrow ((<<<), arr) +import Control.Applicative (pure, liftA, liftA2, (<$>)) +import Control.Monad.Trans.State (evalState) + +import qualified Numeric.NonNegative.Wrapper as NonNegW +import qualified Numeric.NonNegative.Chunky as NonNegChunky + +import Algebra.IntegralDomain (divUp) + +import qualified Number.DimensionTerm as DN + +import Prelude hiding (Real, round, break) + + +chunkSize :: SVL.ChunkSize +chunkSize = Play.defaultChunkSize + +vectorChunkSize :: SVL.ChunkSize +vectorChunkSize = + case chunkSize of + SVL.ChunkSize size -> + SVL.ChunkSize (divUp size vectorSize) + +sampleRatePlain :: Num a => a +sampleRatePlain = case Default.sampleRate of SampleRate r -> r + +sampleRate :: SampleRate Real +sampleRate = Default.sampleRate + + +emptyEvents :: time -> EventList.T time [Event.T] +emptyEvents t = + let evs = EventList.cons t [] evs + in evs + + +{- | +try to reproduce a space leak +-} +sequencePlain :: IO () +sequencePlain = + SVL.writeFile "test.f32" $ +-- print $ last $ SVL.chunks $ + CutSt.arrange chunkSize $ + evalState (Gen.sequence Default.channel (error "no sound" :: Instrument Real Real)) $ + emptyEvents 10 + +sequenceLLVM :: IO () +sequenceLLVM = do + arrange <- SigStL.makeArranger + SVL.writeFile "test.f32" $ +-- print $ last $ SVL.chunks $ + arrange vectorChunkSize $ + evalState (Gen.sequence Default.channel (error "no sound" :: Instrument Real Vector)) $ + emptyEvents 10 + +sequencePitchBendCycle :: IO () +sequencePitchBendCycle = do + arrange <- SigStL.makeArranger + SVL.writeFile "test.f32" $ + arrange vectorChunkSize $ + evalState + (let -- fm = error "undefined pitch bend" + fm = EventListBT.cons 1 10 fm + in Gen.sequenceModulated fm Default.channel + (error "no sound" :: + PC.T Real -> Instrument Real Vector)) $ + emptyEvents 10 + +sequencePitchBendSimple :: IO () +sequencePitchBendSimple = do + arrange <- SigStL.makeArranger + SVL.writeFile "test.f32" $ + arrange vectorChunkSize $ + evalState + (let fm y = EventListBT.cons y 10 (fm (2-y)) + in Gen.sequenceModulated (fm 1) Default.channel + (error "no sound" :: + PC.T Real -> Instrument Real Vector)) $ + emptyEvents 10 + +sequencePitchBend :: IO () +sequencePitchBend = do + arrange <- SigStL.makeArranger + SVL.writeFile "test.f32" $ + arrange vectorChunkSize $ + evalState + (do fm <- PC.pitchBend Default.channel 2 0.01 + Gen.sequenceModulated fm Default.channel + (error "no sound" :: + PC.T Real -> Instrument Real Vector)) $ + emptyEvents 10 + +sequenceModulated :: IO () +sequenceModulated = do + arrange <- SigStL.makeArranger + SVL.writeFile "test.f32" $ + arrange vectorChunkSize $ + evalState + (do fm <- PC.bendWheelPressure Default.channel 2 0.04 0.03 + Gen.sequenceModulated fm Default.channel + (error "no sound" :: + PC.T (BM.T Real) -> + Instrument Real Vector)) $ + emptyEvents 10 + +sequenceModulatedLong :: IO () +sequenceModulatedLong = do + arrange <- SigStL.makeArranger +-- sound <- Instr.softStringReleaseEnvelope $/ sampleRate + sound <- Instr.softString $/ sampleRate -- space leak +-- sound <- Instr.pingReleaseEnvelope $/ 1 $/ sampleRate -- no space leak +-- sound <- Instr.pingRelease $/ 1 $/ 1 $/ sampleRate -- no space leak + SVL.writeFile "test.f32" $ + arrange vectorChunkSize $ + evalState (Gen.sequence Default.channel sound) $ + let evs t = EventList.cons t [] (evs (20-t)) + in EventList.cons 10 [makeNote Event.NoteOn 60] $ + EventList.cons 10 [makeNote Event.NoteOn 64] $ + evs 10 + +sequenceModulatedLongFM :: IO () +sequenceModulatedLongFM = do + arrange <- SigStL.makeArranger + sound <- Instr.softStringFM + SVL.writeFile "test.f32" $ + arrange vectorChunkSize $ + evalState + (do fm <- PC.bendWheelPressure Default.channel 2 0.04 0.03 + Gen.sequenceModulated fm Default.channel + (\fmlocal -> sound fmlocal $ sampleRate)) $ + let evs t = EventList.cons t [] (evs (20-t)) + in EventList.cons 10 [makeNote Event.NoteOn 60] $ + EventList.cons 10 [makeNote Event.NoteOn 64] $ + evs 10 + +sequenceModulatedRepeat :: IO () +sequenceModulatedRepeat = do + arrange <- SigStL.makeArranger + sound <- Instr.softStringFM + SVL.writeFile "test.f32" $ + arrange vectorChunkSize $ + evalState + (do fm <- PC.bendWheelPressure Default.channel 2 0.04 0.03 + Gen.sequenceModulated fm Default.channel + (\fmlocal -> sound fmlocal $ sampleRate)) $ + let evs t = + EventList.cons t [makeNote Event.NoteOn 60] $ + EventList.cons t [makeNote Event.NoteOff 60] $ + evs (20-t) + in evs 10 + +sequencePress :: IO () +sequencePress = do + arrange <- SigStL.makeArranger +-- sound <- Instr.softString $/ sampleRate +-- sound <- Instr.softStringReleaseEnvelope $/ sampleRate + sound <- Instr.pingReleaseEnvelope $/ 1 $/ 1 $/ vectorChunkSize $/ sampleRate + SVL.writeFile "test.f32" $ + arrange vectorChunkSize $ + evalState + (Gen.sequence Default.channel (\ _freq -> sound)) $ + let evs t = + EventList.cons t [makeNote Event.NoteOn 60] $ + EventList.cons t [makeNote Event.NoteOff 60] $ + evs (20-t) + in evs 10 + + +sampledSoundTest0 :: + IO (Sample.T -> + PC.T (BM.T Real) -> + Instrument Real (Stereo.T Vector)) +sampledSoundTest0 = + liftA + (\osc smp _fm _vel _freq _dur -> + osc chunkSize (Sample.body smp)) + (Render.run $ \smp -> + fmap (\x -> Stereo.consMultiValue x x) $ SigPS.pack smp) + +sampledSoundTest1 :: + IO (Sample.T -> + PC.T (BM.T Real) -> + Instrument Real (Stereo.T Vector)) +sampledSoundTest1 = + liftA + (\osc smp _fm _vel _freq _dur -> + osc chunkSize (Sample.body smp)) + (Render.run $ \smp -> + Stereo.multiValue <$> + Causal.stereoFromMono + (CausalPS.pack (Causal.frequencyModulationLinear smp)) + $* liftA2 Stereo.cons + (SigPS.constant 0.999) + (SigPS.constant 1.001)) +-- $* (SigPS.constant $# Stereo.cons 0.999 1.001))) + +sampledSoundTest2 :: + IO (Sample.T -> + PC.T (BM.T Real) -> + Instrument Real (Stereo.T Vector)) +sampledSoundTest2 = + liftA + (\osc smp fm _vel freq dur -> + let pos = Sample.positions smp + body = + SigSt.take (Sample.length pos) $ + SigSt.drop (Sample.start pos) $ + Sample.body smp + in SVP.take (chunkSizesFromLazyTime dur) $ + osc chunkSize sampleRate body (fm, freq * Sample.period pos)) + (Render.run $ + wrapped $ \(Signal smp) (Modulation fm) -> + constant frequency 3 $ \speed _sr -> + Stereo.multiValue <$> + ((Causal.stereoFromMono + (CausalPS.pack (Causal.frequencyModulationLinear smp)) + <<< + liftA2 Stereo.cons + (CausalPS.amplify 0.999) + (CausalPS.amplify 1.001)) + $* Instr.frequencyFromBendModulation speed fm)) + +sampledSoundTest3SpaceLeak :: + IO (Sample.T -> + PC.T (BM.T Real) -> + Instrument Real (Stereo.T Vector)) +sampledSoundTest3SpaceLeak = + liftA + (\osc smp _fm vel freq dur -> + {- + We split the frequency modulation signal + in order to get a smooth frequency modulation curve. + Without (periodic) frequency modulation + we could just split the piecewise constant control curve @fm@. + -} + let sustainFM, releaseFM :: SigSt.T Vector + (sustainFM, releaseFM) = + SVP.splitAt (chunkSizesFromLazyTime dur) $ + SigSt.repeat chunkSize + (Serial.replicate (freq*Sample.period pos/sampleRatePlain)) + pos = Sample.positions smp + amp = 2 * amplitudeFromVelocity vel + (attack, sustain, release) = Sample.parts smp + in pioApply + (osc amp + (attack `SigSt.append` + SVL.cycle (SigSt.take (Sample.loopLength pos) sustain))) + sustainFM + `SigSt.append` + pioApply (osc amp release) releaseFM) + (CausalRender.run $ \amp smp -> + Stereo.multiValue <$> + (CausalPS.amplifyStereo amp + <<< + Causal.stereoFromMono + (CausalPS.pack + (Causal.frequencyModulationLinear smp)) + <<< + liftA2 Stereo.cons + (CausalPS.amplify 0.999) + (CausalPS.amplify 1.001))) + +sampledSoundTest4NoSpaceLeak :: + IO (Sample.T -> + PC.T (BM.T Real) -> + Instrument Real (Stereo.T Vector)) +sampledSoundTest4NoSpaceLeak = + liftA + (\freqMod smp fm _vel freq dur -> + {- + We split the frequency modulation signal + in order to get a smooth frequency modulation curve. + Without (periodic) frequency modulation + we could just split the piecewise constant control curve @fm@. + -} + let sustainFM, releaseFM :: SigSt.T Vector + (sustainFM, releaseFM) = + SVP.splitAt (chunkSizesFromLazyTime dur) $ + pioApplyToLazyTime + (freqMod sampleRate (fm, freq*Sample.period pos)) + (PC.duration fm) + pos = Sample.positions smp + in SigSt.map + (\x -> Stereo.cons x x) + (sustainFM `SigSt.append` releaseFM)) + (CausalRender.run $ + wrapped $ \(Modulation fm) -> + constant frequency 3 $ \speed _sr -> + Causal.fromSignal $ Instr.frequencyFromBendModulation speed fm) + +sampledSoundTest5LargeSpaceLeak :: + IO (Sample.T -> + PC.T (BM.T Real) -> + Instrument Real (Stereo.T Vector)) +sampledSoundTest5LargeSpaceLeak = + liftA2 + (\osc freqMod smp fm vel freq dur -> + {- + We split the frequency modulation signal + in order to get a smooth frequency modulation curve. + Without (periodic) frequency modulation + we could just split the piecewise constant control curve @fm@. + -} + let sustainFM, releaseFM :: SigSt.T Vector + (sustainFM, releaseFM) = + SVP.splitAt (chunkSizesFromLazyTime dur) $ + pioApplyToLazyTime + (freqMod sampleRate (fm, freq*Sample.period pos)) + (PC.duration fm) + pos = Sample.positions smp + amp = 2 * amplitudeFromVelocity vel + (attack, sustain, release) = Sample.parts smp + in pioApply + (osc amp + (attack `SigSt.append` + SVL.cycle (SigSt.take (Sample.loopLength pos) sustain))) + sustainFM + `SigSt.append` + pioApply (osc amp release) releaseFM) + (CausalRender.run $ \ _amp _smp -> arr (\x -> Stereo.consMultiValue x x)) + (CausalRender.run $ + wrapped $ \(Modulation fm) -> + constant frequency 3 $ \speed _sr -> + Causal.fromSignal $ Instr.frequencyFromBendModulation speed fm) + + +sampledSoundSmallSpaceLeak4 :: + IO (Sample.T -> + PC.T (BM.T Real) -> + Instrument Real (Stereo.T Vector)) +sampledSoundSmallSpaceLeak4 = + liftA + (\osc smp _fm _vel freq dur -> + let sustainFM, releaseFM :: SigSt.T Vector + (sustainFM, releaseFM) = + SVP.splitAt (chunkSizesFromLazyTime dur) $ + SigSt.repeat chunkSize + (Serial.replicate (freq*Sample.period pos/sampleRatePlain)) + pos = Sample.positions smp + in pioApply osc sustainFM + `SigSt.append` + SigSt.map (\x -> Stereo.cons x x) releaseFM) + (CausalRender.run $ arr (\x -> Stereo.consMultiValue x x)) + +sampledSoundSmallSpaceLeak4a :: + IO (Sample.T -> + PC.T (BM.T Real) -> + Instrument Real (Stereo.T Vector)) +sampledSoundSmallSpaceLeak4a = + liftA + (\osc smp _fm _vel freq dur -> + case SVP.splitAt (chunkSizesFromLazyTime dur) $ + SigSt.repeat chunkSize + (Serial.replicate (freq*Sample.period (Sample.positions smp) / sampleRatePlain)) of + (sustainFM, releaseFM) -> + pioApply osc (sustainFM :: SigSt.T Vector) + `SigSt.append` + SigSt.map (\x -> Stereo.cons x x) releaseFM) + (CausalRender.run $ arr (\x -> Stereo.consMultiValue x x)) + +sampledSoundNoSmallSpaceLeak3 :: + IO (Sample.T -> + PC.T (BM.T Real) -> + Instrument Real (Stereo.T Vector)) +sampledSoundNoSmallSpaceLeak3 = + pure + (\smp _fm _vel freq dur -> + let sustainFM, releaseFM :: SigSt.T Vector + (sustainFM, releaseFM) = + SVP.splitAt (chunkSizesFromLazyTime dur) $ + SigSt.repeat chunkSize + (Serial.replicate (freq*Sample.period pos/sampleRatePlain)) + pos = Sample.positions smp + in SigSt.map (\x -> Stereo.cons x x) sustainFM + `SigSt.append` + SigSt.map (\x -> Stereo.cons x x) releaseFM) + +{-# NOINLINE amplifySVL #-} +amplifySVL :: SVL.Vector Vector -> SVL.Vector Vector +amplifySVL = SigSt.map (2*) + +sampledSoundNoSmallSpaceLeak2 :: + IO (Sample.T -> + PC.T (BM.T Real) -> + Instrument Real (Stereo.T Vector)) +sampledSoundNoSmallSpaceLeak2 = + liftA + (\osc smp _fm _vel freq dur -> + let sustainFM, releaseFM :: SigSt.T Vector + (sustainFM, releaseFM) = + SVP.splitAt (chunkSizesFromLazyTime dur) $ + SigSt.repeat chunkSize + (Serial.replicate (freq*Sample.period pos/sampleRatePlain)) + pos = Sample.positions smp + in pioApply osc + (amplifySVL sustainFM + `SigSt.append` + amplifySVL releaseFM)) + (CausalRender.run $ arr (\x -> Stereo.consMultiValue x x)) + +sampledSoundSmallSpaceLeak1 :: + IO (Sample.T -> + PC.T (BM.T Real) -> + Instrument Real (Stereo.T Vector)) +sampledSoundSmallSpaceLeak1 = + liftA + (\osc smp _fm _vel freq dur -> + let sustainFM, releaseFM :: SigSt.T Vector + (sustainFM, releaseFM) = + SVP.splitAt (chunkSizesFromLazyTime dur) $ + SigSt.repeat chunkSize + (Serial.replicate (freq*Sample.period pos/sampleRatePlain)) + pos = Sample.positions smp + in pioApply osc sustainFM + `SigSt.append` + pioApply osc releaseFM) + (CausalRender.run $ arr (\x -> Stereo.consMultiValue x x)) + +sampledSoundSmallSpaceLeak0 :: + IO (Sample.T -> + PC.T (BM.T Real) -> + Instrument Real (Stereo.T Vector)) +sampledSoundSmallSpaceLeak0 = + liftA + (\osc smp _fm vel freq dur -> + {- + We split the frequency modulation signal + in order to get a smooth frequency modulation curve. + Without (periodic) frequency modulation + we could just split the piecewise constant control curve @fm@. + -} + let sustainFM, releaseFM :: SigSt.T Vector + (sustainFM, releaseFM) = + SVP.splitAt (chunkSizesFromLazyTime dur) $ + SigSt.repeat chunkSize + (Serial.replicate (freq*Sample.period pos/sampleRatePlain)) + pos = Sample.positions smp + amp = 2 * amplitudeFromVelocity vel + (attack, sustain, release) = Sample.parts smp + in pioApply + (osc amp + (attack `SigSt.append` + SVL.cycle (SigSt.take (Sample.loopLength pos) sustain))) + sustainFM + `SigSt.append` + pioApply (osc amp release) releaseFM) + (CausalRender.run $ \ _amp _smp -> arr (\x -> Stereo.consMultiValue x x)) + +makeSample :: Int -> Sample.T +makeSample size = + Sample.Cons + (SigSt.replicate chunkSize size 0) + (DN.frequency 44100) + (Sample.Positions 0 100000 50000 50000 100) + +sequenceSample :: IO () +sequenceSample = do + arrange <- SigStL.makeArranger + sampler <- sampledSoundTest2 + let sound = sampler $ makeSample 100000 + SVL.writeFile "test.f32" $ + arrange vectorChunkSize $ + evalState + (do fm <- PC.bendWheelPressure Default.channel 2 0.04 0.03 + Gen.sequenceModulated fm Default.channel sound) $ + let evs t = EventList.cons t [] (evs (20-t)) + in EventList.cons 10 [makeNote Event.NoteOn 60] $ + evs 10 + +{- +sequenceSample1 :: IO () +sequenceSample1 = do + sampler <- Instr.sampledSound + let sound = + sampler (SampledSound (SigSt.replicate chunkSize 100000 0) + (SamplePositions 0 100000 50000 50000) + 100) + SVL.writeFile "test.f32" $ + sound +{- + (let evs f = + EventListBT.cons (BM.Cons 0.001 f) 10 (evs (0.02-f)) + in evs 0.01) +-} + (let evs t = + EventListBT.cons (BM.Cons 0.01 0.001) t (evs (20-t)) + in evs 10) +{- + (PCS.Cons + (Map.singleton + (PC.Controller VoiceMsg.modulation) 1) + (let evs t = EventList.cons t [] (evs (20-t)) + in EventListMT.consTime 10 $ evs 10)) +-} + 0.01 1 +-- (NonNegChunky.fromChunks $ repeat $ NonNegW.fromNumber 10) + (NonNegChunky.fromChunks $ map NonNegW.fromNumber $ iterate (20-) 10) +-} + +sequenceSample1 :: IO () +sequenceSample1 = do + sampler <- sampledSoundSmallSpaceLeak4a + let sound = sampler $ makeSample 100000 + SVL.writeFile "test.f32" $ + sound + (let evs = EventListBT.cons (BM.Cons 0.01 0.001) 1 evs + in evs) + 0.01 1 + (NonNegChunky.fromChunks $ repeat $ NonNegW.fromNumber 10) + +{- +sequenceSample1a :: IO () +sequenceSample1a = do +{- + makeStereoLLVM <- + CausalP.runStorableChunky2 -- NoSpaceLeak + (arr (\x -> Stereo.cons x x)) + let stereoLLVM = makeStereoLLVM () +-} + stereoLLVM <- CausalP.runStorableChunky3 + let stereoPlain = SigSt.map (\x -> Stereo.cons x x) + SVL.writeFile "test.f32" $ + let dur = NonNegChunky.fromChunks $ repeat $ SVL.chunkSize 10 + sustainFM, releaseFM :: SigSt.T Vector + !(sustainFM, releaseFM) = + SVP.splitAt dur $ + SigSt.repeat chunkSize (Serial.replicate 1) + in case 3::Int of + -- no leak + 0 -> stereoLLVM $ sustainFM `SigSt.append` releaseFM + -- no leak + 1 -> stereoPlain $ sustainFM `SigSt.append` releaseFM + -- no leak + 2 -> stereoPlain sustainFM `SigSt.append` stereoPlain releaseFM + -- leak + 3 -> stereoLLVM sustainFM `SigSt.append` stereoPlain releaseFM + -- no leak + 4 -> stereoPlain sustainFM `SigSt.append` stereoLLVM releaseFM + -- leak + 5 -> stereoLLVM sustainFM `SigSt.append` stereoLLVM releaseFM +-} + +sequenceSample2 :: IO () +sequenceSample2 = do + arrange <- SigStL.makeArranger + sampler <- sampledSoundTest2 + let sound = sampler $ makeSample 100000 + SVL.writeFile "test.f32" $ + arrange vectorChunkSize $ + evalState + (do bend <- PC.pitchBend Default.channel 2 0.01 + let fm = fmap (\t -> BM.Cons t t) bend + Gen.sequenceModulated fm Default.channel sound) $ + let evs t = EventList.cons t [] (evs (20-t)) + in EventList.cons 10 [makeNote Event.NoteOn 60] $ + evs 10 + +{- +Interestingly, when the program aborts because of heap exhaustion, +then the generated file has size 137MB independent of the heap size +(I tried sizes from 1MB to 64MB). +-} +sequenceSample3 :: IO () +sequenceSample3 = do + arrange <- SigStL.makeArranger + sampler <- sampledSoundTest2 + let sound = sampler $ makeSample 100000 + SVL.writeFile "test.f32" $ + arrange vectorChunkSize $ + evalState + (let evs = + EventListBT.cons (BM.Cons 0.01 0.001) 10 evs + in Gen.sequence Default.channel (sound evs)) $ + let evs = EventList.cons 10 [] evs + in EventList.cons 10 [makeNote Event.NoteOn 60] evs + +sequenceSample4 :: IO () +sequenceSample4 = do + arrange <- SigStL.makeArranger + sampler <- Instr.sampledSound +-- sampler <- sampledSoundTest2 + let sound = sampler $ makeSample 100000 + SVL.writeFile "test.f32" $ + arrange vectorChunkSize $ + evalState + (let evs = EventListBT.cons (BM.Cons 0.01 0.001) 10 evs + in Gen.sequenceCore + Default.channel Gen.errorNoProgram + (Gen.Modulator () return + (return . Gen.renderInstrumentIgnoreProgram (sound evs sampleRate)))) $ + let evs = EventList.cons 10 [] evs + in EventList.cons 10 [makeNote Event.NoteOn 60] evs + +sequenceFM1 :: IO () +sequenceFM1 = do + arrange <- SigStL.makeArranger + sound <- Instr.softStringFM $/ + let evs = EventListBT.cons (BM.Cons 0.01 0.001) 10 evs + in evs +-- sound <- Instr.softStringReleaseEnvelope + SVL.writeFile "test.f32" $ + arrange vectorChunkSize $ + evalState + (Gen.sequenceCore + Default.channel Gen.errorNoProgram + (Gen.Modulator () return + (return . Gen.renderInstrumentIgnoreProgram (sound sampleRate)))) $ + let evs = EventList.cons 10 [] evs + in EventList.cons 10 [makeNote Event.NoteOn 60] evs +{- + sound + 0.01 1 + (NonNegChunky.fromChunks $ map NonNegW.fromNumber $ iterate (20-) 10) +-} + + +adsr :: IO () +adsr = do + env <- Instr.adsr + SVL.writeFile "adsr.f32" $ + env 0.2 2 0.15 0.3 0.5 vectorChunkSize sampleRate (-0.5) 88200 + + +constCtrl :: a -> PC.T a +constCtrl x = + let xs = EventListBT.cons x 10000 xs + in xs + +bellNoiseStereoTest :: IO () +bellNoiseStereoTest = do + str <- Instr.bellNoiseStereoFM + SVL.writeFile "bellnoise.f32" $ + str 0.3 0.1 (constCtrl 0.3) (constCtrl 100) + vectorChunkSize + (constCtrl (BM.Cons 1 0.01)) sampleRate 0 440 + 100000 diff --git a/alsa/Synthesizer/LLVM/Server/Scalar/Run.hs b/alsa/Synthesizer/LLVM/Server/Scalar/Run.hs new file mode 100644 --- /dev/null +++ b/alsa/Synthesizer/LLVM/Server/Scalar/Run.hs @@ -0,0 +1,157 @@ +module Synthesizer.LLVM.Server.Scalar.Run where + +import qualified Synthesizer.LLVM.Server.Scalar.Instrument as Instr +import qualified Synthesizer.LLVM.Server.Option as Option +import Synthesizer.LLVM.Server.ALSA (Output, play, startMessage) +import Synthesizer.LLVM.Server.CausalPacked.Common (transposeModulation) +import Synthesizer.LLVM.Server.Common hiding (transposeModulation) + +import qualified Sound.ALSA.Sequencer.Event as Event +import qualified Data.EventList.Relative.TimeBody as EventList + +import qualified Synthesizer.LLVM.MIDI.BendModulation as BM +import qualified Synthesizer.LLVM.MIDI as MIDIL +import qualified Synthesizer.LLVM.Frame.Stereo as Stereo +import qualified Synthesizer.LLVM.Causal.Render as CausalRender +import qualified Synthesizer.LLVM.Causal.Process as Causal +import qualified Synthesizer.LLVM.Generator.Render as Render +import qualified Synthesizer.LLVM.Storable.Signal as SigStL +import qualified Synthesizer.LLVM.Wave as WaveL +import Synthesizer.LLVM.Causal.Process (($<), ($*)) + +import qualified Synthesizer.Storable.Signal as SigSt + +import qualified Synthesizer.ALSA.EventList as Ev + +import qualified Synthesizer.MIDI.PiecewiseConstant as PC +import qualified Synthesizer.MIDI.Generic as Gen + +import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg + +import Control.Arrow ((^<<), (<<^)) +import Control.Monad.Trans.State (evalState) +import Control.Applicative ((<$>)) + +import Control.Exception (bracket) + +import NumericPrelude.Numeric (fromIntegral, zero, (*), (*>), (/)) +import NumericPrelude.Base +import Prelude (Double) + + +{-# INLINE withMIDIEvents #-} +withMIDIEvents :: + Option.T -> + Output handle signal a -> + (SigSt.ChunkSize -> SampleRate Real -> + EventList.T Ev.StrictTime [Event.T] -> signal) -> IO a +withMIDIEvents opt output process = do + putStrLn startMessage + case output opt of + (open,close,write) -> + bracket open (close . snd) $ \((chunkSize,rate),h) -> + let rrate = fromIntegral rate :: Double + in Ev.withMIDIEvents + (Option.clientName opt) + (fromIntegral chunkSize / rrate) + rrate + (write h . + process (SigSt.chunkSize chunkSize) + (Option.SampleRate $ fromIntegral rate)) + + + +pitchBend :: IO () +pitchBend = do + opt <- Option.get + osc <- + Render.run $ \fm -> + Causal.osci WaveL.triangle $< zero $* piecewiseConstant fm + withMIDIEvents opt play $ \chunkSize sampleRate -> + (id :: SigSt.T Real -> SigSt.T Real) . + osc chunkSize . + evalState (PC.pitchBend (Option.channel opt) 2 (frequency sampleRate 880)) + + +frequencyModulation :: IO () +frequencyModulation = do + opt <- Option.get + osc <- + Render.run $ + constant frequency 10 $ \speed _sr fm -> + Causal.osci WaveL.triangle + $< zero + $* (MIDIL.frequencyFromBendModulation speed + $* piecewiseConstant (fmap BM.unMultiValue <$> fm)) + withMIDIEvents opt play $ \chunkSize sampleRate -> + (id :: SigSt.T Real -> SigSt.T Real) . + osc chunkSize sampleRate . transposeModulation sampleRate 880 . + evalState (PC.bendWheelPressure (Option.channel opt) 2 0.04 (0.03::Real)) + + + +keyboard :: IO () +keyboard = do + opt <- Option.get +-- sound <- Instr.pingDur +{- + sound <- + fmap (\s vel _freq dur -> s vel dur) $ + (Instr.pingReleaseEnvelope $/ 0.4 $/ 0.1) +-} + sound <- Instr.pingRelease $/ 0.4 $/ 0.1 + amp <- CausalRender.run Causal.amplify + arrange <- SigStL.makeArranger + withMIDIEvents opt play $ \chunkSize sampleRate -> + pioApply (amp (0.2 :: Real)) . + arrange chunkSize . + evalState + (Gen.sequence + (Option.channel opt) + (sound chunkSize sampleRate)) + +keyboardStereo :: IO () +keyboardStereo = do + opt <- Option.get + sound <- Instr.pingStereoRelease $/ 0.4 $/ 0.1 + amp <- + CausalRender.run $ \vol -> + Stereo.multiValue ^<< Causal.amplifyStereo vol <<^ Stereo.unMultiValue + arrange <- SigStL.makeArranger + withMIDIEvents opt play $ \chunkSize sampleRate -> + pioApply (amp (0.2 :: Real)) . + arrange chunkSize . + evalState + (Gen.sequence + (Option.channel opt) + (sound chunkSize sampleRate)) + +keyboardMulti :: IO () +keyboardMulti = do + opt <- Option.get + png <- Instr.pingDur + pngRel <- Instr.pingRelease $/ 0.4 $/ 0.1 $/ Option.chunkSize opt + tin <- Instr.tine $/ 0.4 $/ 0.1 $/ Option.chunkSize opt + arrange <- SigStL.makeArranger + withMIDIEvents opt play $ \chunkSize sampleRate -> +-- playALSA (Bld.put :: Int16 -> Bld.Builder Int16) (sampleRate opt::Real) . + SigSt.map (0.2*) . + arrange chunkSize . + evalState (Gen.sequenceMultiProgram (Option.channel opt) + (VoiceMsg.toProgram 2) + (map ($ sampleRate) [png, pngRel, tin])) + +keyboardStereoMulti :: IO () +keyboardStereoMulti = do + opt <- Option.get + png <- Instr.pingStereoRelease $/ 0.4 $/ 0.1 + tin <- Instr.tineStereo $/ 0.4 $/ 0.1 + str <- Instr.softString + arrange <- SigStL.makeArranger + withMIDIEvents opt play $ \chunkSize sampleRate -> +-- playALSA (Bld.put :: Int16 -> Bld.Builder Int16) (sampleRate opt::Real) . + SigSt.map ((0.2::Real)*>) . + arrange chunkSize . + evalState (Gen.sequenceMultiProgram (Option.channel opt) + (VoiceMsg.toProgram 1) + (map (\sound -> sound chunkSize sampleRate) [png, tin, const str])) diff --git a/alsa/Synthesizer/LLVM/Server/Scalar/Test.hs b/alsa/Synthesizer/LLVM/Server/Scalar/Test.hs new file mode 100644 --- /dev/null +++ b/alsa/Synthesizer/LLVM/Server/Scalar/Test.hs @@ -0,0 +1,88 @@ +module Synthesizer.LLVM.Server.Scalar.Test where + +import qualified Synthesizer.LLVM.Server.Scalar.Instrument as Instr +import qualified Synthesizer.LLVM.Server.Option as Option +import qualified Synthesizer.LLVM.Server.Default as Default +import Synthesizer.LLVM.Server.Scalar.Run (withMIDIEvents) +import Synthesizer.LLVM.Server.ALSA (record, put, makeNote) +import Synthesizer.LLVM.Server.Common + +import qualified Synthesizer.ALSA.Storable.Play as Play +import qualified Sound.ALSA.Sequencer.Event as Event + +import qualified Synthesizer.MIDI.PiecewiseConstant as PC +import qualified Synthesizer.MIDI.Generic as Gen + +import qualified Synthesizer.LLVM.Causal.Process as Causal +import qualified Synthesizer.LLVM.Generator.Render as Render +import qualified Synthesizer.LLVM.Wave as WaveL +import Synthesizer.LLVM.Causal.Process (($<), ($*)) + +import qualified Synthesizer.Storable.Cut as CutSt +import qualified Synthesizer.Storable.Signal as SigSt +import qualified Data.StorableVector.Lazy as SVL + +import qualified Data.EventList.Relative.TimeBody as EventList + +import Control.Monad.Trans.State (evalState) + +import NumericPrelude.Numeric (zero) +import Prelude hiding (Real) + + +chunkSize :: SVL.ChunkSize +chunkSize = Play.defaultChunkSize + +sampleRate :: SampleRate Real +sampleRate = Default.sampleRate + + +pitchBend0 :: IO () +pitchBend0 = do + osc <- + Render.run $ \fm -> + Causal.osci WaveL.triangle $< zero $* piecewiseConstant fm + SVL.writeFile "test.f32" $ + (id :: SigSt.T Real -> SigSt.T Real) . + osc chunkSize . + evalState (PC.pitchBend Default.channel 2 (frequency sampleRate 880)) $ + let evs = EventList.cons 100 [] evs + in EventList.cons 0 ([]::[Event.T]) evs + +pitchBend1 :: IO () +pitchBend1 = do + opt <- Option.get + osc <- + Render.run $ \fm -> + Causal.osci WaveL.triangle $< zero $* piecewiseConstant fm + withMIDIEvents opt (record "test.f32") $ \ _size _rate -> + (id :: SigSt.T Real -> SigSt.T Real) . + osc chunkSize . + evalState (PC.pitchBend Default.channel 2 (frequency sampleRate 880)) + +pitchBend2 :: IO () +pitchBend2 = do + opt <- Option.get + withMIDIEvents opt put $ \ _size _rate -> id + + + +sequencePress :: IO () +sequencePress = do +-- arrange <- SigStL.makeArranger +-- sound <- Instr.softString +-- sound <- Instr.softStringReleaseEnvelope +-- sound <- Instr.pingReleaseEnvelope $/ 1 $/ chunkSize +-- sound <- Instr.pingDur +-- sound <- Instr.pingDurTake + let sound = Instr.dummy chunkSize Default.sampleRate + SVL.writeFile "test.f32" $ + CutSt.arrange chunkSize $ + evalState + (do Gen.sequence Default.channel sound) $ + let evs t = + EventList.cons t [makeNote Event.NoteOn 60] $ + EventList.cons t [makeNote Event.NoteOff 60] $ + evs (20-t) + in evs 10 + diff --git a/example/Synthesizer/LLVM/ExampleUtility.hs b/example/Synthesizer/LLVM/ExampleUtility.hs new file mode 100644 --- /dev/null +++ b/example/Synthesizer/LLVM/ExampleUtility.hs @@ -0,0 +1,29 @@ +module Synthesizer.LLVM.ExampleUtility where + +import qualified Synthesizer.LLVM.Frame.SerialVector as Serial +import qualified Synthesizer.LLVM.Frame.Stereo as Stereo + +import Type.Data.Num.Decimal (D4, D16) + +import Data.Word (Word32) + + +type Id a = a -> a + +asMono :: Id (vector Float) +asMono = id + +asStereo :: Id (vector (Stereo.T Float)) +asStereo = id + +asMonoPacked :: Id (vector (Serial.T D4 Float)) +asMonoPacked = id + +asMonoPacked16 :: Id (vector (Serial.T D16 Float)) +asMonoPacked16 = id + +asWord32 :: Id (vector Word32) +asWord32 = id + +asWord32Packed :: Id (vector (Serial.T D4 Word32)) +asWord32Packed = id diff --git a/example/Synthesizer/LLVM/LAC2011.hs b/example/Synthesizer/LLVM/LAC2011.hs new file mode 100644 --- /dev/null +++ b/example/Synthesizer/LLVM/LAC2011.hs @@ -0,0 +1,254 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +module Synthesizer.LLVM.LAC2011 where + +import Synthesizer.LLVM.ExampleUtility + +import qualified Synthesizer.LLVM.Filter.ComplexFirstOrderPacked as BandPass +import qualified Synthesizer.LLVM.Filter.Allpass as Allpass +import qualified Synthesizer.LLVM.Filter.Butterworth as Butterworth +import qualified Synthesizer.LLVM.Filter.Chebyshev as Chebyshev +import qualified Synthesizer.LLVM.Filter.FirstOrder as Filt1 +import qualified Synthesizer.LLVM.Filter.SecondOrder as Filt2 +import qualified Synthesizer.LLVM.Filter.SecondOrderPacked as Filt2P +import qualified Synthesizer.LLVM.Filter.Moog as Moog +import qualified Synthesizer.LLVM.Filter.Universal as UniFilter +import qualified Synthesizer.LLVM.Causal.Controlled as Ctrl +import qualified Synthesizer.LLVM.Causal.Process as Causal +import qualified Synthesizer.LLVM.Generator.Render as Render +import qualified Synthesizer.LLVM.Generator.SignalPacked as GenP +import qualified Synthesizer.LLVM.Generator.Signal as Gen +import qualified Synthesizer.LLVM.Storable.Signal as SigStL +import qualified Synthesizer.LLVM.Frame.SerialVector as Serial +import qualified Synthesizer.LLVM.Frame as Frame +import qualified Synthesizer.LLVM.Wave as Wave + +import qualified LLVM.DSL.Expression as Expr +import LLVM.DSL.Expression (Exp) + +import qualified LLVM.Extra.ScalarOrVector as SoV +import qualified LLVM.Extra.Memory as Memory +import qualified LLVM.Extra.Arithmetic as A +import qualified LLVM.Extra.Multi.Vector as MultiVector +import qualified LLVM.Extra.Multi.Value as MultiValue +import qualified LLVM.Extra.Tuple as Tuple + +import qualified LLVM.Core as LLVM + +import qualified Type.Data.Num.Decimal as TypeNum +import Type.Data.Num.Decimal (D4, D8, D16, d0, d1, d2, d3, d4, d5, d6, d7, d8) + +import Synthesizer.LLVM.Causal.Process (($<), ($*), ($*#)) + +import qualified Synthesizer.Plain.Filter.Recursive as FiltR +import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1Core +import qualified Synthesizer.Plain.Filter.Recursive.SecondOrder as Filt2Core + +import Control.Arrow (Arrow, arr, (&&&), (^<<)) +import Control.Category ((<<<), (.), id) +import Control.Monad ((<=<)) +import Control.Applicative (liftA2, pure) +import Control.Functor.HT (void) +import Data.Traversable (traverse) + +import Foreign.Storable (Storable) +import qualified Data.StorableVector.Lazy as SVL +import qualified Data.StorableVector as SV + +import qualified Data.EventList.Relative.TimeBody as EventList +import qualified Data.EventList.Relative.BodyTime as EventListBT +import qualified Data.EventList.Relative.MixedTime as EventListMT +import qualified Data.EventList.Relative.TimeMixed as EventListTM +import qualified Numeric.NonNegative.Wrapper as NonNeg + +import qualified Synthesizer.LLVM.Frame.Stereo as Stereo + +import qualified Sound.Sox.Option.Format as SoxOption +import qualified Sound.Sox.Frame as SoxFrame +import qualified Sound.Sox.Play as SoxPlay + +-- import qualified Sound.ALSA.PCM as ALSA +-- import qualified Synthesizer.ALSA.Storable.Play as Play + +import Data.List (genericLength) +import System.Random (randomRs, mkStdGen) + +import qualified System.IO as IO + +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import NumericPrelude.Numeric +import NumericPrelude.Base hiding (fst, snd, id, (.)) +import qualified NumericPrelude.Base as P + + +playStereo :: Gen.T (Stereo.T (MultiValue.T Float)) -> IO () +playStereo sig = + playStereoStream . ($ SVL.chunkSize 100000) =<< + Render.run (fmap Stereo.multiValue sig) + +playStereoStream :: SVL.Vector (Stereo.T Float) -> IO () +playStereoStream = playStreamSox + +playMono :: Gen.MV Float -> IO () +playMono sig = playMonoStream . ($ SVL.chunkSize 100000) =<< Render.run sig + +playMonoPacked :: Gen.T (MultiValue.T (Serial.T D4 Float)) -> IO () +playMonoPacked = + playMonoStream . + SigStL.unpack . + ($ SVL.chunkSize 100000) <=< + Render.run + +playMonoStream :: SVL.Vector Float -> IO () +playMonoStream = playStreamSox + + +{- +play :: + (C.MakeValueTuple y, Tuple.ValueOf y ~ a, Memory.C a struct) => + Gen.MV a -> IO () +play = + playStreamSox . + Gen.renderChunky (SVL.chunkSize 100000) +-} + +{- +playStreamALSA :: + (Additive.C y, ALSA.SampleFmt y) => + SVL.Vector y -> IO () +playStreamALSA = + Play.auto (Play.makeSink Play.defaultDevice (0.05::Double) sampleRate) +-} + +-- reacts faster to CTRL-C +playStreamSox :: + (Storable y, SoxFrame.C y) => + SVL.Vector y -> IO () +playStreamSox = + void . SoxPlay.simple SVL.hPut SoxOption.none sampleRate + + +sampleRate :: Ring.C a => a +sampleRate = 44100 + +intSecond :: Ring.C a => Float -> a +intSecond t = fromInteger $ round $ t * sampleRate + +second :: Field.C a => a -> a +second t = t * sampleRate + +hertz :: Field.C a => a -> a +hertz f = f / sampleRate + +sine :: IO () +sine = + playMono (0.99 * Gen.osci Wave.sine 0 (hertz 440)) + +ping :: IO () +ping = + playMono (Gen.exponential2 (second 1) 1 * Gen.osci Wave.triangle 0 (hertz 440)) + +tremolo :: IO () +tremolo = + playMono (Gen.osci Wave.sine 0 (hertz 0.3) * Gen.osci Wave.triangle 0 (hertz 440)) + + +stereo :: IO () +stereo = + playStereo (liftA2 Stereo.cons (Gen.osci Wave.triangle 0 (hertz 439)) (Gen.osci Wave.triangle 0 (hertz 441))) + +stereoFancy :: IO () +stereoFancy = + playStereo (traverse (Gen.osci Wave.triangle 0 . hertz) (Stereo.cons 439 441)) + + +pingParam :: IO (Float -> SVL.Vector Float) +pingParam = + fmap ($ SVL.chunkSize 1024) $ + Render.run $ \freq -> + Gen.exponential2 (second 0.3) 1 * Gen.osci Wave.triangle 0 freq + +playPingParam :: IO () +playPingParam = do + png <- pingParam + playMonoStream (SVL.take (intSecond 1) $ png (hertz 880)) + +melody :: IO (SVL.Vector Float) +melody = do + png <- pingParam + return $ SVL.concat $ map (SVL.take (intSecond 0.2) . png . hertz) $ cycle [440, 550, 660, 880] + +playMelody :: IO () +playMelody = do + mel <- melody + playMonoStream mel + +pingParam2 :: IO ((Float, Float) -> SVL.Vector Float) +pingParam2 = + fmap ($ SVL.chunkSize 1024) $ + Render.run $ \(amp,freq) -> + Gen.exponential2 (second 0.3) amp * Gen.osci Wave.triangle 0 freq + +playMelody2 :: IO () +playMelody2 = do + png <- pingParam2 + playMonoStream $ SVL.concat $ map (SVL.take (intSecond 0.2) . png) $ zip (map sin $ [0,0.1..]) (cycle $ map hertz [440, 550, 660, 880]) + + +retard :: Gen.MV Float -> Gen.MV Float +retard xs = + Causal.frequencyModulationLinear xs . + Causal.map Field.recip $* + (1 + Gen.rampInf (second 10)) + +playRetarded :: IO () +playRetarded = do + mel <- melody + ret <- Render.run retard + playMonoStream $ ret (SVL.chunkSize 10000) mel + + + +pingGen :: Gen.MV Float +pingGen = + Gen.exponential2 (second 0.5) 0.7 * + Gen.osci Wave.triangle 0 (hertz 440) + +delay :: IO () +delay = + playMono $ + pingGen + 0.7 * (Causal.delay 0 (intSecond 0.5) $* pingGen) + +delayArrow :: IO () +delayArrow = + playMono + ((id + 0.7 * Causal.delay 0 (intSecond 0.5)) $* pingGen) + +comb :: IO () +comb = + playMono $ + (Causal.loopZero + (id &&& 0.7 * Causal.delay 0 (intSecond 0.5) + <<< Causal.mix) $* + pingGen) + + +lfoSine :: Exp Float -> Gen.T (Moog.Parameter D8 (MultiValue.T Float)) +lfoSine reduct = + Causal.map (Moog.parameter d8 30 . (hertz 700 *) . (2**)) + $* + Gen.osci Wave.sine 0 (reduct * hertz 0.1) + +filterSweep :: IO () +filterSweep = + playMono $ + (Ctrl.processCtrlRate 128 lfoSine $* Gen.noise 0 (recip $ hertz 3.5e6)) + + +pingPacked :: IO () +pingPacked = + playMonoPacked $ + GenP.exponential2 (second 1) 1 * GenP.osci Wave.triangle 0 (hertz 440) diff --git a/example/Synthesizer/LLVM/LNdW2011.hs b/example/Synthesizer/LLVM/LNdW2011.hs new file mode 100644 --- /dev/null +++ b/example/Synthesizer/LLVM/LNdW2011.hs @@ -0,0 +1,520 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +module Synthesizer.LLVM.LNdW2011 where + +import Synthesizer.LLVM.ExampleUtility + +import qualified Synthesizer.LLVM.Causal.Render as Render +import qualified Synthesizer.LLVM.Causal.ProcessPacked as CausalP +import qualified Synthesizer.LLVM.Causal.Process as Causal +import qualified Synthesizer.LLVM.Generator.Render as SigRender +import qualified Synthesizer.LLVM.Generator.SignalPacked as GenP +import qualified Synthesizer.LLVM.Generator.Signal as Gen + +import qualified Synthesizer.LLVM.Plug.Input as PIn +import qualified Synthesizer.LLVM.Plug.Output as POut +import qualified Synthesizer.MIDI.PiecewiseConstant.ControllerSet as PCS +import qualified Synthesizer.MIDI.EventList as Ev +import qualified Synthesizer.MIDI.CausalIO.ControllerSelection as MCS +import qualified Synthesizer.MIDI.CausalIO.Process as PMIDI +import qualified Synthesizer.MIDI.Value as MV +import qualified Synthesizer.ALSA.CausalIO.Process as PALSA +import qualified Synthesizer.CausalIO.Process as PIO +import qualified Synthesizer.Zip as Zip +import Synthesizer.ALSA.EventList (ClientName(ClientName)) + +import qualified Sound.MIDI.Controller as Ctrl +import qualified Sound.MIDI.Message.Channel as ChannelMsg +import qualified Sound.MIDI.Message.Class.Check as MidiCheck + +import qualified Synthesizer.LLVM.Filter.ComplexFirstOrderPacked as BandPass +import qualified Synthesizer.LLVM.Filter.Allpass as Allpass +import qualified Synthesizer.LLVM.Filter.Butterworth as Butterworth +import qualified Synthesizer.LLVM.Filter.Chebyshev as Chebyshev +import qualified Synthesizer.LLVM.Filter.FirstOrder as Filt1 +import qualified Synthesizer.LLVM.Filter.SecondOrder as Filt2 +import qualified Synthesizer.LLVM.Filter.SecondOrderPacked as Filt2P +import qualified Synthesizer.LLVM.Filter.Moog as Moog +import qualified Synthesizer.LLVM.Filter.Universal as UniFilter +import qualified Synthesizer.LLVM.Storable.Signal as SigStL +import qualified Synthesizer.LLVM.Frame.SerialVector as Serial +import qualified Synthesizer.LLVM.Frame as Frame +import qualified Synthesizer.LLVM.Wave as Wave + +import qualified LLVM.DSL.Expression as Expr +import LLVM.DSL.Expression (Exp) + +import qualified LLVM.Extra.Multi.Value as MultiValue +import qualified LLVM.Extra.ScalarOrVector as SoV +import qualified LLVM.Extra.Memory as Memory +import qualified LLVM.Extra.Arithmetic as A +import qualified LLVM.Extra.Tuple as Tuple +import qualified LLVM.Core as LLVM +import LLVM.Core (Value, value, valueOf, constVector, constOf) +import LLVM.Util.Arithmetic () -- Floating instance for TValue + +import qualified Type.Data.Num.Decimal as TypeNum +import Type.Data.Num.Decimal (D4, D8, D16, d0, d1, d2, d3, d4, d5, d6, d7, d8) + +import qualified Synthesizer.Causal.Class as CausalClass +import Synthesizer.Causal.Class (($<), ($*)) + +import qualified Synthesizer.Plain.Filter.Recursive as FiltR +import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1Core +import qualified Synthesizer.Plain.Filter.Recursive.SecondOrder as Filt2Core + +import qualified Synthesizer.Causal.Spatial as Spatial + +import qualified Control.Monad.Trans.State as State +import qualified Control.Arrow as Arr +import Control.Arrow (Arrow, arr, (&&&), (***), (^<<), (^>>), (>>^)) +import Control.Category ((<<<), (.), id, (>>>)) +import Control.Monad (liftM2, (<=<)) +import Control.Applicative (liftA2, pure, (<$>)) +import Control.Functor.HT (void) +import Data.Tuple.HT (mapPair) +import Data.Traversable (traverse) + +import qualified Data.StorableVector.Lazy as SVL +import qualified Data.StorableVector as SV +import Foreign.Storable (Storable) + +import qualified Data.EventList.Relative.TimeBody as EventList +import qualified Data.EventList.Relative.BodyTime as EventListBT +import qualified Data.EventList.Relative.MixedTime as EventListMT +import qualified Data.EventList.Relative.TimeMixed as EventListTM +import qualified Data.EventList.Relative.TimeTime as EventListTT +import qualified Numeric.NonNegative.Wrapper as NonNegW +import qualified Numeric.NonNegative.Class as NonNeg + +import qualified Synthesizer.LLVM.Frame.Stereo as Stereo +import qualified Synthesizer.LLVM.Frame.StereoInterleaved as StereoInt + +import qualified Sound.Sox.Option.Format as SoxOption +import qualified Sound.Sox.Frame as SoxFrame +import qualified Sound.Sox.Play as SoxPlay + +import qualified Sound.ALSA.PCM as ALSA +import qualified Synthesizer.ALSA.Storable.Play as Play + +import Data.List (genericLength) +import System.Random (randomRs, mkStdGen) + +import qualified System.IO as IO + +import qualified Algebra.NormedSpace.Euclidean as NormedEuc +import qualified Algebra.Algebraic as Algebraic +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive +import qualified Algebra.IntegralDomain as Integral + +import NumericPrelude.Numeric +import NumericPrelude.Base hiding (fst, snd, id, (.)) +import qualified NumericPrelude.Base as P + + +playStereo :: Gen.T (Stereo.T (MultiValue.T Float)) -> IO () +playStereo sig = + playStereoStream . ($ SVL.chunkSize 100000) =<< + SigRender.run (fmap Stereo.multiValue sig) + +playStereoStream :: SVL.Vector (Stereo.T Float) -> IO () +playStereoStream = playStreamSox + +playMono :: Gen.MV Float -> IO () +playMono sig = + playMonoStream . ($ SVL.chunkSize 100000) =<< SigRender.run sig + +playMonoPacked :: Gen.T VectorValue -> IO () +playMonoPacked = + playMonoStream . + SigStL.unpack . + ($ SVL.chunkSize 100000) <=< + SigRender.run + +playMonoStream :: SVL.Vector Float -> IO () +playMonoStream = playStreamSox + + +playStreamALSA :: + (Additive.C y, ALSA.SampleFmt y) => + SVL.Vector y -> IO () +playStreamALSA = + Play.auto (Play.makeSink Play.defaultDevice (0.05::Double) sampleRate) + +-- reacts faster to CTRL-C +playStreamSox :: + (Storable y, SoxFrame.C y) => + SVL.Vector y -> IO () +playStreamSox = + void . SoxPlay.simple SVL.hPut SoxOption.none sampleRate + + +sampleRate :: Ring.C a => a +sampleRate = 44100 + +type Vector = Serial.T VectorSize Float +type VectorSize = TypeNum.D4 +type VectorValue = MultiValue.T Vector + +vectorSize :: Int +vectorSize = + TypeNum.integralFromSingleton + (TypeNum.singleton :: TypeNum.Singleton VectorSize) + +vectorRate :: Field.C a => a +vectorRate = sampleRate / fromIntegral vectorSize + + + +intSecond :: Ring.C a => Float -> a +intSecond t = fromInteger $ round $ t * sampleRate + +second :: Field.C a => a -> a +second t = t * sampleRate + +hertz :: Field.C a => a -> a +hertz f = f / sampleRate + + + +fst :: Arrow arrow => arrow (a,b) a +fst = arr P.fst + +snd :: Arrow arrow => arrow (a,b) b +snd = arr P.snd + + +playFromEvents :: + (ALSA.SampleFmt a, Additive.C a) => + Double -> + Double -> + PIO.T PALSA.Events (SV.Vector a) -> + IO () +playFromEvents latency period = + PALSA.playFromEvents + Play.defaultDevice (ClientName "Haskell-LLVM-demo") + latency period sampleRate + + +modulation :: IO () +modulation = do + proc <- Render.run (0.95 * (Causal.osci Wave.approxSine4 $< 0)) + playFromEvents 0.01 (0.015::Double) + ((proc :: PIO.T (EventListBT.T NonNegW.Int Float) (SV.Vector Float)) + . + PMIDI.controllerExponential + (ChannelMsg.toChannel 0) + Ctrl.modulation + (hertz 500, hertz 2000) (hertz 1000)) + + +vectorBlockSize :: Double +vectorBlockSize = fromIntegral $ 150*vectorSize + +subsample, _subsample :: (Integral.C t) => t -> t -> State.State t t +subsample step t = State.state $ \r -> divMod (r+t) step +_subsample step t = do + State.modify (t+) + (q,r) <- State.gets (flip divMod step) + State.put r + return q + +subsampleBT :: EventListBT.T NonNegW.Int a -> EventListBT.T NonNegW.Int a +subsampleBT = + flip State.evalState NonNeg.zero . + EventListBT.mapTimeM + (subsample (NonNegW.fromNumberMsg "vectorSize" vectorSize)) + +modulationPacked :: IO () +modulationPacked = do + proc <- + Render.run + (0.95 * (CausalP.osci Wave.approxSine4 $< 0) + . + Causal.map Serial.upsample) + playFromEvents 0.01 (vectorBlockSize/sampleRate) + (arr SigStL.unpackStrict + . + (proc :: PIO.T (EventListBT.T NonNegW.Int Float) (SV.Vector Vector)) + . + arr subsampleBT + . + PMIDI.controllerExponential + (ChannelMsg.toChannel 0) + Ctrl.modulation + (hertz 500, hertz 2000) (hertz 1000)) + + +bubbles :: IO () +bubbles = do + proc <- + Render.run + (0.95 * (Causal.osci Wave.sine $< 0) + . + (fst.fst * (1 + snd.fst * snd)) + . + Arr.second (Causal.osci Wave.saw $< 0)) + playFromEvents 0.01 (0.015::Double) + ((proc :: + PIO.T + (Zip.T + (Zip.T + (EventListBT.T NonNegW.Int Float) + (EventListBT.T NonNegW.Int Float)) + (EventListBT.T NonNegW.Int Float)) + (SV.Vector Float)) + . + PIO.zip + (PIO.zip + (PMIDI.controllerExponential + (ChannelMsg.toChannel 0) + Ctrl.modulation + (hertz 500, hertz 2000) (hertz 1000)) + (PMIDI.controllerLinear + (ChannelMsg.toChannel 0) + Ctrl.timbre + (-1, 1) (-0.1))) + (PMIDI.controllerExponential + (ChannelMsg.toChannel 0) + Ctrl.soundVariation + (hertz 1, hertz 10) (hertz 1))) + +bubbleControl :: + (MidiCheck.C event) => + PIO.T (EventListTT.T Ev.StrictTime [event]) (PCS.T Int Float) +bubbleControl = + MCS.filter [ + MCS.controllerExponential Ctrl.volume (0.001, 0.99) 0.5, + MCS.controllerExponential Ctrl.modulation (hertz 500, hertz 2000) (hertz 1000), + MCS.controllerLinear Ctrl.soundVariation (-1, 1) 0.7, + MCS.controllerExponential Ctrl.timbre (hertz 0.2, hertz 5) (hertz 1), + MCS.controllerLinear Ctrl.soundController5 (-1, 1) 0.5, + MCS.controllerExponential Ctrl.soundController7 (hertz 2, hertz 20) (hertz 10)] + . + MCS.fromChannel (ChannelMsg.toChannel 0) + +bubblesSet :: IO () +bubblesSet = do + proc <- + Render.runPlugged + (PIn.controllerSet d6) + (Causal.arrayElement d0 * + (Causal.osci Wave.sine $< 0) + . + (Causal.arrayElement d1 + * + (1 - Causal.arrayElement d2 * + (Causal.osci Wave.saw $< 0) . + Causal.arrayElement d3) + * + (1 - Causal.arrayElement d4 * + (Causal.osci Wave.saw $< 0) . + Causal.arrayElement d5))) + POut.storableVector + playFromEvents 0.01 (0.015::Double) + ((proc :: PIO.T (PCS.T Int Float) (SV.Vector Float)) + . + bubbleControl) + + +subsamplePCS :: PCS.T key a -> PCS.T key a +subsamplePCS = + PCS.mapStream $ + flip State.evalState NonNeg.zero . + EventListTT.mapTimeM (subsample (NonNegW.fromNumberMsg "vectorSize" $ fromIntegral vectorSize)) + +bubblesPacked :: IO () +bubblesPacked = do + proc <- + Render.runPlugged + (PIn.controllerSet d6) + (CausalP.arrayElement d0 * + (CausalP.osci Wave.approxSine4 $< 0) + . + (CausalP.arrayElement d1 + * + (1 - CausalP.arrayElement d2 * + (CausalP.osci Wave.saw $< 0) . + CausalP.arrayElement d3) + * + (1 - CausalP.arrayElement d4 * + (CausalP.osci Wave.saw $< 0) . + CausalP.arrayElement d5))) + POut.storableVector + playFromEvents 0.01 (vectorBlockSize/sampleRate) + (arr SigStL.unpackStrict + . + (proc :: PIO.T (PCS.T Int Float) (SV.Vector Vector)) + . + arr subsamplePCS + . + bubbleControl) + + +{- +Implementation of 'moveAround' that just lifts the corresponding plain function +in the @Spatial@ module from @synthesizer-core@. +Unfortunately, this way we get a @PseudoModule v v@ constraint +that cannot be satisfied with @LLVM.Vector@s. +-} +moveAround2dLifted :: + (Expr.Aggregate ve vl, Algebraic.C ve, NormedEuc.Sqr ve ve) => + ve -> ve -> (ve, ve) -> Causal.T (vl, vl) (vl, vl) +moveAround2dLifted att sonicDelay ear = + Causal.map (Spatial.moveAround att sonicDelay ear) + +moveAround2d :: + (ve ~ Exp v, vl ~ MultiValue.T v, + MultiValue.Algebraic v, MultiValue.RationalConstant v) => + ve -> ve -> (ve, ve) -> Causal.T (vl, vl) (vl, vl) +moveAround2d att sonicDelay ear = + Causal.map $ + (\dist -> (sonicDelay*dist, 1/(att+dist)^2)) . + euclideanNorm2d . subtract ear + +euclideanNorm2d :: + (MultiValue.Algebraic a) => + (Exp a, Exp a) -> Exp a +euclideanNorm2d (x,y) = Expr.sqrt $ Expr.sqr x + Expr.sqr y + +flyChannel :: + (ae ~ Exp Float, al ~ MultiValue.T Float) => + (ae, ae) -> Causal.T (al, (al, al)) al +flyChannel ear = + ((snd ^>> moveAround2d 1 0.1 ear >>> Arr.first (negate id)) + &&& + (Arr.second + (2 * (Causal.differentiate (0,0) >>> Causal.map euclideanNorm2d)) + >>> + Causal.mix)) + >>> + arr (\((phase,volume), speed) -> (volume, (phase,speed))) + >>> + Arr.second (Causal.osci Wave.saw) + >>> + (Causal.envelope * 10) + +fly :: IO () +fly = do + let slow, fast :: Causal.T (MultiValue.T Float) (MultiValue.T Float) + slow = + Filt1.lowpassCausal $< + Gen.constant (Filt1Core.parameter (1/sampleRate :: Exp Float)) + fast = + Filt1.lowpassCausal $< + Gen.constant (Filt1Core.parameter (30/sampleRate :: Exp Float)) + proc <- + Render.runPlugged + (PIn.controllerSet d5) + ((Causal.arrayElement d0 &&& + (liftA2 (,) + (Causal.arrayElement d2) + (liftA2 (,) + ((Causal.arrayElement d3 >>> slow) + + + Causal.arrayElement d1 * + (CausalClass.fromSignal (Gen.noise 366210 0.3) + >>> fast >>> fast)) + ((Causal.arrayElement d4 >>> slow) + + + Causal.arrayElement d1 * + (CausalClass.fromSignal (Gen.noise 234298 0.3) + >>> fast >>> fast))) + >>> + liftA2 Stereo.cons + (flyChannel (-1,0)) + (flyChannel ( 1,0)))) + >>> + Causal.envelopeStereo + >>^ + Stereo.multiValue) + POut.storableVector + playFromEvents 0.01 (0.015::Double) + ((proc :: PIO.T (PCS.T Int Float) (SV.Vector (Stereo.T Float))) + . + MCS.filter [ + MCS.controllerExponential Ctrl.volume (0.001, 0.99) 0.2, + MCS.controllerLinear Ctrl.modulation (0, 5) 2, + MCS.pitchBend 2 (hertz 250), + MCS.controllerLinear Ctrl.vectorX (-10, 10) 0, + MCS.controllerLinear Ctrl.vectorY (-10, 10) 0] + . + MCS.fromChannel (ChannelMsg.toChannel 0)) + + +flyChannelPacked :: + (ae ~ Exp Vector, al ~ VectorValue) => + (ae, ae) -> Causal.T (al, (al, al)) al +flyChannelPacked ear = + ((snd ^>> moveAround2d 1 0.1 ear >>> Arr.first (negate id)) + &&& + (Arr.second + (2 * (CausalP.differentiate 0 *** CausalP.differentiate 0 + >>> + Causal.map euclideanNorm2d)) + >>> + Causal.mix)) + >>> + arr (\((phase,volume), speed) -> (volume, (phase,speed))) + >>> + Arr.second (CausalP.osci Wave.saw) + >>> + Causal.envelope + >>> + CausalP.amplify 10 + + +flyPacked :: IO () +flyPacked = do + let slow, fast :: Causal.T VectorValue VectorValue + slow = + Filt1.lowpassCausalPacked $< + Gen.constant (Filt1Core.parameter (1/sampleRate :: Exp Float)) + fast = + Filt1.lowpassCausalPacked $< + Gen.constant (Filt1Core.parameter (30/sampleRate :: Exp Float)) + proc <- + Render.runPlugged + (PIn.controllerSet d5) + ((CausalP.arrayElement d0 &&& + (liftA2 (,) + (CausalP.arrayElement d2) + (liftA2 (,) + ((CausalP.arrayElement d3 >>> slow) + + + CausalP.arrayElement d1 * + (CausalClass.fromSignal (GenP.noise 366210 0.3) + >>> fast >>> fast)) + ((CausalP.arrayElement d4 >>> slow) + + + CausalP.arrayElement d1 * + (CausalClass.fromSignal (GenP.noise 234298 0.3) + >>> fast >>> fast))) + >>> + liftA2 Stereo.cons + (flyChannelPacked (-1,0)) + (flyChannelPacked ( 1,0)))) + >>> + Causal.envelopeStereo + >>^ + Stereo.multiValueSerial) + POut.storableVector + playFromEvents 0.01 (vectorBlockSize/sampleRate) + (arr SigStL.unpackStrict + . + (proc :: PIO.T (PCS.T Int Float) (SV.Vector (Serial.T VectorSize (Stereo.T Float)))) + . + arr subsamplePCS + . + MCS.filter [ + MCS.controllerExponential Ctrl.volume (0.001, 0.99) 0.2, + MCS.controllerLinear Ctrl.modulation (0, 5) 2, + MCS.pitchBend 2 (hertz 250), + MCS.controllerLinear Ctrl.vectorX (-10, 10) 0, + MCS.controllerLinear Ctrl.vectorY (-10, 10) 0] + . + MCS.fromChannel (ChannelMsg.toChannel 0)) diff --git a/example/Synthesizer/LLVM/Test.hs b/example/Synthesizer/LLVM/Test.hs new file mode 100644 --- /dev/null +++ b/example/Synthesizer/LLVM/Test.hs @@ -0,0 +1,1929 @@ +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +module Main where + +import Synthesizer.LLVM.LAC2011 () +import Synthesizer.LLVM.ExampleUtility + +import qualified Synthesizer.LLVM.Server.Default as Default +import qualified Synthesizer.LLVM.Server.SampledSound as Sample + +import qualified Synthesizer.LLVM.Filter.ComplexFirstOrderPacked as BandPass +import qualified Synthesizer.LLVM.Filter.Allpass as Allpass +import qualified Synthesizer.LLVM.Filter.Butterworth as Butterworth +import qualified Synthesizer.LLVM.Filter.Chebyshev as Chebyshev +import qualified Synthesizer.LLVM.Filter.FirstOrder as Filt1 +import qualified Synthesizer.LLVM.Filter.SecondOrder as Filt2 +import qualified Synthesizer.LLVM.Filter.SecondOrderPacked as Filt2P +import qualified Synthesizer.LLVM.Filter.Moog as Moog +import qualified Synthesizer.LLVM.Filter.Universal as UniFilter +import qualified Synthesizer.LLVM.Filter.NonRecursive as FiltNR +import qualified Synthesizer.LLVM.Causal.Helix as Helix +import qualified Synthesizer.LLVM.Causal.ControlledPacked as CtrlPS +import qualified Synthesizer.LLVM.Causal.Controlled as Ctrl +import qualified Synthesizer.LLVM.Causal.Render as CausalRender +import qualified Synthesizer.LLVM.Causal.ProcessPacked as CausalPS +import qualified Synthesizer.LLVM.Causal.Process as Causal +import qualified Synthesizer.LLVM.Causal.Functional as Func +import qualified Synthesizer.LLVM.Generator.Render as Render +import qualified Synthesizer.LLVM.Generator.SignalPacked as SigPS +import qualified Synthesizer.LLVM.Generator.Core as SigCore +import qualified Synthesizer.LLVM.Generator.Source as Source +import qualified Synthesizer.LLVM.Generator.Signal as Sig +import qualified Synthesizer.LLVM.Interpolation as Interpolation +import qualified Synthesizer.LLVM.Storable.Signal as SigStL +import qualified Synthesizer.LLVM.ConstantPiece as Const +import qualified Synthesizer.LLVM.Wave as Wave +import Synthesizer.LLVM.Causal.Functional (($&), (&|&)) +import Synthesizer.LLVM.Causal.Process (($<), ($>), ($*), ($<#), ($*#)) + +import qualified Synthesizer.LLVM.Frame.StereoInterleaved as StereoInt +import qualified Synthesizer.LLVM.Frame.Stereo as Stereo +import qualified Synthesizer.LLVM.Frame.SerialVector as Serial + +import qualified LLVM.DSL.Expression.Maybe as ExprMaybe +import qualified LLVM.DSL.Expression as Expr +import LLVM.DSL.Expression (Exp, (>*), (&&*)) + +import qualified LLVM.Extra.Multi.Value.Marshal as Marshal +import qualified LLVM.Extra.Multi.Vector.Instance as MultiVectorI +import qualified LLVM.Extra.Multi.Vector as MultiVector +import qualified LLVM.Extra.Multi.Value as MultiValue +import qualified LLVM.Extra.Arithmetic as A +import qualified LLVM.Extra.Tuple as Tuple +import qualified LLVM.Extra.Maybe as Maybe + +import qualified LLVM.Core as LLVM +import LLVM.Util.Arithmetic () -- Floating instance for TValue + +import qualified Type.Data.Num.Decimal as TypeNum +import Type.Data.Num.Decimal (D2, D4, (:*:)) +import Type.Base.Proxy (Proxy) + +import qualified Synthesizer.CausalIO.Process as PIO +import qualified Synthesizer.Causal.Class as CausalClass +import qualified Synthesizer.Zip as Zip +import qualified Synthesizer.State.Control as CtrlS +import qualified Synthesizer.State.Signal as SigS + +import qualified Synthesizer.Plain.Filter.Recursive as FiltR +import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1Core + +import Control.Arrow (Arrow, arr, first, (&&&), (^<<), (<<^), (***)) +import Control.Category ((<<<), (.), id) +import Control.Applicative (liftA2) +import Control.Functor.HT (void) +import Control.Monad (when, join) + +import qualified Data.StorableVector.Lazy as SVL +import qualified Data.StorableVector as SV +import Foreign.Storable (Storable) + +import qualified Data.EventList.Relative.TimeBody as EventList +import qualified Data.EventList.Relative.BodyTime as EventListBT +import qualified Data.EventList.Relative.MixedTime as EventListMT +import qualified Data.EventList.Relative.TimeMixed as EventListTM +import qualified Numeric.NonNegative.Wrapper as NonNeg + +import qualified Sound.Sox.Option.Format as SoxOption +import qualified Sound.Sox.Play as SoxPlay +-- import qualified Synthesizer.ALSA.Storable.Play as Play + +import qualified Data.NonEmpty.Class as NonEmptyC +import qualified Data.NonEmpty as NonEmpty +import qualified Data.Foldable as Fold +import Data.Function.HT (nest) +import Data.NonEmpty ((!:)) +import Data.Semigroup ((<>)) +import Data.Traversable (sequenceA) +import Data.Tuple.HT (mapSnd) +import System.Path (()) +import System.Random (randomRs, mkStdGen) + +import qualified System.Unsafe as Unsafe +import qualified System.IO as IO +import Control.Exception (bracket) + +import qualified Algebra.Field as Field + +import qualified NumericPrelude.Numeric as NP +import qualified Prelude as P +import NumericPrelude.Numeric (fromIntegral, sum, (+), (-), (/), (*)) +import Prelude hiding (fst, snd, id, (.), fromIntegral, sum, (+), (-), (/), (*)) + + +asStereoPacked :: Id (vector (Serial.T D4 (Stereo.T Float))) +asStereoPacked = id + +asStereoInterleaved :: Id (vector (StereoInt.T D4 Float)) +asStereoInterleaved = id + + +{- | +> playStereo (Sig.amplifyStereo 0.3 $ stereoOsciSaw 0.01) +-} +playStereo :: Sig.T (Stereo.T (MultiValue.T Float)) -> IO () +playStereo sig = + playStereoVector . ($ SVL.chunkSize 100000) =<< + Render.run (Stereo.multiValue <$> sig) + +playStereoVector :: SVL.Vector (Stereo.T Float) -> IO () +playStereoVector = + void . SoxPlay.simple SVL.hPut SoxOption.none 44100 + +playMono :: Sig.MV Float -> IO () +playMono sig = playMonoVector . ($ SVL.chunkSize 100000) =<< Render.run sig + +playMonoVector :: SVL.Vector Float -> IO () +playMonoVector = + void . SoxPlay.simple SVL.hPut SoxOption.none 44100 + + +playFileMono :: FilePath -> IO () +playFileMono fileName = do + f <- Render.run id + IO.withFile fileName IO.ReadMode $ \h -> + playStereoVector . f (SVL.chunkSize 100000) . + asStereo . snd + =<< SVL.hGetContentsAsync (SVL.chunkSize 4321) h + + +frequency :: Float -> Exp Float +frequency = Expr.cons + +{- | +Assist GHC-7.10.3 with determining the type of causal processes. +GHC-7.8.4 and GHC-8.0.1 do not need it. +-} +causalP :: Causal.T a b -> Causal.T a b +causalP = id + + +constant :: Float -> IO () +constant y = + (SV.writeFile "speedtest.f32" . asMono =<<) $ + fmap ($ 1000) $ Render.run $ + Sig.constant (Expr.cons y) + +saw :: IO () +saw = + (SV.writeFile "speedtest.f32" . asMono =<<) $ + fmap ($ 10000000) $ Render.run $ + Sig.osci Wave.saw 0 0.01 + +exponential :: IO () +exponential = + (SV.writeFile "speedtest.f32" . asMono =<<) $ + fmap ($ 10000000) $ Render.run $ + Sig.exponential2 50000 1 + +triangle :: IO () +triangle = + (SV.writeFile "speedtest.f32" . asMono =<<) $ + fmap ($ 10000000) $ Render.run $ + Sig.osci Wave.triangle 0.25 0.01 + +trianglePack :: IO () +trianglePack = + (SV.writeFile "speedtest.f32" . asMonoPacked =<<) $ + fmap ($ div 10000000 4) $ Render.run $ + (Causal.map (Expr.liftM Wave.triangle) $*) $ + SigPS.packSmall $ + SigCore.osci 0.25 (4.015803e-4) + +trianglePacked :: IO () +trianglePacked = + (SV.writeFile "speedtest.f32" . asMonoPacked =<<) $ + fmap ($ div 10000000 4) $ Render.run $ + (CausalPS.osci Wave.triangle + $< SigPS.constant 0.25 + $* SigPS.constant 0.01) + +triangleReplicate :: IO () +triangleReplicate = + (SV.writeFile "speedtest.f32" . asMonoPacked =<<) $ + fmap ($ div 10000000 4) $ Render.run $ + (CausalPS.shapeModOsci + (\k p -> do + x <- Wave.triangle =<< Wave.replicate k p + y <- Wave.approxSine4 =<< Wave.halfEnvelope p + A.mul x y) + $< SigPS.rampInf 1000000 + $< SigPS.constant 0 + $* SigPS.constant 0.01) + +rationalSine :: IO () +rationalSine = + (SV.writeFile "speedtest.f32" . asMonoPacked =<<) $ + fmap ($ div 10000000 4) $ Render.run $ + (CausalPS.shapeModOsci Wave.rationalApproxSine1 + $< (0.001 + SigPS.rampInf 10000000) + $< SigPS.constant 0 + $* SigPS.constant 0.01) + +rationalSineStereo :: IO () +rationalSineStereo = + (SV.writeFile "speedtest.f32" . asStereoPacked =<<) $ + fmap ($ div 10000000 4) $ Render.run $ + fmap Stereo.multiValueSerial $ + liftA2 Stereo.cons + (CausalPS.shapeModOsci Wave.rationalApproxSine1 + $< (0.001 + SigPS.rampInf 10000000) + $< SigPS.constant (-0.25) + $* SigPS.constant 0.00999) + (CausalPS.shapeModOsci Wave.rationalApproxSine1 + $< (0.001 + SigPS.rampInf 10000000) + $< SigPS.constant 0.25 + $* SigPS.constant 0.01001) + + +pingSig :: Float -> Sig.MV Float +pingSig freq = + Sig.exponential2 50000 1 + * + Sig.osci Wave.saw 0.5 (Expr.cons freq) + +pingSigP :: Exp Float -> Sig.MV Float +pingSigP freq = + Sig.exponential2 50000 1 + * + Sig.osci Wave.saw 0.5 freq + +ping :: IO () +ping = + (SV.writeFile "speedtest.f32" . asMono =<<) $ + fmap ($ 10000000) $ Render.run $ + pingSig 0.01 + +pingSigPacked :: Exp Float -> Sig.T (CausalPS.Serial D4 Float) +pingSigPacked freq = + SigPS.exponential2 50000 1 + * + SigPS.osci Wave.saw 0 freq + +pingPacked :: IO () +pingPacked = + (SV.writeFile "speedtest.f32" . asMonoPacked =<<) $ + fmap (\f -> f (div 10000000 4) (0.01::Float)) $ Render.run $ + pingSigPacked + +pingUnpack :: IO () +pingUnpack = + (SV.writeFile "speedtest.f32" . asMono =<<) $ + fmap (\f -> f 10000000 (0.01::Float)) $ Render.run $ + SigPS.unpack . pingSigPacked + +pingSmooth :: IO () +pingSmooth = + SV.writeFile "speedtest-scalar.f32" . asMono . ($ 10000000) =<< + Render.run + (Filt1.lowpassCausal + $< fmap Filt1Core.Parameter (1 - Sig.exponential2 50000 1) + $* Sig.osci Wave.triangle 0 0.01) + +pingSmoothPacked :: IO () +pingSmoothPacked = + SV.writeFile "speedtest-vector.f32" . asMonoPacked . ($ div 10000000 4) =<< + Render.run + (Filt1.lowpassCausalPacked + $< fmap Filt1Core.Parameter (1 - Sig.exponential2 (50000/4) 1) + $* SigPS.osci Wave.triangle 0 0.01) + +stereoOsciSaw :: Exp Float -> Sig.T (Stereo.T (MultiValue.T Float)) +stereoOsciSaw freq = + liftA2 Stereo.cons + (Sig.osci Wave.saw 0.0 (freq*1.001) + + Sig.osci Wave.saw 0.2 (freq*1.003) + + Sig.osci Wave.saw 0.1 (freq*0.995)) + (Sig.osci Wave.saw 0.1 (freq*1.005) + + Sig.osci Wave.saw 0.7 (freq*0.997) + + Sig.osci Wave.saw 0.5 (freq*0.999)) + +stereoOsciSawPacked :: Float -> Sig.T (Stereo.T (MultiValue.T Float)) +stereoOsciSawPacked freq = + let mix4 = Expr.liftM $ MultiVector.sum . MultiVectorI.fromMultiValue + in liftA2 Stereo.cons + ((Causal.map mix4 $*) $ + Sig.osci Wave.saw + (Expr.cons $ LLVM.consVector 0.0 0.2 0.1 0.4) + (Expr.cons $ fmap (freq*) $ + LLVM.consVector 1.001 1.003 0.995 0.996)) + ((Causal.map mix4 $*) $ + Sig.osci Wave.saw + (Expr.cons $ LLVM.consVector 0.1 0.7 0.5 0.7) + (Expr.cons $ fmap (freq*) $ + LLVM.consVector 1.005 0.997 0.999 1.001)) + +stereoDeinterleave :: NonEmpty.T [] a -> NonEmpty.T [] (Stereo.T a) +stereoDeinterleave xt = + case xt of + NonEmpty.Cons _ [] -> error "stereoDeinterleave: singleton" + NonEmpty.Cons x0 (x1:xs) -> + Stereo.cons x0 x1 !: + let go (y0:y1:ys) = Stereo.cons y0 y1 : go ys + go [] = [] + go [_] = error "stereoDeinterleave: odd length" + in go xs + +mixVectorToStereo :: + (TypeNum.Positive n, MultiVector.Additive a) => + MultiVector.T n a -> LLVM.CodeGenFunction r (Stereo.T (MultiValue.T a)) +mixVectorToStereo = + NonEmpty.foldBalanced (\x y -> join $ liftA2 A.add x y) . + fmap sequenceA . stereoDeinterleave . MultiVector.dissectList1 + +mixVec :: + (TypeNum.Positive n, MultiVector.Additive a) => + Exp (LLVM.Vector n a) -> Stereo.T (Exp a) +mixVec = + Stereo.unExpression . + Expr.liftM + (fmap Stereo.multiValue . mixVectorToStereo . MultiVectorI.fromMultiValue) + +stereoOsciSawPacked2 :: Float -> Sig.T (Stereo.T (MultiValue.T Float)) +stereoOsciSawPacked2 freq = + (Causal.map mixVec $*) $ + Sig.osci (Wave.trapezoidSlope (A.fromRational' 5)) + (Expr.cons $ LLVM.consVector 0.0 0.2 0.1 0.4 0.1 0.7 0.5 0.7) + (Expr.cons $ fmap (freq*) $ + LLVM.consVector 1.001 1.003 0.995 0.996 1.005 0.997 0.999 1.001) + +stereo :: IO () +stereo = + SV.writeFile "speedtest.f32" . asStereo . ($ 10000000) =<< + Render.run + (Stereo.multiValue <$> Causal.amplifyStereo 0.25 + $* stereoOsciSawPacked2 0.01) + +lazy :: IO () +lazy = + (SVL.writeFile "speedtest.f32" . asMono . SVL.take 10000000 =<<) $ + fmap ($ SVL.chunkSize 100000) $ + Render.run {- SVL.defaultChunkSize - too slow -} + (Causal.envelope + $< Sig.exponential2 50000 1 + $* Sig.osci Wave.sine 0.5 0.01) + +lazyStereo :: IO () +lazyStereo = + (SVL.writeFile "speedtest.f32" . asStereo . SVL.take 10000000 =<<) $ + fmap ($ SVL.chunkSize 100000) $ + Render.run + (Stereo.multiValue <$> Causal.amplifyStereo 0.25 + $* stereoOsciSawPacked 0.01) + +packTake :: IO () +packTake = + (SVL.writeFile "speedtest.f32" . asMonoPacked . ($ SVL.chunkSize 1000) =<<) $ + (Render.run . SigPS.packRotate) + (Causal.take 5 $* Sig.osci Wave.saw 0 (frequency 0.01)) + +chord :: Float -> Sig.T (Stereo.T (MultiValue.T Float)) +chord base = + {- + This exceeds available vector registers + and thus needs more stack accesses. + Thus it needs twice as much time as the simple mixing. + However doing all 32 oscillators in parallel + and mix them in one go might be still faster. + + foldl1 (Sig.zipWith Frame.mixStereoV) $ + -} + NonEmpty.foldBalanced (+) $ + fmap (\f -> stereoOsciSawPacked2 (base*f)) $ + 0.25 !: 1.00 : 1.25 : 1.50 : [] + +lazyChord :: IO () +lazyChord = + (SVL.writeFile "speedtest.f32" . asStereo . SVL.take 10000000 =<<) $ + fmap ($ SVL.chunkSize 100000) $ + Render.run (Stereo.multiValue <$> Causal.amplifyStereo 0.1 $* chord 0.005) + +filterSweepComplex :: IO () +filterSweepComplex = + playStereo $ + (Causal.amplifyStereo 0.3 . BandPass.causal + $< (Causal.map (\x -> BandPass.parameter 100 (0.01 * exp (2*x))) $* + Sig.osci Wave.sine 0 (0.1/44100)) + $* chord 0.005) + +lfoSineCausal :: + Causal.T (MultiValue.T Float) a -> Exp Float -> Sig.T a +lfoSineCausal f reduct = + f . Causal.map (\x -> 0.01 * exp (2*x)) $* + Sig.osci Wave.sine 0 (reduct * 0.1/44100) + +lfoSine :: + (Expr.Aggregate ae a) => + (Exp Float -> ae) -> + Exp Float -> Sig.T a +lfoSine f = lfoSineCausal (Causal.map f) + +filterSweep :: IO () +filterSweep = + (SVL.writeFile "speedtest.f32" . asMono . SVL.take 10000000 =<<) $ + fmap ($ SVL.chunkSize 10000) $ + Render.run $ + (0.2 * Ctrl.processCtrlRate 128 (lfoSine (Filt2.bandpassParameter 100)) + $* Sig.osci Wave.saw 0 (frequency 0.01)) + +filterSweepPacked :: IO () +filterSweepPacked = + (SVL.writeFile "speedtest.f32" . asMonoPacked =<<) $ + fmap (SVL.take (div 10000000 4)) $ + fmap ($ SVL.chunkSize 10000) $ + Render.run + (0.2 * + CtrlPS.processCtrlRate 128 (lfoSine (Filt2.bandpassParameter 100)) + $* SigPS.osci Wave.saw 0 (frequency 0.01)) + +exponentialFilter2Packed :: IO () +exponentialFilter2Packed = + (SVL.writeFile "speedtest.f32" . asMonoPacked16 =<<) $ + fmap (SVL.take (div 10000000 16)) $ + fmap ($ SVL.chunkSize 10000) $ + Render.run + (Filt2.causalPacked + $< Sig.constant (Filt2.Parameter 1 0 0 0 0.99) + $* ( +-- (Causal.delay1 $ Serial.fromFixedList (0.1 !: 0.01 !: 0.001 !: 0.0001 !: Empty.Cons)) +-- (Causal.delay1 $ Serial.replicate 1) + (Causal.delay1 $ Serial.fromFixedList (1 !: NonEmptyC.repeat 0)) + $* 0)) + +filterSweepPacked2 :: IO () +filterSweepPacked2 = + (SVL.writeFile "speedtest.f32" . asMono . SVL.take 10000000 =<<) $ + fmap ($ SVL.chunkSize 10000) $ + Render.run + (0.2 * + Ctrl.processCtrlRate 128 (lfoSine (Filt2P.bandpassParameter 100)) + $* Sig.osci Wave.saw 0 (frequency 0.01)) + +butterworthNoisePacked :: IO () +butterworthNoisePacked = + (SVL.writeFile "speedtest.f32" . asMonoPacked =<<) $ + fmap (SVL.take (div 10000000 4)) $ + fmap ($ SVL.chunkSize 10000) $ + Render.run + (CausalPS.amplify 0.2 . + CtrlPS.processCtrlRate 128 + (lfoSineCausal + (Butterworth.parameterCausal TypeNum.d3 FiltR.Lowpass $<# 0.5)) + $* SigPS.noise 0 0.3) + +chebyshevNoisePacked :: IO () +chebyshevNoisePacked = + (SVL.writeFile "speedtest.f32" . asMonoPacked =<<) $ + fmap (SVL.take (div 10000000 4)) $ + fmap ($ SVL.chunkSize 10000) $ + Render.run + (CausalPS.amplify 0.2 . + CtrlPS.processCtrlRate 128 + (lfoSineCausal + (Chebyshev.parameterCausalA TypeNum.d5 FiltR.Lowpass $<# 0.5)) + $* SigPS.noise 0 0.3) + + +upsample :: IO () +upsample = + (SVL.writeFile "speedtest.f32" . asMono . SVL.take 10000000 =<<) $ + fmap ($ SVL.chunkSize 100000) $ + Render.run + (let reduct = 128 :: Exp Float + in Sig.interpolateConstant reduct + (Sig.osci Wave.sine 0 (reduct*0.1/44100))) + + +filterSweepControlRateCausal :: + Causal.T + (Stereo.T (MultiValue.T Float)) + (Stereo.T (MultiValue.T Float)) +filterSweepControlRateCausal = + Causal.amplifyStereo 0.3 <<< BandPass.causal + $< (let reduct = 128 :: Exp Float + in Sig.interpolateConstant reduct + (Causal.map (BandPass.parameter 100) . + Causal.map (\x -> 0.01 * exp (2*x)) + $* Sig.osci Wave.sine 0 (reduct*0.1/44100))) + +{- | +Trigonometric functions are very slow in LLVM +because they are translated to calls to C's math library. +Thus it is advantageous to compute filter parameters +at a lower rate and interpolate constantly. +-} +filterSweepControlRate :: IO () +filterSweepControlRate = + (SVL.writeFile "speedtest.f32" . asStereo . SVL.take 10000000 =<<) $ + fmap ($ SVL.chunkSize 100000) $ + Render.run + (Stereo.multiValue <$> filterSweepControlRateCausal $* chord 0.005) + + +filterSweepMusic :: IO () +filterSweepMusic = do + proc <- + Render.run $ \music -> + Stereo.multiValue ^<< Causal.amplifyStereo 20 . + filterSweepControlRateCausal <<^ Stereo.unMultiValue $* music + music <- SV.readFile "lichter.f32" + SVL.writeFile "speedtest.f32" . asStereo + =<< proc (SVL.chunkSize 100000) music + + +playFilterSweepMusicLazy :: IO () +playFilterSweepMusicLazy = do + proc <- + Render.run $ \vol music -> + Stereo.multiValue ^<< Causal.amplifyStereo vol . + filterSweepControlRateCausal <<^ Stereo.unMultiValue $* music + IO.withFile "lichter.f32" IO.ReadMode $ \h -> + playStereoVector . proc (SVL.chunkSize 100000) (20::Float) {-1.125-} . snd + =<< SVL.hGetContentsAsync (SVL.chunkSize 4321) h + +playFilterSweepMusicCausal :: IO () +playFilterSweepMusicCausal = do + proc <- + CausalRender.run $ + Stereo.multiValue ^<< Causal.amplifyStereo 20 . + filterSweepControlRateCausal <<^ Stereo.unMultiValue + music <- SV.readFile "lichter.f32" + void $ SoxPlay.simple SV.hPut SoxOption.none 44100 =<< + pioApplyStrict proc music + +playFilterSweepMusicCausalLazy :: IO () +playFilterSweepMusicCausalLazy = do + proc <- + CausalRender.run $ + Stereo.multiValue ^<< Causal.amplifyStereo 20 . + filterSweepControlRateCausal <<^ Stereo.unMultiValue + IO.withFile "lichter.f32" IO.ReadMode $ \h -> + playStereoVector =<< pioApply proc . snd + =<< SVL.hGetContentsAsync (SVL.chunkSize 43210) h + + +deinterleaveProc :: + IO (Float -> + PIO.T + (SV.Vector (StereoInt.T D4 Float)) + (Zip.T + (SV.Vector (StereoInt.T D4 Float)) + (SV.Vector (StereoInt.T D4 Float)))) +deinterleaveProc = + CausalRender.run deinterleaveCausal + +deinterleaveCausal :: + Exp Float -> + Causal.T + (StereoInt.Value D4 Float) + (StereoInt.Value D4 Float, StereoInt.Value D4 Float) +deinterleaveCausal freq = + Func.withArgs $ \input -> + let env = + Func.fromSignal $ + 0.5 * (1 + SigPS.osci (Wave.triangleSquarePower 4) 0 freq) + in (Causal.zipWith StereoInt.envelope $& env &|& input) + &|& + (Causal.zipWith StereoInt.envelope $& (1-env) &|& input) + +deinterleave :: IO () +deinterleave = do + proc <- deinterleaveProc + runSplitProcess (proc (2/44100)) + + +disturbProc, disturbFMProc :: + IO (PIO.T + (SV.Vector (StereoInt.T D4 Float)) + (Zip.T + (SV.Vector (StereoInt.T D4 Float)) + (SV.Vector (StereoInt.T D4 Float)))) +disturbProc = + CausalRender.run $ crossMix disturbCausal + +disturbCausal, disturbFMCausal :: + Causal.T (StereoInt.Value D4 Float) (StereoInt.Value D4 Float) +disturbCausal = + Func.withArgs $ \inputInt -> + let tone = Func.fromSignal $ SigPS.osci Wave.triangle 0 (440/44100) + getEnvelope x = + Filt1.lowpassCausalPacked $& + (Func.fromSignal $ + Sig.constant $ Filt1Core.parameter (1/44100)) + &|& + (Causal.map abs $& x) + envelopedTone x = getEnvelope x * tone + in Causal.map StereoInt.interleave $& + CausalPS.amplifyStereo 5 $& + Stereo.liftApplicative envelopedTone + (Causal.map StereoInt.deinterleave $& inputInt) + +disturbFMProc = + CausalRender.run $ crossMix disturbFMCausal + +disturbFMCausal = + Func.withArgs $ \inputInt -> + let getEnvelope x = + Filt1.lowpassCausalPacked $& + (Func.fromSignal $ + Sig.constant $ Filt1Core.parameter (1/44100)) + &|& + (Causal.map abs $& x) + modulatedTone x = + getEnvelope x * + (CausalPS.osci Wave.triangle $& + NP.zero + &|& + 10 * getEnvelope (CausalPS.differentiate 0 $& x)) + in Causal.map StereoInt.interleave $& + CausalPS.amplifyStereo 5 $& + Stereo.liftApplicative modulatedTone + (Causal.map StereoInt.deinterleave $& inputInt) + +disturb :: IO () +disturb = + runSplitProcess =<< disturbFMProc + + +wowFlutterProc :: + IO (PIO.T + (SV.Vector (StereoInt.T D4 Float)) + (Zip.T + (SV.Vector (StereoInt.T D4 Float)) + (SV.Vector (StereoInt.T D4 Float)))) +wowFlutterProc = + CausalRender.run $ crossMix wowFlutterCausal + +wowFlutterCausal :: + Causal.T (StereoInt.Value D4 Float) (StereoInt.Value D4 Float) +wowFlutterCausal = + Func.withArgs $ \inputInt -> + let freq = + Func.fromSignal $ (44100*) $ + 0.01 * (1 + SigPS.osci Wave.triangle 0 (1/44100 :: Exp Float)) + + 0.01 * (1 + SigPS.osci Wave.approxSine2 + 0 (1.23/44100 :: Exp Float)) + modulatedTone x = + CausalPS.pack + (Causal.delayControlledInterpolated Interpolation.linear + (0 :: Exp Float) (441*2*2+10)) + $& + freq &|& x + in Causal.map StereoInt.interleave $& + Stereo.liftApplicative modulatedTone + (Causal.map StereoInt.deinterleave $& inputInt) + +crossMix :: + Causal.T (StereoInt.Value D4 Float) (StereoInt.Value D4 Float) -> + Causal.T + (StereoInt.Value D4 Float) + (StereoInt.Value D4 Float, StereoInt.Value D4 Float) +crossMix proc = + ((fst NP.+ snd) &&& (fst NP.- snd)) + . + (id &&& proc) + . + Causal.map (StereoInt.amplify 0.5) + + +wowFlutter :: IO () +wowFlutter = + runSplitProcess =<< wowFlutterProc + + + +scrambleProc0, scrambleProc1 :: + IO (Float -> + PIO.T + (SV.Vector (StereoInt.T D4 Float)) + (Zip.T + (SV.Vector (StereoInt.T D4 Float)) + (SV.Vector (StereoInt.T D4 Float)))) +scrambleProc0 = + CausalRender.run $ \freq -> + deinterleaveCausal freq NP.+ + (id &&& NP.negate id) . + Causal.map (StereoInt.amplify 0.5) . wowFlutterCausal + +scrambleProc1 = + CausalRender.run $ \freq -> + deinterleaveCausal freq NP.+ + (id &&& NP.negate id) . + Causal.map (StereoInt.amplify 0.3) . + (wowFlutterCausal NP.+ disturbFMCausal) + +scramble :: IO () +scramble = do + proc <- scrambleProc1 + runSplitProcess (proc (2/44100)) + + +runSplitProcess :: + (Storable a) => + PIO.T (SV.Vector a) (Zip.T (SV.Vector a) (SV.Vector a)) -> + IO () +runSplitProcess proc = do + void $ + IO.withFile "/tmp/test.f32" IO.ReadMode $ \h -> + IO.withFile "/tmp/even.f32" IO.WriteMode $ \h0 -> + IO.withFile "/tmp/odd.f32" IO.WriteMode $ \h1 -> + + case proc of + PIO.Cons next create delete -> + {- + Is the use of 'bracket' correct? + I think 'delete' must be called with the final state, + not with the initial one. + -} + bracket create delete $ + let chunkSize = 543210 + loop s0 = do + chunk <- SV.hGet h chunkSize + (Zip.Cons y0 y1, s1) <- next chunk s0 + SV.hPut h0 y0 + SV.hPut h1 y1 + when + (SV.length y0 >= SV.length chunk && + SV.length y1 >= SV.length chunk && + SV.length chunk >= chunkSize) + (loop s1) + in loop + + +antimixProc :: + IO (SVL.Vector (StereoInt.T D4 Float) -> + PIO.T + (SV.Vector (StereoInt.T D4 Float)) + (Zip.T + (SV.Vector (StereoInt.T D4 Float)) + (SV.Vector (StereoInt.T D4 Float)))) +antimixProc = + CausalRender.run $ \xs -> crossMix $ + Causal.map (StereoInt.amplify 0.5) . Causal.fromSignal xs + +antimix :: IO () +antimix = do + proc <- antimixProc + void $ + IO.withFile "/tmp/test.f32" IO.ReadMode $ \h -> + IO.withFile "/tmp/even.f32" IO.WriteMode $ \h0 -> + IO.withFile "/tmp/odd.f32" IO.WriteMode $ \h1 -> do + let chunkSize = SVL.chunkSize 543210 + input <- fmap snd $ SVL.hGetContentsAsync chunkSize h + let vectorSize = 4 + additive = SVL.drop (div 44100 vectorSize) input +{- + additive = + case SVL.splitAt (div 44100 vectorSize) input of + (prefix, suffix) -> + SVL.append suffix $ + SVL.replicate chunkSize (SVL.length prefix) StereoInt.zero +-} +{- + additive = + case SVL.splitAt (div 44100 vectorSize) input of + (prefix, suffix) -> SVL.append suffix prefix +-} + + case proc additive of + PIO.Cons next create delete -> + {- + Is the use of 'bracket' correct? + I think 'delete' must be called with the final state, + not with the initial one. + -} + bracket create delete $ \state -> + let loop cs0 s0 = + case cs0 of + [] -> return () + c : cs -> do + (Zip.Cons y0 y1, s1) <- next c s0 + SV.hPut h0 y0 + SV.hPut h1 y1 + when + (SV.length y0 >= SV.length c && + SV.length y1 >= SV.length c) + (loop cs s1) + in loop (SVL.chunks input) state + + +arrangeLazy :: IO () +arrangeLazy = do + IO.hSetBuffering IO.stdout IO.NoBuffering + arrange <- SigStL.makeArranger + print $ + arrange (SVL.chunkSize 2) $ + EventList.fromPairList $ + (0, SVL.pack (SVL.chunkSize 2) [1,2::Double]) : + (0, SVL.pack (SVL.chunkSize 2) [3,4,5,6]) : + (2, SVL.pack (SVL.chunkSize 2) [7,8,9,10]) : + -- repeat (2, SVL.empty) +-- (2, SVL.empty) : +-- (2, SVL.empty) : +-- (2::NonNeg.Int, error "undefined sound") : + error "end of list" + -- [] + + +{- | +This is inefficient because pingSig is compiled by LLVM +for every occurence of the sound! + +randomTones :: IO () +randomTones = do + playMonoVector $ + SigStL.arrange (SVL.chunkSize 12345) $ + EventList.fromPairList $ zip + (cycle $ map (flip div 16 . (44100*)) [1,2,3]) + (cycle $ map (SVL.take 44100 . Sig.renderChunky (SVL.chunkSize 54321) . + pingSig . (0.01*)) + [1,1.25,1.5,2]) +-} + +{- +{- | +So far we have not managed to compile signals +that depend on parameters. +Thus in order to avoid much recompilation, +we compile and render a few sounds in advance. +-} +pingTones :: [SVL.Vector Float] +pingTones = + map (SVL.take 44100 . Sig.renderChunky (SVL.chunkSize 4321) . + pingSig . (0.01*)) + [1,1.25,1.5,2] +-} + +pingTonesIO :: IO [SVL.Vector Float] +pingTonesIO = + fmap + (\pingVec -> + map + (SVL.take 44100 . + pingVec (SVL.chunkSize 4321) . + (0.01*)) + [1,1.25,1.5,2::Float]) + (Render.run pingSigP) + +{- +Arrange itself does not seem to have a space leak with temporary data. +However it may leak sound data. +This is not very likely because this would result in a large memory leak. + +Generate random tones in order to see whether generated sounds leak. +How does 'arrange' compare with 'concat'? +-} + +{- +cycleTones :: IO () +cycleTones = do +-- playMono $ + pings <- pingTonesIO + SVL.writeFile "test.f32" $ +-- Play.auto (0.01::Double) 44100 $ + asMono $ +{- +after 13min runtime memory consumption increased from 2.5 to 3.9 +and we get lot of buffer underruns with this implementation of amplification +(renderChunky . amplify . fromStorableVector) +-} + Sig.renderChunky (SVL.chunkSize 432109) $ + Sig.amplify 0.1 $ + Sig.fromStorableVectorLazy $ +{- +after 20min memory consumption increased from 2.5 to 3.4 +and we get lot of buffer underruns with applyStorableChunky +-} +{- +applyStorableChunky applied to concatenated zero vectors +starts with memory consumption 1.0 and after an hour, it's still 1.1 +without buffer underruns. +-} +{- + CausalP.applyStorableChunky (CausalP.amplify $# (0.1::Float)) () $ + asMono $ +-} +{- +with chunksize 12345678 +after 50min runtime the memory consumption increased from 12.0 to 26.2 + +with chunksize 123 +after 25min runtime the memory consumption is constant 7.4 +however at start time there 5 buffer underruns, but no more +probably due to initial LLVM compilation + +with chunksize 1234567 and SVL.replicate instead of pingTones +we get memory consumption from 1.3 to 3.2 in 15min, +while producing lots of buffer underruns. +After 45min in total, it is still 3.2 of memory consumption. +Is this a memory leak, or isn't it? + +with chunksize 12345678 and SVL.replicate +we get from 5.6 to 10.2 in 3min +to 14.9 after total 13min. +-} +{- + SigStL.arrange (SVL.chunkSize 12345678) $ + EventList.fromPairList $ zip + (repeat (div 44100 8)) +-- (cycle $ map (flip div 4 . (44100*)) [1,2,3]) +-} +{- +With plain concatenation of those zero vectors +we stay constantly at 0.4 memory consumption and no buffer underruns over 30min. +-} + SVL.concat + (cycle pings) +-- (repeat $ SVL.replicate (SVL.chunkSize 44100) 44100 0) + return () +-} + + +tonesChunkSize :: SVL.ChunkSize +numTones :: Int + +{- +For one-time-compiled fill functions, +larger chunks have no relevant effect on the processing speed. +-} +(tonesChunkSize, numTones) = + (SVL.chunkSize 441, 200) +-- (SVL.chunkSize 44100, 200) + +fst :: Arrow arrow => arrow (a,b) a +fst = arr P.fst + +snd :: Arrow arrow => arrow (a,b) b +snd = arr P.snd + + +{-# NOINLINE makePing #-} +makePing :: IO (Float -> Float -> SVL.Vector Float) +makePing = + fmap ($ tonesChunkSize) $ + Render.run $ \halfLife freq -> + Causal.envelope + $< Sig.exponential2 halfLife 1 + $* Sig.osci Wave.saw 0.5 freq + +tonesDown :: IO () +tonesDown = do + let dist = div 44100 10 + pingp <- makePing + arrange <- SigStL.makeArranger + amplify <- CausalRender.run Causal.amplify + playMonoVector =<< + (pioApply (amplify (0.03::Float)) $ + arrange tonesChunkSize $ + EventList.fromPairList $ + zip + (repeat (NonNeg.fromNumber dist)) + (map (SVL.take (numTones * dist) . pingp 50000) $ + iterate (0.999*) 0.01)) + + +vibes :: (Exp Float, Exp Float) -> Sig.MV Float +vibes (modDepth, freq) = + let halfLife = 5000 + -- sine = Wave.sine + sine = Wave.approxSine4 + in Causal.envelope + $< Sig.exponential2 halfLife 1 + $* (((Causal.osci sine + $< (Causal.envelope + $< Sig.exponential2 halfLife modDepth + $* (Causal.osci sine $* Sig.constant (0, 2*freq)))) + <<< + Causal.amplify freq + <<< + (Causal.osci sine * 0.01 + 1)) + $* Sig.constant (0, 0.0001)) + +makeVibes :: IO ((Float,Float) -> SVL.Vector Float) +makeVibes = fmap ($ tonesChunkSize) $ Render.run vibes + +vibesCycleVector :: ((Float,Float) -> SVL.Vector Float) -> IO (SVL.Vector Float) +vibesCycleVector pingp = + (\evs -> fmap (\arrange -> arrange tonesChunkSize evs) SigStL.makeArranger) $ + EventList.fromPairList $ zip + (repeat 5000) + (map (SVL.take 50000 . pingp) $ + zip + (map (\k -> 0.5 * (1 - cos k)) $ iterate (0.05+) 0) + (cycle $ map (0.01*) [1, 1.25, 1.5, 2])) + +pioApply :: + (Storable a, Storable b) => + PIO.T (SV.Vector a) (SV.Vector b) -> SVL.Vector a -> IO (SVL.Vector b) +pioApply proc sig = do + act <- PIO.runStorableChunkyCont proc + return $ act (const SVL.empty) sig + +pioApplyStrict :: + (Storable a, Storable b) => + PIO.T (SV.Vector a) (SV.Vector b) -> SV.Vector a -> IO (SV.Vector b) +pioApplyStrict proc sig = do + act <- PIO.runCont proc + return $ + case act (const []) [sig] of + chunk : _ -> chunk + [] -> SV.empty + +vibesCycle :: IO () +vibesCycle = do + sig <- vibesCycleVector =<< makeVibes + proc <- CausalRender.run Causal.amplify + playMonoVector =<< pioApply (proc (0.2::Float)) sig + +vibesEcho :: IO () +vibesEcho = do + sig <- vibesCycleVector =<< makeVibes + proc <- + CausalRender.run (\vol -> Causal.amplify vol <<< Causal.comb 0.5 7000) + playMonoVector =<< pioApply (proc (0.2::Float)) sig + +vibesReverb :: IO () +vibesReverb = do + sig <- vibesCycleVector =<< makeVibes + proc <- + CausalRender.run + (\params -> Causal.amplify 0.3 <<< Causal.reverbExplicit params) + playMonoVector =<< + pioApply + (proc (Causal.reverbParams (mkStdGen 142) + TypeNum.d16 (0.9,0.97) (400,1000))) + sig + +vibesReverbStereo :: IO () +vibesReverbStereo = do + sig <- vibesCycleVector =<< makeVibes + proc <- + CausalRender.run + (\params -> + Stereo.multiValue + ^<< + Causal.amplifyStereo 0.3 + <<< + Causal.stereoFromMonoParametric Causal.reverbExplicit params + <<^ + (\x -> Stereo.cons x x)) + playStereoVector =<< + pioApply + (proc + (fmap + (\seed -> + Causal.reverbParams (mkStdGen seed) + TypeNum.d16 (0.9,0.97) (400,1000)) + (Stereo.cons 142 857))) + sig + + +stair :: IO () +stair = + (SVL.writeFile "speedtest.f32" . asMono . SVL.take 10000000 =<<) $ + fmap + (\f -> + f tonesChunkSize $ + EventListBT.fromPairList $ + zip (iterate (/2) 1) (iterate (2*) (1::NonNeg.Integer))) $ + Render.run Const.flatten + + +filterBass :: IO () +filterBass = do + proc <- + Render.run $ \xs -> + (fmap Stereo.multiValue BandPass.causal + <<< + CausalClass.feedSnd + (liftA2 Stereo.cons + (Sig.osci Wave.saw 0 (frequency 0.001499)) + (Sig.osci Wave.saw 0 (frequency 0.001501))) + <<< + Causal.map (BandPass.parameter 100)) + $* + Const.flatten xs + + playStereoVector $ proc tonesChunkSize $ + EventListBT.fromPairList $ + zip + (map (((0.01::Float)*) . (2**) . (/12) . fromInteger) $ + randomRs (0,24) (mkStdGen 998)) + (repeat (6300::NonNeg.Int)) + + +mixVectorStereo :: + SVL.Vector (Stereo.T Float) -> + SVL.Vector (Stereo.T Float) -> + SVL.Vector (Stereo.T Float) +mixVectorStereo = Unsafe.performIO mixVectorStereoIO + +mixVectorStereoIO :: + IO (SVL.Vector (Stereo.T Float) -> + SVL.Vector (Stereo.T Float) -> + SVL.Vector (Stereo.T Float)) +mixVectorStereoIO = + (\proc xs ys -> Unsafe.performIO $ pioApply (proc xs) ys) + <$> + CausalRender.run (\xs -> Causal.mix $< xs) + +{- +slightly slower than mixVectorParam +-} +mixVectorHaskell :: SVL.Vector Float -> SVL.Vector Float -> SVL.Vector Float +mixVectorHaskell = SVL.zipWith (+) + +toneMix :: IO () +toneMix = do + pingp <- makePing + mix <- CausalRender.run $ \x -> Causal.mix $< x + amplify <- CausalRender.run (Causal.amplify 0.1) + playMonoVector + =<< pioApply amplify + =<< ((\(x:xs) -> Fold.foldlM (pioApply . mix) x xs) $ take numTones $ + map (pingp 1000000) $ iterate (*(2/3)) 0.01) + +fadeEnvelope :: Exp Word -> Exp Word -> Sig.MV Float +fadeEnvelope intro len = + Sig.parabolaFadeIn intro + <> + (Causal.take len $* 1) + <> + Sig.parabolaFadeOut intro + +fadeEnvelopeWrite :: IO () +fadeEnvelopeWrite = + (SVL.writeFile "speedtest.f32" . asMono =<<) $ + fmap ($ SVL.chunkSize 1234) $ + Render.run $ fadeEnvelope 100000 200000 + + +-- | normalize a list of numbers, such that they have a specific average +-- Cf. haskore-supercollider/src/Haskore/Interface/SuperCollider/Example.hs +normalizeLevel :: (Field.C a) => a -> [a] -> [a] +normalizeLevel newAvrg xs = + let avrg = sum xs / fromIntegral (length xs) + in map ((newAvrg-avrg)+) xs + +stereoOsciParams :: + (TypeNum.Integer n) => + Proxy n -> Float -> (Float, Stereo.T (MultiValue.Array n (Float,Float))) +stereoOsciParams np freq = + let n = TypeNum.integralFromProxy np + volume :: Float + volume = recip $ sqrt $ TypeNum.integralFromProxy np + detunes :: [Float] + detunes = + normalizeLevel 1 $ take (2*n) $ + randomRs (0,0.03) $ mkStdGen 912 + phases :: [Float] + phases = randomRs (0,1) $ mkStdGen 54 + in (,) volume $ + fmap MultiValue.Array $ + uncurry Stereo.cons $ splitAt n $ + zipWith + (\phase detune -> (phase, detune*freq)) + phases detunes + +stereoOsciSawP :: + (TypeNum.Natural n) => + (TypeNum.Natural arrSize, arrSize ~ (n :*: LLVM.UnknownSize)) => + (TypeNum.Natural stereoSize, stereoSize ~ (D2 :*: arrSize)) => + Exp Float -> Stereo.T (Exp (MultiValue.Array n (Float,Float))) -> + Sig.MV (Stereo.T Float) +stereoOsciSawP volume = + fmap Stereo.multiValue + . + stereoFromMonoParametricSignal + (\params -> + Causal.amplify volume + $* multiMixSignal + (\phaseFreq -> + Sig.osci Wave.saw + (Expr.fst phaseFreq) + (Expr.snd phaseFreq)) + params) + +stereoFromMonoParametricSignal :: + (Marshal.C x) => + (D2 :*: LLVM.SizeOf (Marshal.Struct x) ~ arrSize, + TypeNum.Natural arrSize) => + (Exp x -> Sig.MV Float) -> + Stereo.T (Exp x) -> Sig.T (Stereo.T (MultiValue.T Float)) +stereoFromMonoParametricSignal f ps = + Causal.toSignal $ + Causal.stereoFromMonoParametric (Causal.fromSignal . f) ps + <<^ + (\() -> Stereo.cons () ()) + +multiMixSignal :: + (TypeNum.Natural n, Marshal.C x, + n :*: LLVM.SizeOf (Marshal.Struct x) ~ arraySize, + TypeNum.Natural arraySize, + Tuple.Undefined a, Tuple.Phi a, A.Additive a) => + (Exp x -> Sig.T a) -> + Exp (MultiValue.Array n x) -> Sig.T a +multiMixSignal f = + Causal.toSignal . multiMix (Causal.fromSignal . f) + +multiMix :: + (TypeNum.Natural n, Marshal.C x, + n :*: LLVM.SizeOf (Marshal.Struct x) ~ arraySize, + TypeNum.Natural arraySize, + Tuple.Undefined b, Tuple.Phi b, A.Additive b) => + (Exp x -> Causal.T a b) -> + Exp (MultiValue.Array n x) -> Causal.T a b +multiMix f ps = + Causal.replicateControlledParam (\x -> Causal.mix <<< first (f x)) ps + <<^ + (\a -> (a, A.zero)) + +stereoOsciSawVector :: Float -> SVL.Vector (Stereo.T Float) +stereoOsciSawVector freq = + Unsafe.performIO $ + (\f -> uncurry (f tonesChunkSize) (stereoOsciParams TypeNum.d5 freq)) + <$> + Render.run stereoOsciSawP + +stereoOsciSawChord :: NonEmpty.T [] Float -> SVL.Vector (Stereo.T Float) +stereoOsciSawChord = + NonEmpty.foldBalanced mixVectorStereo . fmap stereoOsciSawVector + +stereoOsciSawPad :: Word -> NonEmpty.T [] Float -> SVL.Vector (Stereo.T Float) +stereoOsciSawPad dur pitches = + let attack = 20000 + in Unsafe.performIO $ + fmap + (\f -> + Unsafe.performIO $ + pioApply (f attack (dur-attack)) (stereoOsciSawChord pitches)) $ + CausalRender.run + (\intro len -> + Stereo.multiValue <$> + (Causal.envelopeStereo $< fadeEnvelope intro len) + <<^ Stereo.unMultiValue) + +a0, as0, b0, c1, cs1, d1, ds1, e1, f1, fs1, g1, gs1, + a1, as1, b1, c2, cs2, d2, ds2, e2, f2, fs2, g2, gs2, + a2, as2, b2, c3, cs3, d3, ds3, e3, f3, fs3, g3, gs3, + a3, as3, b3, c4, cs4, d4, ds4, e4, f4, fs4, g4, gs4 :: Float +a0 : as0 : b0 : c1 : cs1 : d1 : ds1 : e1 : f1 : fs1 : g1 : gs1 : + a1 : as1 : b1 : c2 : cs2 : d2 : ds2 : e2 : f2 : fs2 : g2 : gs2 : + a2 : as2 : b2 : c3 : cs3 : d3 : ds3 : e3 : f3 : fs3 : g3 : gs3 : + a3 : as3 : b3 : c4 : cs4 : d4 : ds4 : e4 : f4 : fs4 : g4 : gs4 : _ = + iterate ((2 ** recip 12) *) (55/44100) + + +chordSequence :: [(Word, NonEmpty.T [] Float)] +chordSequence = + (2, f1 !: f2 : a2 : c3 : []) : + (1, g1 !: g2 : b2 : d3 : []) : + (2, c2 !: g2 : c3 : e3 : []) : + (1, f1 !: a2 : c3 : f3 : []) : + (2, g1 !: g2 : b2 : d3 : []) : + (1, gs1 !: gs2 : b2 : e3 : []) : + (2, a1 !: e2 : a2 : c3 : []) : + (1, g1 !: g2 : b2 : d3 : []) : + (3, c2 !: g2 : c3 : e3 : []) : + + (2, f1 !: f2 : a2 : c3 : []) : + (1, g1 !: g2 : b2 : d3 : []) : + (2, c2 !: g2 : c3 : e3 : []) : + (1, f1 !: a2 : c3 : f3 : []) : + (2, g1 !: g2 : b2 : d3 : []) : + (1, gs1 !: gs2 : b2 : e3 : []) : + (2, a1 !: e2 : a2 : c3 : []) : + (1, g1 !: g2 : b2 : e3 : []) : + (3, c2 !: e2 : g2 : c3 : []) : + [] + + +withDur :: (Word -> a -> v) -> Word -> a -> (v, NonNeg.Int) +withDur f d ps = + let dur = d*30000 + in (f dur ps, NonNeg.fromNumber $ fromIntegral dur) + + +padMusic :: IO () +padMusic = do + arrange <- SigStL.makeArranger + amplify <- + CausalRender.run $ \volume -> + Stereo.multiValue ^<< + Causal.amplifyStereo volume <<^ + Stereo.unMultiValue + (playStereoVector =<<) $ + pioApply (amplify (0.1::Float)) $ + arrange tonesChunkSize $ + EventListTM.switchTimeR const $ + EventListMT.consTime 0 $ + EventListBT.fromPairList $ + map (\(d,ps) -> withDur stereoOsciSawPad d ps) + chordSequence + + +lowpassSweepControlRateCausal :: + Causal.T + (Stereo.T (MultiValue.T Float)) + (Stereo.T (MultiValue.T Float)) +lowpassSweepControlRateCausal = +-- Causal.stereoFromVector $ + Causal.stereoFromMono $ + UniFilter.lowpass ^<< + Ctrl.processCtrlRate 128 + (lfoSine (UniFilter.parameter (10::Exp Float))) + + +moogSweepControlRateCausal :: + Causal.T + (Stereo.T (MultiValue.T Float)) + (Stereo.T (MultiValue.T Float)) +moogSweepControlRateCausal = +-- Causal.stereoFromVector $ + Causal.stereoFromMono $ + Ctrl.processCtrlRate 128 + (lfoSine (Moog.parameter TypeNum.d8 (10::Exp Float))) + + +filterMusic :: IO () +filterMusic = do + arrange <- SigStL.makeArranger + pad <- stereoOsciSawPadIO + proc <- + CausalRender.run $ \volume -> + Stereo.multiValue ^<< + Causal.amplifyStereo volume <<< + moogSweepControlRateCausal <<^ + Stereo.unMultiValue + (playStereoVector =<<) $ + pioApply (proc (0.05::Float)) $ + arrange tonesChunkSize $ + EventListTM.switchTimeR const $ + EventListMT.consTime 0 $ + EventListBT.fromPairList $ + map (\(d,ps) -> withDur pad d ps) + chordSequence + + + +stereoOsciSawVectorIO :: IO (Float -> SVL.Vector (Stereo.T Float)) +stereoOsciSawVectorIO = + (\f freq -> uncurry (f tonesChunkSize) (stereoOsciParams TypeNum.d5 freq)) + <$> + Render.run stereoOsciSawP + +applyFadeEnvelopeIO :: + IO (Word -> SVL.Vector (Stereo.T Float) -> SVL.Vector (Stereo.T Float)) +applyFadeEnvelopeIO = + let attack = 20000 in + fmap + (\f dur sig -> + Unsafe.performIO $ pioApply (f attack (dur-attack)) sig) $ + CausalRender.run + (\intro len -> + Stereo.multiValue <$> + (Causal.envelopeStereo $< fadeEnvelope intro len) + <<^ Stereo.unMultiValue) + +stereoOsciSawChordIO :: IO (NonEmpty.T [] Float -> SVL.Vector (Stereo.T Float)) +stereoOsciSawChordIO = do + sawv <- stereoOsciSawVectorIO + mix <- mixVectorStereoIO + return (NonEmpty.foldBalanced mix . fmap sawv) + +stereoOsciSawPadIO :: + IO (Word -> NonEmpty.T [] Float -> SVL.Vector (Stereo.T Float)) +stereoOsciSawPadIO = do + chrd <- stereoOsciSawChordIO + envelope <- applyFadeEnvelopeIO + return $ + \ dur pitches -> envelope dur (chrd pitches) + +padMusicIO :: IO () +padMusicIO = do + arrange <- SigStL.makeArranger + pad <- stereoOsciSawPadIO + amplify <- + CausalRender.run $ \volume -> + Stereo.multiValue ^<< + Causal.amplifyStereo volume <<^ + Stereo.unMultiValue + (playStereoVector =<<) $ + pioApply (amplify (0.08::Float)) $ + arrange tonesChunkSize $ + EventListTM.switchTimeR const $ + EventListMT.consTime 0 $ + EventListBT.fromPairList $ + map (uncurry (withDur pad)) $ + chordSequence + +{- +Apply the envelope separately to each tone of the chord +and mix all tones by 'arrange'. +-} +padMusicSeparate :: IO () +padMusicSeparate = do + arrange <- SigStL.makeArranger + osci <- stereoOsciSawVectorIO + env <- applyFadeEnvelopeIO + amplify <- + CausalRender.run $ \volume -> + Stereo.multiValue ^<< + Causal.amplifyStereo volume <<^ + Stereo.unMultiValue + (playStereoVector =<<) $ + pioApply (amplify (0.08::Float)) $ + arrange tonesChunkSize $ + EventList.flatten $ + EventListTM.switchTimeR const $ + EventListMT.consTime 0 $ + EventListBT.fromPairList $ + map (uncurry (withDur (\d ps -> + map (\p -> env d (osci p)) $ NonEmpty.flatten ps))) $ + chordSequence + + +delay :: IO () +delay = + (SVL.writeFile "speedtest.f32" . asMono =<<) $ + fmap (\f -> f tonesChunkSize (0::Word) (10000::Word)) $ + Render.run $ \del dur -> + Causal.delayZero del . Causal.take dur + $* + Sig.osci Wave.saw 0 (frequency 0.01) + +delayStereo :: IO () +delayStereo = + (SVL.writeFile "speedtest.f32" . asStereo =<<) $ + fmap (\f -> f tonesChunkSize (7::Word) (10000::Word)) $ + Render.run $ \del dur -> + Causal.take dur . liftA2 Stereo.consMultiValue id (Causal.delayZero del) + $* + Sig.osci Wave.saw 0 (frequency 0.01) + +delayPhaser :: IO () +delayPhaser = + (SVL.writeFile "speedtest.f32" . asStereo =<<) $ + fmap (\f -> f tonesChunkSize (40000::Word)) $ + Render.run $ \dur -> + Func.compileSignal $ + let osci = Func.fromSignal $ Sig.osci Wave.saw 0 (frequency 0.01) + ctrl = + Func.fromSignal $ + Sig.osci Wave.triangle 0 $ frequency (1/20000) + in Causal.take dur $& + liftA2 Stereo.consMultiValue + osci + (Causal.delayControlledInterpolated Interpolation.cubic 0 100 + $& + (50+50*ctrl) &|& osci) + + + +allpassControl :: + (TypeNum.Natural n) => + Proxy n -> Exp Float -> + Sig.T (Allpass.CascadeParameter n (MultiValue.T Float)) +allpassControl order reduct = + Sig.interpolateConstant reduct $ + lfoSine (Allpass.flangerParameter order) reduct + +allpassPhaserCausal, allpassPhaserPipeline :: + Exp Float -> + Sig.MV Float -> + Sig.MV Float +allpassPhaserCausal reduct xs = + let order = TypeNum.d16 + in 0.5 * Allpass.phaser $< allpassControl order reduct $* xs + +allpassPhaserPipeline reduct xs = + let order = TypeNum.d16 + in (nest (TypeNum.integralFromProxy order) Sig.tail) $ + -- Sig.drop + -- (TypeNum.integralFromProxy order) + (0.5 * Allpass.phaserPipeline $< allpassControl order reduct $* xs) + +allpassPhaser :: IO () +allpassPhaser = + (SVL.writeFile "speedtest.f32" . asMono . SVL.take 10000000 =<<) $ + fmap (\f -> f (SVL.chunkSize 100000) (128::Float)) $ + Render.run $ + \reduct -> +-- allpassPhaserCausal reduct $ + allpassPhaserPipeline reduct $ + Sig.osci Wave.saw 0 (frequency 0.01) + +noise :: IO () +noise = + (SVL.writeFile "speedtest.f32" . asMono . SVL.take 10000000 =<<) $ + fmap ($ SVL.chunkSize 100000) $ + Render.run $ + Sig.noise 0 0.3 + +noisePacked :: IO () +noisePacked = + (SVL.writeFile "speedtest.f32" . asMonoPacked + . SVL.take (div 10000000 4) =<<) $ + fmap ($ SVL.chunkSize 100000) $ + Render.run $ + SigPS.noise 0 0.3 +-- SigPS.pack (SigP.noise 0 0.3) +-- SigPS.packSmall (SigP.noise 0 0.3) + +frequencyModulationStorable :: IO () +frequencyModulationStorable = do + sample <- Render.run $ Sig.osci Wave.saw 0 (frequency 0.01) + f <- + Render.run $ \smp -> + Causal.frequencyModulationLinear smp $* 0.3 + SVL.writeFile "speedtest.f32" . asMono $ + f (SVL.chunkSize 100000) $ SVL.take 1000000 $ sample (SVL.chunkSize 1000) + + +frequencyModulation :: IO () +frequencyModulation = + (SVL.writeFile "speedtest.f32" . asMono . SVL.take 10000000 =<<) $ + fmap ($ SVL.chunkSize 100000) $ + Render.run + (Causal.frequencyModulationLinear (Sig.osci Wave.saw 0 (frequency 0.01)) + $* Sig.exponential2 500000 1) + +frequencyModulationStereo :: IO () +frequencyModulationStereo = do + sample <- Render.run $ Sig.osci Wave.saw 0 (frequency 0.01) + f <- + Render.run $ \smp -> + Stereo.multiValue ^<< + Causal.stereoFromMono (Causal.frequencyModulationLinear smp) + $* Sig.constant (Stereo.cons 0.2999 0.3001) + SVL.writeFile "speedtest.f32" . asStereo $ + f (SVL.chunkSize 100000) $ SVL.take 1000000 $ sample (SVL.chunkSize 1000) + +frequencyModulationProcess :: IO () +frequencyModulationProcess = do + proc <- + CausalRender.run + (Causal.frequencyModulationLinear + (Causal.take 50000 $* Sig.osci Wave.saw 0 (frequency 0.01))) + sample <- Render.run (1 + 0.1 * Sig.osci Wave.approxSine2 0 0.0001) + SVL.writeFile "speedtest.f32" . asMono =<< + pioApply proc (sample (SVL.chunkSize 512)) + + + +quantize :: IO () +quantize = +{- + SV.writeFile "speedtest.f32" $ + asMono $ + (\xs -> SigP.render xs 10000000 ()) $ +-} + (SVL.writeFile "speedtest.f32" . asMono =<<) $ + fmap (SVL.take 10000000) $ + fmap ($ SVL.chunkSize 100000) $ + Render.run $ + (Causal.quantizeLift id + $<# (5.5::Float) + $* Sig.osci Wave.saw 0 (frequency 0.01)) + +quantizedFilterControl :: IO () +quantizedFilterControl = + (SVL.writeFile "speedtest.f32" . asMono =<<) $ + fmap (SVL.take 10000000) $ + fmap ($ SVL.chunkSize 100000) $ + Render.run + (0.3 * (UniFilter.lowpass ^<< Ctrl.process) + $< (Causal.quantizeLift + (Causal.map (UniFilter.parameter 100) <<< + -- (Causal.map (Moog.parameter TypeNum.d8 100) <<< + Causal.map (\x -> 0.01 * exp (2 * x))) + $<# (128::Float) + $* Sig.osci Wave.approxSine2 0 (frequency (0.1/44100))) + $* Sig.osci Wave.saw 0 (frequency 0.01)) + + +arrowNonShared :: IO () +arrowNonShared = + (SVL.writeFile "speedtest.f32" . asStereo =<<) $ + fmap (SVL.take 10000000) $ + fmap ($ SVL.chunkSize 100000) $ + Render.run + (let osci = Causal.osci Wave.approxSine2 + in liftA2 Stereo.consMultiValue osci osci $* Sig.constant (0, 0.01)) + +arrowShared :: IO () +arrowShared = + (SVL.writeFile "speedtest.f32" . asStereo =<<) $ + fmap (SVL.take 10000000) $ + fmap ($ SVL.chunkSize 100000) $ + Render.run + (let osci = Func.lift $ Causal.osci Wave.approxSine2 + in Func.compile (liftA2 Stereo.consMultiValue osci osci) $* + Sig.constant (0, 0.01)) + +arrowIndependent :: IO () +arrowIndependent = + (SVL.writeFile "speedtest.f32" . asStereo =<<) $ + fmap (SVL.take 10000000) $ + fmap ($ SVL.chunkSize 100000) $ + Render.run + (let osci = Causal.osci Wave.approxSine2 + in Func.compile + (uncurry Stereo.consMultiValue <$> + (osci *** osci $& Func.lift id)) $* + Sig.constant ((0, 0.01), (0.25, 0.01001))) + + +rampDown :: Int -> SV.Vector Float +rampDown n = + SigS.toStrictStorableSignal n $ + CtrlS.line n (1, 0) + +impulses :: Int -> Float -> SVL.Vector Float +impulses n x = + SVL.fromChunks $ + concatMap (\k -> [SV.singleton x, SV.replicate k 0]) $ + take n $ iterate (2*) 1 + +convolution :: IO () +convolution = + (SVL.writeFile "speedtest.f32" . asMono =<<) $ + ((\f -> + pioApply (f $ Render.buffer $ rampDown 1000) (impulses 18 0.1)) =<<) $ + CausalRender.run FiltNR.convolve + +convolutionPacked :: IO () +convolutionPacked = do + pack <- Render.run SigPS.pack + impulsesPacked <- pack SVL.defaultChunkSize $ impulses 18 0.1 + (SVL.writeFile "speedtest.f32" . asMonoPacked =<<) $ + ((\f -> + pioApply (f $ Render.buffer $ rampDown 1000) impulsesPacked) =<<) $ + CausalRender.run FiltNR.convolvePacked + + +helixSaw :: IO () +helixSaw = do + let srcFreq = 0.01 + srcLength :: Word + srcLength = 40000 + osci <- Render.run $ \dur -> Sig.osci Wave.saw 0 srcFreq * (1-Sig.ramp dur) + let perc = + asMono $ osci (fromIntegral srcLength) srcLength + SV.writeFile "osci-saw.f32" perc + stretched <- + Render.run $ \dur sig -> + Func.compileSignal $ + (Helix.static Interpolation.cubic Interpolation.cubic + 100 (recip srcFreq) sig + $& + (Func.fromSignal $ Sig.amplify (fromIntegral srcLength) $ Sig.ramp dur) + &|& + (Causal.osciCore $& 0 &|& 0.01)) + SVL.writeFile "osci-stretched.f32" . asMono =<< + stretched SVL.defaultChunkSize (80000::Word) (Render.buffer perc) + + +loadTomato :: IO (Float, SVL.Vector Float) +loadTomato = do + let Sample.Info name _sampleRate positions = Sample.tomatensalat + word <- Sample.load (Default.sampleDirectory name) + return (Sample.period $ head positions, word) + +helixOsci :: Exp Float -> Func.T a (MultiValue.T Float) +helixOsci period = + Causal.osciCore $& 0 &|& Func.fromSignal (Sig.constant (recip period)) + +helixSpeechStaticSig :: + Func.T () (MultiValue.T Float) -> + Exp (Source.StorableVector Float) -> + Exp Float -> + Sig.MV Float +helixSpeechStaticSig shape word period = + Func.compileSignal + (Helix.static Interpolation.linear Interpolation.linear + (Expr.roundToIntFast period) period word + $& + shape + &|& + helixOsci period) + +helixSpeechStaticSpeed :: + Exp Float -> + Exp (Source.StorableVector Float) -> + Exp Float -> + Sig.MV Float +helixSpeechStaticSpeed speed word = + helixSpeechStaticSig + (Func.fromSignal + (Causal.takeWhile + (Expr.fromIntegral (Source.storableVectorLength word) >*) + $* + Sig.rampSlope speed)) + word + +helixSpeechStatic :: IO () +helixSpeechStatic = do + smp <- loadTomato + stretched <- + Render.run $ \speed (period, word) -> + helixSpeechStaticSpeed speed word period + (SVL.writeFile "speech-stretched.f32" . asMono =<<) $ + stretched SVL.defaultChunkSize (0.5::Float) $ + mapSnd (Render.buffer . SV.concat . SVL.chunks) smp + +helixSpeechDynamicSig :: + Func.T () (MultiValue.T Float) -> + Sig.MV Float -> + Exp Float -> + Sig.MV Float +helixSpeechDynamicSig shape word period = + Func.compileSignal + (Helix.dynamicLimited Interpolation.linear Interpolation.linear + (Expr.roundToIntFast period) period word + $& + shape + &|& + helixOsci period) + +helixSpeechDynamicSpeed :: + Exp Float -> + Sig.MV Float -> + Exp Float -> + Sig.MV Float +helixSpeechDynamicSpeed speed = + helixSpeechDynamicSig (Func.fromSignal $ Sig.constant speed) + +helixSpeechDynamic :: IO () +helixSpeechDynamic = do + smp <- loadTomato + stretched <- + Render.run $ \speed (period, word) -> + helixSpeechDynamicSpeed speed word period + SVL.writeFile "speech-stretched.f32" $ asMono $ + stretched SVL.defaultChunkSize (0.5::Float) smp + +helixSpeechCompare :: IO () +helixSpeechCompare = do + (per,smp) <- loadTomato + stretched <- + Render.run $ \speed period word wordBuffer -> + fmap Stereo.multiValue $ + sequenceA $ + Stereo.cons + (helixSpeechStaticSpeed speed wordBuffer period) + (helixSpeechDynamicSpeed speed word period) + SVL.writeFile "speech-stretched.f32" $ asStereo $ + stretched SVL.defaultChunkSize (0.5::Float) + per smp (Render.buffer . SV.concat . SVL.chunks $ smp) + +helixSpeechVariCompare :: IO () +helixSpeechVariCompare = do + (per,smp) <- loadTomato + stretched <- + Render.run $ \period word wordBuffer -> + fmap Stereo.multiValue $ + sequenceA $ + let speed = + Func.fromSignal $ Sig.cycle $ + Sig.fromArray $ Expr.cons $ + (MultiValue.Array [0.2, 0.5, 1, 1.5, 1.8] + :: MultiValue.Array TypeNum.D5 Float) + in Stereo.cons + (helixSpeechStaticSig + (Causal.integrateZero $& speed) + wordBuffer period) + (helixSpeechDynamicSig speed word period) + SVL.writeFile "speech-stretched.f32" $ asStereo $ + stretched SVL.defaultChunkSize + per smp (Render.buffer . SV.concat . SVL.chunks $ smp) + +helixLimited :: IO () +helixLimited = do + let period = 100 + srcLength :: Int + srcLength = 500 + dstLength = 5000 + speed :: Exp Float + speed = 0.5 + osci = + 0.5 + * + Sig.ramp (fromIntegral srcLength) + * + Sig.osci Wave.approxSine2 0 (recip period) + renderOsci <- Render.run osci + let osciVec = renderOsci srcLength + SV.writeFile "helix-orig.f32" $ asMono osciVec + + let stretchedStatic osciBuffer = + Helix.static Interpolation.linear Interpolation.linear + (Expr.roundToIntFast period) period osciBuffer + $& + Func.fromSignal (Sig.rampSlope speed) + &|& + helixOsci period + stretchedDynamic = + Helix.dynamic Interpolation.linear Interpolation.linear + (Expr.roundToIntFast period) period osci + $& + Func.fromSignal (Sig.constant speed) + &|& + helixOsci period + stretched osciBuffer = + liftA2 Stereo.consMultiValue + (stretchedStatic osciBuffer) stretchedDynamic + renderHelix <- Render.run $ Func.compileSignal . stretched + SV.writeFile "helix-stretched.f32" $ asStereo $ + renderHelix dstLength (Render.buffer osciVec) + +cycleRamp :: IO () +cycleRamp = + SVL.writeFile "speedtest.f32" . asMono . + (\f -> f SVL.defaultChunkSize (10000::Word)) =<< + Render.run + (\dur -> + Causal.take 100000 $* + Sig.cycle (Sig.append (Sig.ramp dur) (1 - Sig.ramp dur))) + +zigZag :: IO () +zigZag = + SVL.writeFile "speedtest.f32" . asMono . + (\f -> f SVL.defaultChunkSize (-3::Float)) =<< + Render.run + (\start -> Causal.take 100000 $* (Helix.zigZag start $* 0.0001)) + +zigZagPacked :: IO () +zigZagPacked = + SVL.writeFile "speedtest.f32" . asMonoPacked . + (\f -> f SVL.defaultChunkSize (-3::Float)) =<< + Render.run + (\start -> + let vectorSize = 4 + in Causal.take (fromInteger $ div 100000 vectorSize) $* + (Helix.zigZagPacked start $* 0.0001)) + + +trigger :: IO () +trigger = + (SVL.writeFile "speedtest.f32" . asMono =<<) $ + fmap ($ SVL.defaultChunkSize) $ + Render.run + (let pause len = + CausalClass.applyConst (Causal.take len) Maybe.nothing + pulse :: Float -> Exp Word -> Sig.T (Maybe.T (MultiValue.T Float)) + pulse freq len = + Causal.take len . + arr (flip Maybe.fromBool (MultiValue.cons freq) . unbool) . + Causal.delay1 Expr.true $*# False + in (Causal.zipWith ExprMaybe.select + $> Sig.noise 0 (0.01 :: Exp Float)) $* + (Causal.trigger (\freq -> Causal.take 150000 $* pingSigP freq) $* + pause 50000 <> + pulse 0.004 100000 <> + pulse 0.005 200000 <> + pulse 0.006 400000)) + +-- FixMe: duplicate of CausalExp.ProcessPrivate +unbool :: MultiValue.T Bool -> LLVM.Value Bool +unbool (MultiValue.Cons b) = b + + +triggerLFO :: Sig.MV Float +triggerLFO = + Sig.osci Wave.approxSine2 0 0.00015 + + + Sig.osci Wave.approxSine2 0 0.000037 + +trackZeros :: Causal.MV Float Bool +trackZeros = + Causal.zipWith (\x y -> x &&* Expr.not y) . + (id &&& Causal.delay1 Expr.false) . + Causal.map (>* 0) + +fmPingSig :: Exp Float -> Exp Float -> Sig.MV Float +fmPingSig freq depth = + Sig.exponential2 5000 1 + * + ((Causal.osci Wave.approxSine2 $> Sig.constant freq) + $* + (Sig.constant depth * Sig.osci Wave.approxSine2 0 (2*freq))) + +sweepTrigger :: IO () +sweepTrigger = + (SVL.writeFile "speedtest.f32" . asMono =<<) $ + fmap ($ SVL.defaultChunkSize) $ + Render.run + ((Causal.zipWith ExprMaybe.select $> Sig.noise 0 0.01) $* + (Causal.trigger (fmPingSig 0.005) $* + liftA2 (Maybe.fromBool . unbool) + (Causal.take 10000000 . trackZeros $* triggerLFO) + (5 * Sig.osci Wave.approxSine2 0 0.00001))) + + +main :: IO () +main = do + LLVM.initializeNativeTarget + filterSweepComplex diff --git a/example/Synthesizer/LLVM/TestALSA.hs b/example/Synthesizer/LLVM/TestALSA.hs new file mode 100644 --- /dev/null +++ b/example/Synthesizer/LLVM/TestALSA.hs @@ -0,0 +1,12 @@ +module Main where + +import qualified Synthesizer.LLVM.LNdW2011 as LNdW + +import Control.Monad (when) + + +main :: IO () +main = do + when True LNdW.flyPacked + when False LNdW.modulation + when False LNdW.bubblesPacked diff --git a/jack/Synthesizer/LLVM/Server/JACK.hs b/jack/Synthesizer/LLVM/Server/JACK.hs new file mode 100644 --- /dev/null +++ b/jack/Synthesizer/LLVM/Server/JACK.hs @@ -0,0 +1,263 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +module Main where +-- module Synthesizer.LLVM.Server.JACK where + +import qualified Synthesizer.LLVM.Server.CausalPacked.Arrange as Arrange + +import Synthesizer.LLVM.Server.CommonPacked (Vector, VectorSize, vectorSize) + +import qualified Synthesizer.LLVM.Server.Option as Option +import Synthesizer.LLVM.Server.Common + +import qualified Synthesizer.MIDI.CausalIO.Process as MIO +import qualified Synthesizer.CausalIO.Process as PIO + +import qualified Synthesizer.LLVM.Causal.Render as CausalRender +import qualified Synthesizer.LLVM.Causal.ProcessPacked as CausalPS +import qualified Synthesizer.LLVM.Causal.Process as Causal +import qualified Synthesizer.LLVM.Storable.Signal as SigStL + +import qualified Synthesizer.LLVM.Frame.StereoInterleaved as StereoInt +import qualified Synthesizer.LLVM.Frame.Stereo as Stereo + +import qualified Type.Data.Num.Decimal as TypeNum + +import qualified Data.StorableVector as SV +import qualified Data.StorableVector.Base as SVB +import Foreign.Marshal.Array (copyArray) + +import qualified Data.EventList.Relative.TimeTime as EventListTT +import qualified Data.EventList.Absolute.TimeTime as EventListAbsTT +import qualified Data.EventList.Absolute.TimeMixed as EventListAbsTM + +import qualified Synthesizer.Zip as Zip + +import qualified Sound.JACK.Audio as JackAudio +import qualified Sound.JACK.MIDI as JackMIDI +import qualified Sound.JACK.Exception as JackExc +import qualified Sound.JACK as JACK + +import Data.IORef (newIORef, readIORef, writeIORef) + +import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg +import qualified Sound.MIDI.Message.Channel as ChannelMsg +import qualified Sound.MIDI.Message as Msg + +import qualified Control.Monad.Exception.Synchronous as Exc +import qualified Control.Monad.Trans.Class as MT + +import qualified System.Path.PartClass as PathClass +import qualified System.Path as Path + +import Control.Arrow (arr, (<<<), (^<<)) +import Control.Category (id) + +import qualified System.Random as Random +import qualified Numeric.NonNegative.Wrapper as NonNegW + +import Prelude hiding (Real, id) + + +type StereoVector = StereoInt.T VectorSize Real + +type StrictTime = NonNegW.Integer + + +strictTimeFromNFrames :: JACK.NFrames -> StrictTime +strictTimeFromNFrames (JACK.NFrames n) = + NonNegW.fromNumberMsg "strictTimeFromNFrames" $ fromIntegral n + +writeBlock :: JackAudio.Port JACK.Output -> SV.Vector Real -> IO () +writeBlock output block = do + outArr <- + JackAudio.getBufferPtr output $ + JACK.NFrames $ fromIntegral $ SV.length block + SVB.withStartPtr (SV.map realToFrac block) $ + copyArray outArr + +{-# INLINE playFromEvents #-} +playFromEvents :: + (JACK.Client -> + (ports -> Exc.ExceptionalT JackExc.All IO ()) -> + Exc.ExceptionalT JackExc.All IO ()) -> + (ports -> block -> IO ()) -> + Option.T -> + (SampleRate Real -> + PIO.T Events block) -> + IO () +playFromEvents withOutPorts writeBlocks opt process = do + let Option.ClientName name = Option.clientName opt + JACK.handleExceptions $ + JACK.withClientDefault name $ \client -> + JACK.withPort client "input" $ \input -> + withOutPorts client $ \output -> do + sampleRate <- MT.lift $ JACK.getSampleRate client + case process (SampleRate $ fromIntegral sampleRate) of + PIO.Cons next create delete -> + {- + Is the use of 'bracket' correct? + I think 'delete' must be called with the final state, + not with the initial one. + -} + Exc.bracketT (MT.lift create) (MT.lift . delete) $ \start -> do + stateRef <- MT.lift $ newIORef start + let jackProcess nframes = do + evs <- JackMIDI.readEventsFromPort input nframes + MT.lift $ do + let deconsNFrames (JACK.NFrames n) = fromIntegral n + (block, state) <- + next + (EventListTT.collectCoincident $ + EventListTT.mapTime + (NonNegW.fromNumberMsg "JACK.playFromEvents") $ + EventListTT.fromAbsoluteEventList $ + EventListAbsTT.mapTime + (flip div (fromIntegral vectorSize) . + deconsNFrames) $ + EventListAbsTM.snocTime evs nframes) +{- + (EventListTT.collectCoincident $ + EventListTT.mapTime strictTimeFromNFrames $ + EventListTT.fromAbsoluteEventList $ + EventListAbsTM.snocTime evs nframes) +-} + =<< readIORef stateRef + writeIORef stateRef state + writeBlocks output block + JACK.withProcess client jackProcess $ + JACK.withActivation client $ MT.lift $ do + putStrLn $ "started " ++ name ++ "..." + JACK.waitForBreak +-- MT.lift $ readIORef stateRef + +playMonoFromEvents :: + Option.T -> + (SampleRate Real -> + PIO.T Events (SV.Vector Vector)) -> + IO () +playMonoFromEvents opt proc = + playFromEvents + (flip JACK.withPort "mono") + writeBlock + opt + (\sampleRate -> SigStL.unpackStrict ^<< proc sampleRate) + +playStereoFromEvents :: + Option.T -> + (SampleRate Real -> + PIO.T Events (Zip.T (SV.Vector Vector) (SV.Vector Vector))) -> + IO () +playStereoFromEvents opt proc = + playFromEvents + (\client f -> + JACK.withPort client "left" $ \left -> + JACK.withPort client "right" $ \right -> + f (left, right)) + (\(leftPort,rightPort) (Zip.Cons leftBlock rightBlock) -> + writeBlock leftPort leftBlock >> + writeBlock rightPort rightBlock) + opt + (\sampleRate -> + Zip.arrowSplit SigStL.unpackStrict SigStL.unpackStrict + ^<< + proc sampleRate) + + +keyboard :: IO () +keyboard = do + opt <- Option.get + proc <- Arrange.keyboard + + playMonoFromEvents opt $ proc (Option.channel opt) + + +type Events = MIO.Events Msg.T + +unconsStereo :: Stereo.T t -> (t, t) +unconsStereo x = + (Stereo.left x, Stereo.right x) + +keyboardFM :: IO () +keyboardFM = do + opt <- Option.get + playStereoFromEvents opt =<< + Arrange.keyboardFM (arr unconsStereo) (Option.channel opt) + + +keyboardDetuneFMCore :: + (PathClass.AbsRel ar) => + Path.Dir ar -> + IO (ChannelMsg.Channel -> VoiceMsg.Program -> + SampleRate Real -> + PIO.T + Events + (Zip.T (SV.Vector Vector) (SV.Vector Vector))) +keyboardDetuneFMCore = + Arrange.keyboardDetuneFMCore (arr unconsStereo) + +keyboardDetuneFM :: IO () +keyboardDetuneFM = do + opt <- Option.get + proc <- keyboardDetuneFMCore (Option.sampleDirectory opt) + playStereoFromEvents opt $ + proc (Option.channel opt) (VoiceMsg.toProgram 0) + +keyboardMultiChannel :: IO () +keyboardMultiChannel = do + opt <- Option.get + proc <- keyboardDetuneFMCore (Option.sampleDirectory opt) + mix <- CausalRender.run Causal.mix + + playStereoFromEvents opt $ \ sampleRate -> + foldl1 + (\x y -> mix <<< Zip.arrowFanout x y) + (map + (\chan -> + proc (ChannelMsg.toChannel chan) (VoiceMsg.toProgram 0) + sampleRate) + [0 .. 3]) + + +voderBand :: IO () +voderBand = do + opt <- Option.get + proc <- + Arrange.voderBand + (arr unconsStereo) + (Option.sampleDirectory opt) + + playStereoFromEvents opt $ \ sampleRate -> + proc (Option.channel opt) (VoiceMsg.toProgram 5) sampleRate + + +voderMaskSeparated :: IO () +voderMaskSeparated = do + opt <- Option.get + let postProcessing params = + if True + then + CausalPS.pack + (Stereo.arrowFromChannels + (Causal.reverbExplicit $ Stereo.left params) + (Causal.reverbExplicit $ Stereo.right params)) + else id + proc <- + Arrange.voderMaskSeparated + (\reverbParams -> unconsStereo ^<< postProcessing reverbParams) + (Option.sampleDirectory opt) + + playStereoFromEvents opt $ \ sampleRate@(SampleRate rate) -> + proc + (Option.channel opt) (Option.extraChannel opt) + (VoiceMsg.toProgram 4) sampleRate + (fmap + (\seed -> + Causal.reverbParams + (Random.mkStdGen seed) TypeNum.d16 (0.92,0.98) + (round (rate/200), round (rate/40))) + (Stereo.cons 42 23)) + + +main :: IO () +main = keyboardMultiChannel diff --git a/jack/Synthesizer/LLVM/Server/Option.hs b/jack/Synthesizer/LLVM/Server/Option.hs new file mode 100644 --- /dev/null +++ b/jack/Synthesizer/LLVM/Server/Option.hs @@ -0,0 +1,37 @@ +module Synthesizer.LLVM.Server.Option ( + T(..), + Option.ClientName(ClientName), + get, + ) where + +import qualified Synthesizer.LLVM.Server.OptionCommon as Option +import qualified Sound.MIDI.Message.Channel as ChannelMsg + +import qualified System.Path as Path +import qualified Options.Applicative as OP +import Control.Applicative (pure, (<*>)) + +import Prelude hiding (Real) + + +data T = + Cons { + clientName :: Option.ClientName, + channel, extraChannel :: ChannelMsg.Channel, + sampleDirectory :: Path.AbsRelDir + } + deriving (Show) + + + +options :: OP.Parser T +options = + pure Cons + <*> Option.clientName "Name of the JACK client" + <*> Option.channel + <*> Option.extraChannel + <*> Option.sampleDirectory + + +get :: IO T +get = Option.get options "Live software synthesizer using LLVM and JACK" diff --git a/render/Synthesizer/LLVM/Server/Option.hs b/render/Synthesizer/LLVM/Server/Option.hs new file mode 100644 --- /dev/null +++ b/render/Synthesizer/LLVM/Server/Option.hs @@ -0,0 +1,63 @@ +module Synthesizer.LLVM.Server.Option ( + T(..), + get, + ) where + +import qualified Synthesizer.LLVM.Server.OptionCommon as Option +import qualified Synthesizer.LLVM.Server.Default as Default +import Synthesizer.LLVM.Server.Common (SampleRate) +import qualified Data.StorableVector.Lazy as SVL + +import qualified Sound.MIDI.Message.Channel as ChannelMsg + +import qualified System.Path as Path + +import qualified Options.Applicative as OP +import Control.Applicative (pure, (<$>), (<*>)) +import Data.Maybe (fromMaybe) +import Data.Monoid ((<>)) + +import Prelude hiding (Real) + + +data T = + Cons { + channel, extraChannel :: ChannelMsg.Channel, + sampleDirectory :: Path.AbsRelDir, + sampleRate :: SampleRate Int, + chunkSize :: SVL.ChunkSize +-- volume :: Float + } + deriving (Show) + + + +options :: OP.Parser T +options = + pure Cons + <*> Option.channel + <*> Option.extraChannel + <*> Option.sampleDirectory + <*> fmap (fromMaybe Default.sampleRate) Option.sampleRate + <*> Option.blockSize (SVL.chunkSize (128*1024)) +{- + <*> + (OP.option (parseNumber "volume" (const True) "any") + (OP.short 'v' <> + OP.long "volume" <> + OP.metavar "FACTOR" <> + OP.help "global volume") +-} + + +parser :: OP.Parser (T, String, Maybe String) +parser = + pure (,,) + <*> options + <*> OP.strArgument (OP.metavar "infile.mid") + <*> OP.argument (Just <$> OP.str) + (OP.metavar "outfile.wav" <> OP.value Nothing) + + +get :: IO (T, String, Maybe String) +get = Option.get parser "Render MIDI to audio files using LLVM and SoX" diff --git a/render/Synthesizer/LLVM/Server/Render.hs b/render/Synthesizer/LLVM/Server/Render.hs new file mode 100644 --- /dev/null +++ b/render/Synthesizer/LLVM/Server/Render.hs @@ -0,0 +1,111 @@ +module Main (main) where +-- module Synthesizer.LLVM.Server.Render where + +import qualified Synthesizer.LLVM.Server.CausalPacked.Arrange as Arrange +import Synthesizer.LLVM.Server.CommonPacked + (vectorSize, vectorRate) + +import qualified Synthesizer.LLVM.Server.Option as Option +import qualified Synthesizer.LLVM.Frame.Stereo as Stereo +import Synthesizer.LLVM.Server.CausalPacked.Common (chopEvents) +import Synthesizer.LLVM.Server.Common + +import qualified Synthesizer.CausalIO.Process as PIO +import qualified Synthesizer.PiecewiseConstant.Signal as PC + +import Shell.Utility.Exit (exitFailureMsg) + +import qualified Data.StorableVector.Lazy as SVL + +import qualified Data.EventList.Relative.TimeBody as EventList +import qualified Data.EventList.Relative.TimeMixed as EventListTM + +import qualified Sound.MIDI.File as MidiFile +import qualified Sound.MIDI.File.Event as FileEvent +import qualified Sound.MIDI.File.Load as Load + +import qualified Sound.Sox.Write as SoxWrite +import qualified Sound.Sox.Play as SoxPlay + +import Control.Applicative ((<*>)) + +import Data.Monoid (mempty) + +import qualified Numeric.NonNegative.Wrapper as NonNegW + +import qualified System.Exit as Exit + +import Prelude hiding (Real, id) + + + +strictTimeFromChunkSize :: SVL.ChunkSize -> PC.StrictTime +strictTimeFromChunkSize (SVL.ChunkSize n) = + NonNegW.fromNumberMsg "strictTimeFromNFrames" $ fromIntegral n + + +{- +This is the duration of rendering after the last MIDI event. + +Optimally we would stop rendering after the last sound ends. +Unfortunately with causal processes we have no way +to make the output audio stream longer than the input MIDI stream. +We might make the stream infinitely long +and add an End-Of-Stream marker in the MIDI input +that tells the 'arrange' process to stop after the last sound. +-} +padTime :: Integer +padTime = 2 + +render :: Option.T -> IO (MidiFile.T -> SVL.Vector (Stereo.T Real)) +render opt = do + proc <- + case fromInteger 0 :: Int of + 0 -> Arrange.keyboardMultiChannel $ Option.sampleDirectory opt + _ -> Arrange.voderMaskMulti $ Option.sampleDirectory opt + run <- PIO.runCont $ proc $ fmap fromIntegral $ Option.sampleRate opt + return $ + SVL.fromChunks . + run (const []) . + chopEvents (strictTimeFromChunkSize $ Option.chunkSize opt) . + flip EventListTM.snocTime + (NonNegW.fromNumberMsg "render end pad" $ + case Option.sampleRate opt of + SampleRate rate -> padTime * (fromIntegral $ div rate vectorSize)) . +-- flip EventListTM.snocTime (NonNegW.fromNumber 1) . +-- flip EventListTM.snocTime mempty . + EventList.collectCoincident . + EventList.mapMaybe (\ev -> + case ev of + FileEvent.MIDIEvent mev -> Just mev + _ -> Nothing) . + EventList.resample + (vectorRate $ fmap fromIntegral $ Option.sampleRate opt) . + (\(MidiFile.Cons typ division tracks) -> + MidiFile.mergeTracks typ $ + map (MidiFile.secondsFromTicks division) tracks) + +handleSoxExit :: IO Exit.ExitCode -> IO () +handleSoxExit sox = do + soxResult <- sox + case soxResult of + Exit.ExitSuccess -> return () + Exit.ExitFailure n -> + exitFailureMsg $ "'sox' aborted with exit code " ++ show n + +main :: IO () +main = do + (opt, midiPath, mWavePath) <- Option.get + case Option.sampleRate opt of + SampleRate rate -> do + audio <- render opt <*> Load.fromFile midiPath + case mWavePath of + Nothing -> + handleSoxExit $ SoxPlay.simple SVL.hPut mempty rate audio + Just wavePath -> + if True + then + -- Rendering to SoX ends with an error code 13, but why? + handleSoxExit $ + SoxWrite.simple SVL.hPut mempty wavePath rate audio + else SVL.writeFile wavePath audio diff --git a/server/Synthesizer/LLVM/Server/CausalPacked/Arrange.hs b/server/Synthesizer/LLVM/Server/CausalPacked/Arrange.hs new file mode 100644 --- /dev/null +++ b/server/Synthesizer/LLVM/Server/CausalPacked/Arrange.hs @@ -0,0 +1,658 @@ +module Synthesizer.LLVM.Server.CausalPacked.Arrange where + +import Synthesizer.LLVM.Server.CommonPacked + (VectorSize, Vector, VectorValue, stair) + +import qualified Sound.MIDI.Controller as Ctrl + +import qualified Synthesizer.LLVM.Server.CausalPacked.Speech as Speech +import qualified Synthesizer.LLVM.Server.CausalPacked.Instrument as Instr +import qualified Synthesizer.LLVM.Server.CausalPacked.InstrumentPlug as InstrPlug +import qualified Synthesizer.LLVM.Server.SampledSound as Sample +import Synthesizer.LLVM.Server.Common + +import qualified Synthesizer.MIDI.PiecewiseConstant.ControllerSet as PCS +import qualified Synthesizer.MIDI.CausalIO.ControllerSet as MCS +import qualified Synthesizer.MIDI.CausalIO.Process as MIO +import qualified Synthesizer.MIDI.Value as MV +import qualified Synthesizer.CausalIO.Process as PIO +import qualified Synthesizer.PiecewiseConstant.Signal as PC + +import qualified Synthesizer.LLVM.Plug.Output as POut +import qualified Synthesizer.LLVM.Causal.Render as CausalRender +import qualified Synthesizer.LLVM.Causal.ProcessPacked as CausalPS +import qualified Synthesizer.LLVM.Causal.Process as Causal +import qualified Synthesizer.LLVM.Generator.Render as Render +import qualified Synthesizer.LLVM.Storable.Process as CausalSt +import qualified Synthesizer.LLVM.Storable.Signal as SigStL + +import qualified Synthesizer.LLVM.Frame.StereoInterleaved as StereoInt +import qualified Synthesizer.LLVM.Frame.Stereo as Stereo +import qualified Synthesizer.LLVM.Frame.SerialVector as Serial + +import qualified Data.EventList.Relative.TimeTime as EventListTT + +import qualified Data.StorableVector as SV + +import qualified Synthesizer.Zip as Zip + +import qualified Synthesizer.MIDI.Dimensional.ValuePlain as DMV +import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg +import qualified Sound.MIDI.Message.Channel as ChannelMsg +import qualified Sound.MIDI.Message.Class.Construct as Construct +import qualified Sound.MIDI.Message.Class.Check as Check + +import qualified System.Path.PartClass as PathClass +import qualified System.Path as Path + +import Control.Arrow (Arrow, arr, (***), (<<<), (^<<), (<<^)) +import Control.Category (id) +import Control.Applicative ((<*>)) + +import qualified Data.List.HT as ListHT +import qualified Data.Map as Map +import Data.Maybe.HT (toMaybe) + +import qualified Number.DimensionTerm as DN +import qualified Algebra.DimensionTerm as Dim + +import qualified Algebra.Transcendental as Trans + +import qualified Numeric.NonNegative.Wrapper as NonNegW + +import Prelude hiding (Real, id) + + + +type StereoVector = StereoInt.T VectorSize Real + + +keyboard :: + (Check.C msg) => + IO (ChannelMsg.Channel -> + SampleRate Real -> + PIO.T (MIO.Events msg) (SV.Vector Vector)) +keyboard = do + arrange <- CausalSt.makeArranger + amp <- CausalRender.run (CausalPS.amplify 0.2) + + ping <- Instr.pingRelease + + return $ \ chan sampleRate -> + amp + <<< + arrange + <<< + arr shortTime + <<< + MIO.sequenceCore chan + (\ _pgm -> ping 0.8 0.1 sampleRate) + + +infixr 3 &+& + +(&+&) :: + (Arrow arrow) => + arrow a b -> arrow a c -> arrow a (Zip.T b c) +(&+&) = Zip.arrowFanout + + +controllerExponentialDirect :: + (Check.C msg, Trans.C y, Dim.C v) => + ChannelMsg.Channel -> + VoiceMsg.Controller -> + (DN.T v y, DN.T v y) -> + DN.T v y -> + PIO.T (MIO.Events msg) (Instr.Control (DN.T v y)) +controllerExponentialDirect chan ctrl bnds initial = + MIO.slice + (Check.controller chan ctrl) + (DMV.controllerExponential bnds) + initial + +shortTime :: + EventListTT.T PC.StrictTime body -> + EventListTT.T PC.ShortStrictTime body +shortTime = + EventListTT.mapTime + (NonNegW.fromNumberUnsafe . fromInteger . NonNegW.toNumber) + +keyboardFM :: + (Check.C msg, POut.Default b) => + Causal.T (Stereo.T VectorValue) (POut.Element b) -> + ChannelMsg.Channel -> + IO (SampleRate Real -> PIO.T (MIO.Events msg) b) +keyboardFM emitStereo chan = do + arrange <- CausalSt.makeArranger + amp <- + CausalRender.run + (emitStereo <<< CausalPS.amplifyStereo 0.2 <<^ Stereo.unMultiValue) + + ping <- Instr.pingStereoReleaseFM + + return $ \ sampleRate -> + amp + <<< + arrange + <<< + arr shortTime + <<< + -- ToDo: fetch parameters from controllers + MIO.sequenceModulated chan + (\ _pgm -> ping sampleRate) + <<< + id &+& + ((controllerExponentialDirect chan + Ctrl.attackTime (DN.time 0.25, DN.time 2.5) (DN.time 0.8) + &+& + controllerExponentialDirect chan + Ctrl.releaseTime (DN.time 0.03, DN.time 0.3) (DN.time 0.1)) + &+& + ((MIO.controllerExponential chan controllerTimbre0 (1/pi,0.01) 0.05 + &+& + controllerExponentialDirect chan controllerTimbre1 + (DN.time 0.01, DN.time 10) + (DN.time 5)) + &+& + ((MIO.controllerLinear chan Ctrl.soundController5 (0,2) 1 + &+& + controllerExponentialDirect chan Ctrl.soundController7 + (DN.time 0.25, DN.time 2.5) + (DN.time 0.8)) + &+& + (MIO.controllerLinear chan controllerDetune (0,0.005) 0.001 + &+& + MIO.bendWheelPressure chan 2 0.04 0.03)))) + + +controllerExponentialDim :: + (Arrow arrow, + Trans.C y, Dim.C v) => + VoiceMsg.Controller -> + (DN.T v y, DN.T v y) -> + DN.T v y -> + MCS.T arrow (DN.T v y) +controllerExponentialDim ctrl bnds initial = + MCS.slice + (MCS.Controller ctrl) + (DMV.controllerExponential bnds) + initial + + +timeControlPercussive, timeControlString :: + PIO.T + (PCS.T MCS.Controller Int) + (Zip.T + (Instr.Control Instr.Time) + (Instr.Control Instr.Time)) + +timeControlPercussive = + controllerExponentialDim Ctrl.attackTime + (DN.time 0.1, DN.time 2.5) (DN.time 0.8) + &+& + controllerExponentialDim Ctrl.releaseTime + (DN.time 0.03, DN.time 0.3) (DN.time 0.1) + +timeControlString = + controllerExponentialDim Ctrl.attackTime + (DN.time 0.005, DN.time 0.1) (DN.time 0.1) + &+& + controllerExponentialDim Ctrl.releaseTime + (DN.time 0.03, DN.time 0.3) (DN.time 0.2) + + +keyboardDetuneFMCore :: + (PathClass.AbsRel ar, Check.C msg, POut.Default b) => + Causal.T (Stereo.T VectorValue) (POut.Element b) -> + Path.Dir ar -> + IO (ChannelMsg.Channel -> VoiceMsg.Program -> + SampleRate Real -> PIO.T (MIO.Events msg) b) +keyboardDetuneFMCore emitStereo smpDir = do + arrange <- keyboardDetuneFMConstVolume smpDir + amp <- + CausalRender.run + (emitStereo <<< + Causal.envelopeStereo <<< + Causal.map Serial.upsample *** arr Stereo.unMultiValue) + return $ \chan initPgm rate -> + amp + <<< + MIO.controllerExponential chan controllerVolume (0.001, 1) (0.2::Float) + &+& + arrange chan initPgm rate + +keyboardDetuneFMConstVolume :: + (PathClass.AbsRel ar, Check.C msg) => + Path.Dir ar -> + IO (ChannelMsg.Channel -> VoiceMsg.Program -> SampleRate Real -> + PIO.T (MIO.Events msg) (SV.Vector (Stereo.T Vector))) +keyboardDetuneFMConstVolume smpDir = do + arrange <- CausalSt.makeArranger + + tine <- Instr.tineStereoFM + ping <- Instr.pingStereoReleaseFM + filterSaw <- Instr.filterSawStereoFM + bellNoise <- Instr.bellNoiseStereoFM + + wind <- Instr.wind + windPhaser <- Instr.windPhaser + string <- Instr.softStringShapeFM + fmString <- Instr.fmStringStereoFM + helixNoise <- InstrPlug.helixNoise + arcs <- sequence $ + Instr.cosineStringStereoFM : + Instr.arcSawStringStereoFM : + Instr.arcSineStringStereoFM : + Instr.arcSquareStringStereoFM : + Instr.arcTriangleStringStereoFM : + [] + + helixSound <- Instr.helixSound + sampledSound <- Instr.sampledSound + + syllables <- + fmap concat $ + mapM (Sample.loadRanges smpDir) $ + Sample.tomatensalat : + Sample.hal : + Sample.graphentheorie : + [] + + let frequencyControlPercussive = + MCS.controllerLinear controllerDetune (0,0.005) 0.001 + &+& + MCS.bendWheelPressure 2 0.04 0.03 + + frequencyControlString = + MCS.controllerLinear controllerDetune (0,0.01) 0.005 + &+& + MCS.bendWheelPressure 2 0.04 0.03 + + let tineProc rate vel freq = + tine rate vel freq + <<< + Zip.arrowSecond + (timeControlPercussive + &+& + (((fmap stair ^<< + MCS.controllerLinear controllerTimbre0 (0.5,6.5) 2) + &+& + MCS.controllerLinear controllerTimbre1 (0,1.5) 1) + &+& + frequencyControlPercussive)) + + pingProc rate vel freq = + ping rate vel freq + <<< + Zip.arrowSecond + (timeControlPercussive + &+& + ((MCS.controllerExponential controllerTimbre0 (1/pi,10) 0.05 + &+& + controllerExponentialDim controllerTimbre1 + (DN.time 0.01, DN.time 10) (DN.time 5)) + &+& + ((MCS.controllerLinear Ctrl.soundController5 (0,10) 2 + &+& + controllerExponentialDim Ctrl.soundController7 + (DN.time 0.03, DN.time 1) (DN.time 0.5)) + &+& + frequencyControlPercussive))) + + filterSawProc rate vel freq = + filterSaw rate vel freq + <<< + Zip.arrowSecond + (timeControlPercussive + &+& + ((controllerExponentialDim controllerTimbre0 + (DN.frequency 100, DN.frequency 10000) + (DN.frequency 1000) + &+& + controllerExponentialDim controllerTimbre1 + (DN.time 0.1, DN.time 1) + (DN.time 0.6)) + &+& + frequencyControlPercussive)) + + bellNoiseProc rate vel freq = + bellNoise rate vel freq + <<< + Zip.arrowSecond + (timeControlPercussive + &+& + ((MCS.controllerLinear controllerTimbre0 (0,1) 0.3 + &+& + MCS.controllerExponential controllerTimbre1 (1,1000) 100) + &+& + frequencyControlPercussive)) + + windProc rate vel freq = + wind rate vel freq + <<< + Zip.arrowSecond + (timeControlString + &+& + (MCS.controllerExponential controllerTimbre1 (1,1000) 100 + &+& + MCS.bendWheelPressure 12 0.8 0)) + + windPhaserProc rate vel freq = + windPhaser rate vel freq + <<< + Zip.arrowSecond + (timeControlString + &+& + (MCS.controllerLinear controllerTimbre0 (0,1) 0.5 + &+& + (controllerExponentialDim controllerDetune + (DN.frequency 50, DN.frequency 5000) (DN.frequency 500) + &+& + (MCS.controllerExponential controllerTimbre1 (1,1000) 100 + &+& + MCS.bendWheelPressure 12 0.8 0)))) + + stringProc rate vel freq = + string rate vel freq + <<< + Zip.arrowSecond + (timeControlString + &+& + (MCS.controllerExponential controllerTimbre0 (1/pi,10) 0.05 + &+& + frequencyControlString)) + + fmStringProc rate vel freq = + fmString rate vel freq + <<< + Zip.arrowSecond + (timeControlString + &+& + ((MCS.controllerLinear controllerTimbre0 (0,0.5) 0.2 + &+& + MCS.controllerExponential controllerTimbre1 (1/pi,10) 0.05) + &+& + frequencyControlString)) + + helixNoiseProc rate vel freq = + helixNoise rate vel freq + <<< + Zip.arrowSecond + (timeControlString + &+& + (MCS.controllerExponential controllerTimbre0 (1,0.01) 0.1 + &+& + frequencyControlString)) + + makeArc proc rate vel freq = + proc rate vel freq + <<< + Zip.arrowSecond + (timeControlString + &+& + (MCS.controllerLinear controllerTimbre0 (0.5,9.5) 1.5 + &+& + frequencyControlString)) + + sampled smp rate vel freq = + smp rate vel freq + <<< + Zip.arrowSecond frequencyControlPercussive + + helixed smp rate vel freq = + smp rate vel freq + <<< + Zip.arrowSecond + (MCS.controllerExponential Ctrl.attackTime (0.25, 4) 1 + &+& + frequencyControlPercussive) + + bank = + Map.fromAscList $ zip [VoiceMsg.toProgram 0 ..] $ + [tineProc, pingProc, filterSawProc, bellNoiseProc, + stringProc, fmStringProc] ++ + map makeArc arcs ++ windProc : windPhaserProc : + ([helixed . helixSound, sampled . sampledSound] <*> syllables) ++ + helixNoiseProc : + [] + + return $ \chan initPgm rate -> + arrange + <<< + arr shortTime + <<< + MIO.sequenceModulatedMultiProgram chan initPgm + (\pgm -> Map.findWithDefault pingProc pgm bank rate) + <<< + id &+& MCS.fromChannel chan + + +keyboardMultiChannel :: + (PathClass.AbsRel ar, Check.C msg) => + Path.Dir ar -> + IO (SampleRate Real -> + PIO.T (MIO.Events msg) (SV.Vector (Stereo.T Real))) +keyboardMultiChannel smpDir = do + proc <- + keyboardDetuneFMCore + (Causal.map StereoInt.interleave) + smpDir + mix <- CausalRender.run Causal.mix + + return $ \ sampleRate -> + arr SigStL.unpackStereoStrict + <<< + foldl1 + (\x y -> mix <<< Zip.arrowFanout x y) + (map + (\chan -> + proc (ChannelMsg.toChannel chan) (VoiceMsg.toProgram 0) + sampleRate) + [0 .. 3]) + + + +data Phoneme = Phoneme Bool VoiceMsg.Velocity VoiceMsg.Pitch + +instance Check.C Phoneme where + note _chan (Phoneme on v p) = Just (v, p, on) + + +voderSplit :: + (Check.C msg, Construct.C msg, Arrow arrow) => + ChannelMsg.Channel -> + arrow + (MIO.Events msg) + (Zip.T + (MIO.Events Phoneme) + (MIO.Events msg)) +voderSplit chan = + arr $ + uncurry Zip.Cons . + EventListTT.unzip . + fmap + (ListHT.unzipEithers . + fmap (\ev -> + case Check.noteExplicitOff chan ev of + Nothing -> Right ev + Just (v,p,b) -> + if p >= VoiceMsg.toPitch 36 + then + let p0 = VoiceMsg.increasePitch (-36) p + in if p0 <= VoiceMsg.toPitch 29 + then Left $ Phoneme b v p0 + else Right $ Construct.note chan + (v, VoiceMsg.increasePitch (-12) p, b) + else Right ev)) + +voder :: + (PathClass.AbsRel ar, Check.C msg, Construct.C msg, POut.Default b) => + Causal.T (Stereo.T VectorValue) (POut.Element b) -> + Speech.VowelSynth -> + Path.Dir ar -> + IO (ChannelMsg.Channel -> VoiceMsg.Program -> + SampleRate Real -> PIO.T (MIO.Events msg) b) +voder emitStereo voice smpDir = do + carrier <- keyboardDetuneFMCore (arr Stereo.multiValue) smpDir + arrange <- CausalSt.makeArranger + interleave <- CausalRender.run (emitStereo <<^ Stereo.unMultiValue) + + return $ \chan initPgm sampleRate -> + interleave + <<< + arrange + <<< + arr shortTime + <<< + MIO.sequenceModulatedMultiProgramVelocityPitch + chan (VoiceMsg.toProgram 0) + (\ _pgm _vel -> voice sampleRate) + <<< + Zip.arrowSecond (carrier chan initPgm sampleRate) + <<< + voderSplit chan + +voderBand :: + (PathClass.AbsRel ar, Check.C msg, Construct.C msg, POut.Default b) => + Causal.T (Stereo.T VectorValue) (POut.Element b) -> + Path.Dir ar -> + IO (ChannelMsg.Channel -> VoiceMsg.Program -> + SampleRate Real -> PIO.T (MIO.Events msg) b) +voderBand emitStereo smpDir = do + voice <- Speech.vowelBand + voder emitStereo voice smpDir + +voderMask :: + (PathClass.AbsRel ar, Check.C msg, Construct.C msg, POut.Default b) => + Causal.T (Stereo.T VectorValue) (POut.Element b) -> + Path.Dir ar -> + IO (ChannelMsg.Channel -> VoiceMsg.Program -> + SampleRate Real -> PIO.T (MIO.Events msg) b) +voderMask emitStereo smpDir = do + voice <- + Speech.vowelMask <*> + fmap + (Map.mapMaybe (\(typ,smp) -> + toMaybe (typ==Speech.Filtered Speech.Continuous Speech.Voiced) smp)) + Speech.loadMasksKeyboard + voder emitStereo voice smpDir + + +voderEnv :: + (PathClass.AbsRel ar, Check.C msg, Construct.C msg, POut.Default b) => + Causal.T (Stereo.T VectorValue) (POut.Element b) -> + Speech.VowelSynthEnv -> + Path.Dir ar -> + IO (ChannelMsg.Channel -> VoiceMsg.Program -> + SampleRate Real -> PIO.T (MIO.Events msg) b) +voderEnv emitStereo voice smpDir = do + carrier <- keyboardDetuneFMConstVolume smpDir + arrange <- CausalSt.makeArranger + amp <- + CausalRender.run + (emitStereo <<< + Causal.envelopeStereo <<< + Causal.map Serial.upsample *** arr Stereo.unMultiValue) + + return $ \chan initPgm sampleRate -> + amp + <<< + MIO.controllerExponential chan controllerVolume (0.001, 1) (0.2::Float) + &+& + (arrange + <<< + arr shortTime + <<< + MIO.sequenceModulatedMultiProgramVelocityPitch + chan (VoiceMsg.toProgram 0) + (\ _pgm vel -> voice sampleRate (MV.velocity vel)) + <<< + Zip.arrowSecond + (Zip.arrowFanout + (timeControlString <<< MCS.fromChannel chan) + (carrier chan initPgm sampleRate)) + <<< + voderSplit chan) + +voderMaskEnv :: + (PathClass.AbsRel ar, Check.C msg, Construct.C msg, POut.Default b) => + Causal.T (Stereo.T VectorValue) (POut.Element b) -> + Path.Dir ar -> + IO (ChannelMsg.Channel -> VoiceMsg.Program -> + SampleRate Real -> PIO.T (MIO.Events msg) b) +voderMaskEnv emitStereo smpDir = do + voice <- Speech.phonemeMask <*> Speech.loadMasksKeyboard + voderEnv emitStereo voice smpDir + + +voderSeparated :: + (PathClass.AbsRel ar, Render.RunArg p, + Check.C msg, Construct.C msg, POut.Default b) => + (Render.DSLArg p -> Causal.T (Stereo.T VectorValue) (POut.Element b)) -> + Speech.VowelSynthEnv -> + Path.Dir ar -> + IO (ChannelMsg.Channel -> ChannelMsg.Channel -> VoiceMsg.Program -> + SampleRate Real -> p -> PIO.T (MIO.Events msg) b) +voderSeparated emitStereo voice smpDir = do + carrier <- keyboardDetuneFMCore (arr Stereo.multiValue) smpDir + arrange <- CausalSt.makeArranger + amp <- + CausalRender.run $ \p -> + (emitStereo p <<< + Causal.envelopeStereo <<< + Causal.map Serial.upsample *** arr Stereo.unMultiValue) + + return $ \carrierChan phonemeChan initPgm sampleRate p -> + amp p + <<< + MIO.controllerExponential phonemeChan controllerVolume (0.001, 1) (0.2::Float) + &+& + (arrange + <<< + arr shortTime + <<< + MIO.sequenceModulatedMultiProgramVelocityPitch + phonemeChan (VoiceMsg.toProgram 0) + (\ _pgm vel -> voice sampleRate (MV.velocity vel)) + <<< + Zip.arrowFanout id + (Zip.arrowFanout + (timeControlString <<< MCS.fromChannel phonemeChan) + (carrier carrierChan initPgm sampleRate))) + +voderMaskSeparated :: + (PathClass.AbsRel ar, Render.RunArg p, + Check.C msg, Construct.C msg, POut.Default b) => + (Render.DSLArg p -> Causal.T (Stereo.T VectorValue) (POut.Element b)) -> + Path.Dir ar -> + IO (ChannelMsg.Channel -> ChannelMsg.Channel -> VoiceMsg.Program -> + SampleRate Real -> p -> PIO.T (MIO.Events msg) b) +voderMaskSeparated emitStereo smpDir = do + voice <- Speech.phonemeMask <*> Speech.loadMasksGrouped + voderSeparated emitStereo voice smpDir + +voderMaskMulti :: + (PathClass.AbsRel ar, Check.C msg, Construct.C msg) => + Path.Dir ar -> + IO (SampleRate Real -> + PIO.T (MIO.Events msg) (SV.Vector (Stereo.T Real))) +voderMaskMulti smpDir = do + mix <- CausalRender.run Causal.mix + proc <- + voderMaskSeparated + (const $ Causal.map StereoInt.interleave) + smpDir + + return $ \ sampleRate -> + arr SigStL.unpackStereoStrict + <<< + foldl1 + (\x y -> mix <<< Zip.arrowFanout x y) + (map + (\chan -> + proc + (ChannelMsg.toChannel chan) + (ChannelMsg.toChannel $ succ chan) + (VoiceMsg.toProgram 4) + sampleRate ()) + [0, 2, 4, 6]) diff --git a/server/Synthesizer/LLVM/Server/Default.hs b/server/Synthesizer/LLVM/Server/Default.hs new file mode 100644 --- /dev/null +++ b/server/Synthesizer/LLVM/Server/Default.hs @@ -0,0 +1,29 @@ +module Synthesizer.LLVM.Server.Default where + +import Synthesizer.LLVM.Server.Common (SampleRate(SampleRate)) + +import qualified Sound.MIDI.Message.Channel as ChannelMsg + +import qualified System.Path as Path + + +sampleRate :: Num a => SampleRate a +sampleRate = + SampleRate + 44100 + -- 24000 + -- 48000 + + +newtype ClientName = ClientName String + deriving (Show) + +clientName :: ClientName +clientName = ClientName "Haskell-LLVM-Synthesizer" + + +channel :: ChannelMsg.Channel +channel = ChannelMsg.toChannel 0 + +sampleDirectory :: Path.AbsRelDir +sampleDirectory = Path.absRel "speech" diff --git a/server/Synthesizer/LLVM/Server/OptionCommon.hs b/server/Synthesizer/LLVM/Server/OptionCommon.hs new file mode 100644 --- /dev/null +++ b/server/Synthesizer/LLVM/Server/OptionCommon.hs @@ -0,0 +1,113 @@ +{- +Guide for common Linux/Unix command-line options: + http://www.faqs.org/docs/artu/ch10s05.html +-} +module Synthesizer.LLVM.Server.OptionCommon ( + module Synthesizer.LLVM.Server.OptionCommon, + ClientName(ClientName), + ) where + +import qualified Synthesizer.LLVM.Server.Default as Default +import Synthesizer.LLVM.Server.Default (ClientName(ClientName)) +import Synthesizer.LLVM.Server.Common (SampleRate(SampleRate)) + +import qualified Sound.MIDI.Message.Channel as ChannelMsg +import qualified Data.StorableVector.Lazy as SVL + +import qualified System.Path.PartClass as PathClass +import qualified System.Path as Path + +import qualified Shell.Utility.ParseArgument as ParseArg +import qualified Options.Applicative as OP +import Control.Applicative ((<$>), (<*>)) +import Data.Monoid ((<>)) + +import Prelude hiding (Real) + + +clientName :: String -> OP.Parser ClientName +clientName help = + OP.option (fmap ClientName OP.str) + (OP.long "clientname" <> + OP.metavar "NAME" <> + OP.help help <> + OP.value Default.clientName) + + +parseChannel :: OP.ReadM ChannelMsg.Channel +parseChannel = + OP.eitherReader $ \str -> + case reads str of + [(chan, "")] -> + if 0<=chan && chan<16 + then return $ ChannelMsg.toChannel chan + else Left "MIDI channel must a number from 0..15" + _ -> Left $ "channel must be a number, but is '" ++ str ++ "'" + +channel, extraChannel :: OP.Parser ChannelMsg.Channel +channel = + OP.option parseChannel + (OP.short 'c' <> + OP.long "channel" <> + OP.metavar "CHANNEL" <> + OP.help "Select MIDI input channel (0-based)" <> + OP.value Default.channel) + +extraChannel = + OP.option parseChannel + (OP.long "extra-channel" <> + OP.metavar "CHANNEL" <> + OP.help "Select MIDI channel with effects" <> + OP.value (ChannelMsg.toChannel 1)) + +path :: (PathClass.FileDir fd) => OP.ReadM (Path.AbsRel fd) +path = OP.eitherReader Path.parse + +sampleDirectory :: OP.Parser Path.AbsRelDir +sampleDirectory = + OP.option path + (OP.short 'I' <> + OP.long "sample-directory" <> + OP.metavar "DIR" <> + OP.help "Directory for sound samples" <> + OP.value Default.sampleDirectory) + + +maxInt :: Integer +maxInt = fromIntegral (maxBound :: Int) + +parseNumber :: + (Read a) => + String -> (a -> Bool) -> String -> OP.ReadM a +parseNumber name constraint constraintName = + OP.eitherReader $ ParseArg.parseNumber name constraint constraintName + +sampleRate :: OP.Parser (Maybe (SampleRate Int)) +sampleRate = + OP.option + (Just . SampleRate . fromInteger <$> + parseNumber "sample-rate" (\n -> 0 + OP.long "samplerate" <> + OP.metavar "RATE" <> + OP.value Nothing <> + OP.help "Sample-rate in samples per second") + +blockSize :: SVL.ChunkSize -> OP.Parser SVL.ChunkSize +blockSize deflt = + OP.option + (SVL.ChunkSize . fromInteger <$> + parseNumber "blocksize" (\n -> 0 + OP.long "blocksize" <> + OP.metavar "SIZE" <> + OP.value deflt <> + OP.help "Block size as number of sample-frames") + + +get :: OP.Parser a -> String -> IO a +get parser descr = + OP.execParser $ + OP.info + (OP.helper <*> parser) + (OP.fullDesc <> OP.progDesc descr) diff --git a/src/Synthesizer/LLVM/Causal/Controlled.hs b/src/Synthesizer/LLVM/Causal/Controlled.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Causal/Controlled.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{- | +This module provides a type class that automatically selects a filter +for a given parameter type. +We choose the dependency this way +because there may be different ways to specify the filter parameters +but there is only one implementation of the filter itself. +-} +module Synthesizer.LLVM.Causal.Controlled ( + C(..), + processCtrlRate, + ) where + +import qualified Synthesizer.LLVM.Filter.ComplexFirstOrderPacked + as ComplexFiltPack +import qualified Synthesizer.LLVM.Filter.ComplexFirstOrder as ComplexFilt +import qualified Synthesizer.LLVM.Filter.Allpass as Allpass +import qualified Synthesizer.LLVM.Filter.FirstOrder as Filt1 +import qualified Synthesizer.LLVM.Filter.SecondOrder as Filt2 +import qualified Synthesizer.LLVM.Filter.SecondOrderCascade as Cascade +import qualified Synthesizer.LLVM.Filter.SecondOrderPacked as Filt2P +import qualified Synthesizer.LLVM.Filter.Moog as Moog +import qualified Synthesizer.LLVM.Filter.Universal as UniFilter + +import qualified Synthesizer.LLVM.Causal.Private as Causal +import qualified Synthesizer.LLVM.Generator.Signal as Sig +import qualified Synthesizer.LLVM.Frame.Stereo as Stereo + +import Synthesizer.Causal.Class (($<)) + +import qualified LLVM.DSL.Expression as Expr +import LLVM.DSL.Expression (Exp) + +import qualified LLVM.Extra.Multi.Value.Marshal as Marshal +import qualified LLVM.Extra.Multi.Value as MultiValue +import qualified LLVM.Extra.Multi.Vector as MultiVector +import qualified LLVM.Extra.Memory as Memory +import qualified LLVM.Extra.Arithmetic as A + +import qualified LLVM.Core as LLVM + +import qualified Type.Data.Num.Decimal as TypeNum +import Type.Data.Num.Decimal.Number ((:*:)) + +import qualified Algebra.Module as Module + + + +processCtrlRate :: + (C parameter a b, Memory.C parameter) => + (Marshal.C r, MultiValue.IntegerConstant r, + MultiValue.Additive r, MultiValue.Comparison r) => + Exp r -> (Exp r -> Sig.T parameter) -> Causal.T a b +processCtrlRate reduct ctrlGen = + process $< Sig.interpolateConstant reduct (ctrlGen reduct) + + +{- | +A filter parameter type uniquely selects a filter function. +However it does not uniquely determine the input and output type, +since the same filter can run on mono and stereo signals. +-} +class (a ~ Input parameter b, b ~ Output parameter a) => C parameter a b where + type Input parameter b + type Output parameter a + process :: Causal.T (parameter, a) b + + +{- +Instances for the particular filters shall be defined here +in order to avoid orphan instances. +-} + +instance + (Module.C ae ve, Expr.Aggregate ae a, Expr.Aggregate ve v, + Memory.C a, Memory.C v) => + C (Filt1.Parameter a) v (Filt1.Result v) where + type Input (Filt1.Parameter a) (Filt1.Result v) = v + type Output (Filt1.Parameter a) v = Filt1.Result v + process = Filt1.causal + +instance + (a ~ A.Scalar v, A.PseudoModule v, A.RationalConstant a, + Memory.C a, Memory.C v) => + C (Filt2.Parameter a) v v where + type Input (Filt2.Parameter a) v = v + type Output (Filt2.Parameter a) v = v + process = Filt2.causal + +instance + (Marshal.C a, Marshal.Vector TypeNum.D4 a, MultiVector.PseudoRing a) => + C (Filt2P.Parameter a) (MultiValue.T a) (MultiValue.T a) where + type Input (Filt2P.Parameter a) (MultiValue.T a) = MultiValue.T a + type Output (Filt2P.Parameter a) (MultiValue.T a) = MultiValue.T a + process = Filt2P.causal + +instance + (a ~ MultiValue.Scalar v, MultiValue.PseudoModule v, + Marshal.C a, MultiValue.IntegerConstant a, Marshal.C v, + TypeNum.Natural n, TypeNum.Positive (n :*: LLVM.UnknownSize), + inp ~ MultiValue.T v, out ~ MultiValue.T v) => + C (Cascade.ParameterValue n a) inp out where + type Input (Cascade.ParameterValue n a) out = out + type Output (Cascade.ParameterValue n a) inp = inp + process = Cascade.causal + + +instance + (Module.C ae ve, Expr.Aggregate ae a, Expr.Aggregate ve v, + Memory.C a, Memory.C v) => + C (Allpass.Parameter a) v v where + type Input (Allpass.Parameter a) v = v + type Output (Allpass.Parameter a) v = v + process = Allpass.causal + +instance + (Module.C ae ve, Expr.Aggregate ae a, Expr.Aggregate ve v, + Memory.C a, Memory.C v, TypeNum.Natural n) => + C (Allpass.CascadeParameter n a) v v where + type Input (Allpass.CascadeParameter n a) v = v + type Output (Allpass.CascadeParameter n a) v = v + process = Allpass.cascade + + +instance + (Module.C ae ve, Expr.Aggregate ae a, Expr.Aggregate ve v, + Memory.C v, TypeNum.Natural n) => + C (Moog.Parameter n a) v v where + type Input (Moog.Parameter n a) v = v + type Output (Moog.Parameter n a) v = v + process = Moog.causal + + +instance + (A.PseudoModule v, A.Scalar v ~ a, A.RationalConstant a, + Memory.C a, Memory.C v) => + C (UniFilter.Parameter a) v (UniFilter.Result v) where + type Input (UniFilter.Parameter a) (UniFilter.Result v) = v + type Output (UniFilter.Parameter a) v = UniFilter.Result v + process = UniFilter.causal + +instance + (A.PseudoRing a, A.RationalConstant a, Memory.C a) => + C (ComplexFilt.Parameter a) (Stereo.T a) (Stereo.T a) where + type Input (ComplexFilt.Parameter a) (Stereo.T a) = Stereo.T a + type Output (ComplexFilt.Parameter a) (Stereo.T a) = Stereo.T a + process = ComplexFilt.causal + +instance + (Marshal.Vector n a, n ~ TypeNum.D3, MultiVector.PseudoRing a, + inp ~ MultiValue.T a, out ~ MultiValue.T a) => + C (ComplexFiltPack.ParameterMV a) (Stereo.T inp) (Stereo.T out) where + type Input (ComplexFiltPack.ParameterMV a) (Stereo.T out) = Stereo.T out + type Output (ComplexFiltPack.ParameterMV a) (Stereo.T inp) = Stereo.T inp + process = ComplexFiltPack.causal diff --git a/src/Synthesizer/LLVM/Causal/ControlledPacked.hs b/src/Synthesizer/LLVM/Causal/ControlledPacked.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Causal/ControlledPacked.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{- | +This is like "Synthesizer.LLVM.CausalExp.Controlled" +but for vectorised signals. +-} +module Synthesizer.LLVM.Causal.ControlledPacked ( + C(..), + processCtrlRate, + ) where + +import qualified Synthesizer.LLVM.Filter.SecondOrderCascade as Cascade +import qualified Synthesizer.LLVM.Filter.Allpass as Allpass +import qualified Synthesizer.LLVM.Filter.FirstOrder as Filt1 +import qualified Synthesizer.LLVM.Filter.SecondOrder as Filt2 +import qualified Synthesizer.LLVM.Filter.Moog as Moog +import qualified Synthesizer.LLVM.Filter.Universal as UniFilter + +import qualified Synthesizer.LLVM.Causal.ProcessPacked as CausalP +import qualified Synthesizer.LLVM.Causal.Process as Causal +import qualified Synthesizer.LLVM.Generator.Signal as Sig +import qualified Synthesizer.LLVM.Frame.SerialVector.Class as Serial + +import Synthesizer.Causal.Class (($<)) + +import qualified LLVM.DSL.Expression as Expr +import LLVM.DSL.Expression (Exp) + +import qualified LLVM.Extra.Multi.Value.Marshal as Marshal +import qualified LLVM.Extra.Multi.Value as MultiValue +import qualified LLVM.Extra.Memory as Memory +import qualified LLVM.Extra.Tuple as Tuple +import qualified LLVM.Extra.Arithmetic as A + +import qualified LLVM.Core as LLVM + +import qualified Type.Data.Num.Decimal as TypeNum +import Type.Data.Num.Decimal.Number ((:*:)) + +import qualified Algebra.Module as Module +import qualified NumericPrelude.Numeric as NP + +import Control.Arrow ((<<<), arr, first) + + + +processCtrlRate :: + (C parameter av bv, Memory.C parameter, + Serial.Read av, n ~ Serial.Size av, + Serial.Write bv, n ~ Serial.Size bv) => + (Marshal.C r, MultiValue.RationalConstant r, + MultiValue.Field r, MultiValue.Comparison r) => + Exp r -> (Exp r -> Sig.T parameter) -> Causal.T av bv +processCtrlRate reduct ctrlGen = Serial.withSize $ \n -> + process $< + Sig.interpolateConstant (reduct / NP.fromIntegral n) (ctrlGen reduct) + + +{- | +A filter parameter type uniquely selects a filter function. +However it does not uniquely determine the input and output type, +since the same filter can run on mono and stereo signals. +-} +class (Output parameter a ~ b, Input parameter b ~ a) => C parameter a b where + type Output parameter a + type Input parameter b + process :: Causal.T (parameter, a) b + + +{- +Instances for the particular filters shall be defined here +in order to avoid orphan instances. +-} + +instance + (Serial.Write v, Serial.Element v ~ a, + A.PseudoRing v, A.IntegerConstant v, + A.PseudoRing a, A.IntegerConstant a, Expr.Aggregate ae a, + Tuple.Phi a, Tuple.Undefined a, Memory.C a) => + C (Filt1.Parameter a) v (Filt1.Result v) where + type Input (Filt1.Parameter a) (Filt1.Result v) = v + type Output (Filt1.Parameter a) v = Filt1.Result v + process = Filt1.causalPacked + +instance + (Serial.Write v, Serial.Element v ~ a, + A.PseudoRing v, A.IntegerConstant v, + A.PseudoRing a, A.IntegerConstant a, Expr.Aggregate ae a, + Tuple.Phi a, Tuple.Undefined a, Memory.C a, Memory.C v) => + C (Filt2.Parameter a) v v where + type Input (Filt2.Parameter a) v = v + type Output (Filt2.Parameter a) v = v + process = Filt2.causalPacked + +instance + (Serial.Write v, Serial.Element v ~ MultiValue.T a, + Memory.C v, A.PseudoRing v, A.IntegerConstant v, + Marshal.C a, MultiValue.PseudoRing a, MultiValue.IntegerConstant a, + TypeNum.Positive (n :*: LLVM.UnknownSize), + TypeNum.Natural n) => + C (Cascade.ParameterValue n a) v v where + type Input (Cascade.ParameterValue n a) v = v + type Output (Cascade.ParameterValue n a) v = v + process = Cascade.causalPacked + +instance + (Serial.Write v, Serial.Element v ~ a, + A.PseudoRing a, A.IntegerConstant a, Memory.C a, + A.PseudoRing v, A.IntegerConstant v) => + C (Allpass.Parameter a) v v where + type Input (Allpass.Parameter a) v = v + type Output (Allpass.Parameter a) v = v + process = Allpass.causalPacked + +instance + (TypeNum.Natural n, + Serial.Write v, Serial.Element v ~ a, + A.PseudoRing a, A.IntegerConstant a, Memory.C a, + A.PseudoRing v, A.RationalConstant v) => + C (Allpass.CascadeParameter n a) v v where + type Input (Allpass.CascadeParameter n a) v = v + type Output (Allpass.CascadeParameter n a) v = v + process = Allpass.cascadePacked + + +instance + (TypeNum.Natural n, + Serial.Write v, Serial.Element v ~ b, Memory.C b, + Tuple.Phi a, Tuple.Undefined a, + Expr.Aggregate ae a, Expr.Aggregate be b, Module.C ae be) => + C (Moog.Parameter n a) v v where + type Input (Moog.Parameter n a) v = v + type Output (Moog.Parameter n a) v = v + process = CausalP.pack Moog.causal <<< first (arr Serial.constant) + + +instance + (Serial.Write v, Serial.Element v ~ b, Memory.C b, + Tuple.Phi a, Tuple.Undefined a, + Expr.Aggregate ae a, Expr.Aggregate be b, Module.C ae be) => + C (UniFilter.Parameter a) v (UniFilter.Result v) where + type Input (UniFilter.Parameter a) (UniFilter.Result v) = v + type Output (UniFilter.Parameter a) v = UniFilter.Result v + process = + CausalP.pack UniFilter.causalExp <<< first (arr Serial.constant) diff --git a/src/Synthesizer/LLVM/Causal/Exponential2.hs b/src/Synthesizer/LLVM/Causal/Exponential2.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Causal/Exponential2.hs @@ -0,0 +1,414 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{- | +Exponential curve with controllable delay. +-} +module Synthesizer.LLVM.Causal.Exponential2 ( + Parameter, + parameter, + parameterPlain, + multiValueParameter, + unMultiValueParameter, + causal, + + ParameterPacked, + parameterPacked, + parameterPackedExp, + parameterPackedPlain, + multiValueParameterPacked, + unMultiValueParameterPacked, + causalPacked, + ) where + +import qualified Synthesizer.LLVM.Causal.Private as CausalPriv +import qualified Synthesizer.LLVM.Causal.Process as Causal +import qualified Synthesizer.LLVM.Causal.Functional as F +import qualified Synthesizer.LLVM.Frame.SerialVector.Plain as SerialPlain +import qualified Synthesizer.LLVM.Frame.SerialVector.Code as SerialCode +import qualified Synthesizer.LLVM.Frame.SerialVector as Serial +import qualified Synthesizer.LLVM.Frame.SerialVector.Class as SerialOld +import qualified Synthesizer.LLVM.Value as Value + +import qualified LLVM.DSL.Expression as Expr +import LLVM.DSL.Expression (Exp) + +import qualified LLVM.Extra.Multi.Value.Marshal as MarshalMV +import qualified LLVM.Extra.Multi.Value as MultiValue +import qualified LLVM.Extra.Multi.Vector as MultiVector +import qualified LLVM.Extra.ScalarOrVector as SoV +import qualified LLVM.Extra.Vector as Vector +import qualified LLVM.Extra.Storable as Storable +import qualified LLVM.Extra.Marshal as Marshal +import qualified LLVM.Extra.Memory as Memory +import qualified LLVM.Extra.Tuple as Tuple +import qualified LLVM.Extra.Arithmetic as A + +import qualified LLVM.Core as LLVM +import LLVM.Core (CodeGenFunction, Value, IsFloating) + +import qualified Type.Data.Num.Decimal as TypeNum + +import qualified Foreign.Storable.Traversable as Store +import qualified Foreign.Storable +import Foreign.Storable (Storable) + +import qualified Control.Applicative as App +import Control.Applicative (liftA2, pure, (<*>)) +import Control.Arrow (arr, (&&&)) + +import qualified Data.Foldable as Fold +import qualified Data.Traversable as Trav +import Data.Traversable (traverse) + +import qualified Algebra.Transcendental as Trans + +import NumericPrelude.Numeric +import NumericPrelude.Base + + +newtype Parameter a = Parameter a + deriving (Show, Storable) + + +instance Functor Parameter where + {-# INLINE fmap #-} + fmap f (Parameter k) = Parameter (f k) + +instance App.Applicative Parameter where + {-# INLINE pure #-} + pure x = Parameter x + {-# INLINE (<*>) #-} + Parameter f <*> Parameter k = Parameter (f k) + +instance Fold.Foldable Parameter where + {-# INLINE foldMap #-} + foldMap = Trav.foldMapDefault + +instance Trav.Traversable Parameter where + {-# INLINE sequenceA #-} + sequenceA (Parameter k) = fmap Parameter k + + +instance (Tuple.Phi a) => Tuple.Phi (Parameter a) where + phi = Tuple.phiTraversable + addPhi = Tuple.addPhiFoldable + +instance Tuple.Undefined a => Tuple.Undefined (Parameter a) where + undef = Tuple.undefPointed + +instance Tuple.Zero a => Tuple.Zero (Parameter a) where + zero = Tuple.zeroPointed + +instance (Memory.C a) => Memory.C (Parameter a) where + type Struct (Parameter a) = Memory.Struct a + load = Memory.loadNewtype Parameter + store = Memory.storeNewtype (\(Parameter k) -> k) + decompose = Memory.decomposeNewtype Parameter + compose = Memory.composeNewtype (\(Parameter k) -> k) + +instance (Marshal.C a) => Marshal.C (Parameter a) where + pack (Parameter k) = Marshal.pack k + unpack = Parameter . Marshal.unpack + +instance (MarshalMV.C a) => MarshalMV.C (Parameter a) where + pack (Parameter k) = MarshalMV.pack k + unpack = Parameter . MarshalMV.unpack + +instance (Storable.C a) => Storable.C (Parameter a) where + load = Storable.loadNewtype Parameter Parameter + store = Storable.storeNewtype Parameter (\(Parameter k) -> k) + +instance (Tuple.Value a) => Tuple.Value (Parameter a) where + type ValueOf (Parameter a) = Parameter (Tuple.ValueOf a) + valueOf = Tuple.valueOfFunctor + +instance (MultiValue.C a) => MultiValue.C (Parameter a) where + type Repr (Parameter a) = Parameter (MultiValue.Repr a) + cons = multiValueParameter . fmap MultiValue.cons + undef = multiValueParameter $ pure MultiValue.undef + zero = multiValueParameter $ pure MultiValue.zero + phi bb = + fmap multiValueParameter . + traverse (MultiValue.phi bb) . unMultiValueParameter + addPhi bb a b = + Fold.sequence_ $ + liftA2 (MultiValue.addPhi bb) + (unMultiValueParameter a) (unMultiValueParameter b) + +multiValueParameter :: + Parameter (MultiValue.T a) -> MultiValue.T (Parameter a) +multiValueParameter = MultiValue.Cons . fmap (\(MultiValue.Cons a) -> a) + +unMultiValueParameter :: + MultiValue.T (Parameter a) -> Parameter (MultiValue.T a) +unMultiValueParameter (MultiValue.Cons x) = fmap MultiValue.Cons x + + +instance (Value.Flatten a) => Value.Flatten (Parameter a) where + type Registers (Parameter a) = Parameter (Value.Registers a) + flattenCode = Value.flattenCodeTraversable + unfoldCode = Value.unfoldCodeTraversable + + +instance (Vector.Simple v) => Vector.Simple (Parameter v) where + type Element (Parameter v) = Parameter (Vector.Element v) + type Size (Parameter v) = Vector.Size v + shuffleMatch = Vector.shuffleMatchTraversable + extract = Vector.extractTraversable + +instance (Vector.C v) => Vector.C (Parameter v) where + insert = Vector.insertTraversable + + +instance + (Expr.Aggregate exp mv) => + Expr.Aggregate (Parameter exp) (Parameter mv) where + type MultiValuesOf (Parameter exp) = Parameter (Expr.MultiValuesOf exp) + type ExpressionsOf (Parameter mv) = Parameter (Expr.ExpressionsOf mv) + bundle (Parameter p) = fmap Parameter $ Expr.bundle p + dissect (Parameter p) = Parameter $ Expr.dissect p + + +parameter :: + (Trans.C a, SoV.TranscendentalConstant a, IsFloating a) => + Value a -> + CodeGenFunction r (Parameter (Value a)) +parameter = Value.unlift1 parameterPlain + +parameterPlain :: + (Trans.C a) => + a -> Parameter a +parameterPlain halfLife = + Parameter $ 0.5 ^? recip halfLife + + +causal :: + (MarshalMV.C a, MultiValue.T a ~ am, MultiValue.PseudoRing a) => + Exp a -> Causal.T (Parameter am) am +causal initial = + Causal.loop initial + (arr snd &&& CausalPriv.zipWith (\(Parameter a) -> A.mul a)) + + +data ParameterPacked a = + ParameterPacked {ppFeedback, ppCurrent :: a} + + +instance Functor ParameterPacked where + {-# INLINE fmap #-} + fmap f p = ParameterPacked + (f $ ppFeedback p) (f $ ppCurrent p) + +instance App.Applicative ParameterPacked where + {-# INLINE pure #-} + pure x = ParameterPacked x x + {-# INLINE (<*>) #-} + f <*> p = ParameterPacked + (ppFeedback f $ ppFeedback p) + (ppCurrent f $ ppCurrent p) + +instance Fold.Foldable ParameterPacked where + {-# INLINE foldMap #-} + foldMap = Trav.foldMapDefault + +instance Trav.Traversable ParameterPacked where + {-# INLINE sequenceA #-} + sequenceA p = + liftA2 ParameterPacked + (ppFeedback p) (ppCurrent p) + + +instance (Tuple.Phi a) => Tuple.Phi (ParameterPacked a) where + phi = Tuple.phiTraversable + addPhi = Tuple.addPhiFoldable + +instance Tuple.Undefined a => Tuple.Undefined (ParameterPacked a) where + undef = Tuple.undefPointed + +instance Tuple.Zero a => Tuple.Zero (ParameterPacked a) where + zero = Tuple.zeroPointed + + +{- +storeParameter :: + Storable a => Store.Dictionary (ParameterPacked a) +storeParameter = + Store.run $ + liftA2 ParameterPacked + (Store.element ppFeedback) + (Store.element ppCurrent) + +instance Storable a => Storable (ParameterPacked a) where + sizeOf = Store.sizeOf storeParameter + alignment = Store.alignment storeParameter + peek = Store.peek storeParameter + poke = Store.poke storeParameter +-} + +instance Storable a => Storable (ParameterPacked a) where + sizeOf = Store.sizeOf + alignment = Store.alignment + peek = Store.peekApplicative + poke = Store.poke + + +type ParameterPackedStruct a = LLVM.Struct (a, (a, ())) + +memory :: + (Memory.C a) => + Memory.Record r (ParameterPackedStruct (Memory.Struct a)) (ParameterPacked a) +memory = + liftA2 ParameterPacked + (Memory.element ppFeedback TypeNum.d0) + (Memory.element ppCurrent TypeNum.d1) + +instance (Memory.C a) => Memory.C (ParameterPacked a) where + type Struct (ParameterPacked a) = ParameterPackedStruct (Memory.Struct a) + load = Memory.loadRecord memory + store = Memory.storeRecord memory + decompose = Memory.decomposeRecord memory + compose = Memory.composeRecord memory + +instance (Marshal.C a) => Marshal.C (ParameterPacked a) where + pack (ParameterPacked bend depth) = Marshal.pack (bend, depth) + unpack = uncurry ParameterPacked . Marshal.unpack + +instance (MarshalMV.C a) => MarshalMV.C (ParameterPacked a) where + pack (ParameterPacked bend depth) = MarshalMV.pack (bend, depth) + unpack = uncurry ParameterPacked . MarshalMV.unpack + +instance (Storable.C a) => Storable.C (ParameterPacked a) where + load = Storable.loadApplicative + store = Storable.storeFoldable + + +instance (Tuple.Value a) => Tuple.Value (ParameterPacked a) where + type ValueOf (ParameterPacked a) = ParameterPacked (Tuple.ValueOf a) + valueOf = Tuple.valueOfFunctor + +instance (MultiValue.C a) => MultiValue.C (ParameterPacked a) where + type Repr (ParameterPacked a) = ParameterPacked (MultiValue.Repr a) + cons = multiValueParameterPacked . fmap MultiValue.cons + undef = multiValueParameterPacked $ pure MultiValue.undef + zero = multiValueParameterPacked $ pure MultiValue.zero + phi bb = + fmap multiValueParameterPacked . + traverse (MultiValue.phi bb) . unMultiValueParameterPacked + addPhi bb a b = + Fold.sequence_ $ + liftA2 (MultiValue.addPhi bb) + (unMultiValueParameterPacked a) (unMultiValueParameterPacked b) + +multiValueParameterPacked :: + ParameterPacked (MultiValue.T a) -> MultiValue.T (ParameterPacked a) +multiValueParameterPacked = MultiValue.Cons . fmap (\(MultiValue.Cons a) -> a) + +unMultiValueParameterPacked :: + MultiValue.T (ParameterPacked a) -> ParameterPacked (MultiValue.T a) +unMultiValueParameterPacked (MultiValue.Cons x) = fmap MultiValue.Cons x + + +instance (Value.Flatten a) => Value.Flatten (ParameterPacked a) where + type Registers (ParameterPacked a) = ParameterPacked (Value.Registers a) + flattenCode = Value.flattenCodeTraversable + unfoldCode = Value.unfoldCodeTraversable + +instance + (Expr.Aggregate exp mv) => + Expr.Aggregate (ParameterPacked exp) (ParameterPacked mv) where + type MultiValuesOf (ParameterPacked exp) = + ParameterPacked (Expr.MultiValuesOf exp) + type ExpressionsOf (ParameterPacked mv) = + ParameterPacked (Expr.ExpressionsOf mv) + bundle p = + liftA2 ParameterPacked + (Expr.bundle $ ppFeedback p) (Expr.bundle $ ppCurrent p) + dissect p = + ParameterPacked + (Expr.dissect $ ppFeedback p) (Expr.dissect $ ppCurrent p) + + +type instance F.Arguments f (ParameterPacked a) = f (ParameterPacked a) +instance F.MakeArguments (ParameterPacked a) where + makeArgs = id + + + +withSize :: + (TypeNum.Natural n) => + (SerialOld.Write v, SerialOld.Size v ~ n, TypeNum.Positive n) => + (TypeNum.Singleton n -> m (param v)) -> + m (param v) +withSize f = f TypeNum.singleton + +parameterPacked :: + (SerialOld.Write v, SerialOld.Element v ~ a, + A.PseudoRing v, A.RationalConstant v, + A.Transcendental a, A.RationalConstant a) => + a -> CodeGenFunction r (ParameterPacked v) +parameterPacked halfLife = withSize $ \n -> do + feedback <- + SerialOld.upsample =<< + A.pow (A.fromRational' 0.5) =<< + A.fdiv (A.fromInteger' $ TypeNum.integralFromSingleton n) halfLife + k <- + A.pow (A.fromRational' 0.5) =<< + A.fdiv (A.fromInteger' 1) halfLife + current <- + SerialOld.iterate (A.mul k) (A.fromInteger' 1) + return $ ParameterPacked feedback current +{- + Value.unlift1 parameterPackedPlain +-} + +withSizePlain :: + (TypeNum.Positive n) => + (TypeNum.Singleton n -> param (Serial.T n a)) -> + param (Serial.T n a) +withSizePlain f = f TypeNum.singleton + +parameterPackedPlain :: + (TypeNum.Positive n, Trans.C a) => + a -> ParameterPacked (Serial.T n a) +parameterPackedPlain halfLife = + withSizePlain $ \n -> + ParameterPacked + (SerialPlain.replicate + (0.5 ^? (fromInteger (TypeNum.integerFromSingleton n) / halfLife))) + (SerialPlain.iterate (0.5 ^? recip halfLife *) one) + +withSizeExp :: + (TypeNum.Positive n) => + (TypeNum.Singleton n -> param (exp (Serial.T n a))) -> + param (exp (Serial.T n a)) +withSizeExp f = f TypeNum.singleton + +parameterPackedExp :: + (TypeNum.Positive n) => + (MultiValue.Transcendental a, MultiValue.RationalConstant a) => + (MultiVector.C a) => + Exp a -> ParameterPacked (Exp (Serial.T n a)) +parameterPackedExp halfLife = + withSizeExp $ \n -> + ParameterPacked + (Serial.upsample + (0.5 ^? (fromInteger (TypeNum.integerFromSingleton n) / halfLife))) + (Serial.iterate (0.5 ^? recip halfLife *) one) + + +causalPacked :: + (MultiVector.PseudoRing a, MultiValue.IntegerConstant a, + TypeNum.Positive n, MarshalMV.Vector n a, MarshalMV.C a) => + Exp a -> + Causal.T (ParameterPacked (SerialCode.Value n a)) (SerialCode.Value n a) +causalPacked initial = + Causal.loop + (Serial.upsample initial) + (CausalPriv.map $ + \(p, s0) -> liftA2 (,) + (A.mul (ppCurrent p) s0) + (A.mul (ppFeedback p) s0)) diff --git a/src/Synthesizer/LLVM/Causal/Functional.hs b/src/Synthesizer/LLVM/Causal/Functional.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Causal/Functional.hs @@ -0,0 +1,519 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE Rank2Types #-} +module Synthesizer.LLVM.Causal.Functional ( + T, + lift, fromSignal, + ($&), (&|&), + compile, + compileSignal, + withArgs, MakeArguments, Arguments, makeArgs, + AnyArg(..), + + Ground(Ground), + withGroundArgs, MakeGroundArguments, GroundArguments, + makeGroundArgs, + + Atom(..), atom, + withGuidedArgs, MakeGuidedArguments, GuidedArguments, PatternArguments, + makeGuidedArgs, + + PrepareArguments(PrepareArguments), withPreparedArgs, withPreparedArgs2, + atomArg, stereoArgs, pairArgs, tripleArgs, + ) where + +import qualified Synthesizer.LLVM.Causal.Private as CausalCore +import qualified Synthesizer.LLVM.Causal.Process as Causal +import qualified Synthesizer.LLVM.Generator.Signal as Signal +import qualified Synthesizer.LLVM.Frame.SerialVector.Class as Serial +import qualified Synthesizer.LLVM.Frame.Stereo as Stereo +import qualified Synthesizer.Causal.Class as CausalClass +import Synthesizer.LLVM.Private (getPairPtrs, noLocalPtr) + +import qualified LLVM.Extra.Multi.Value as MultiValue +import qualified LLVM.Extra.Tuple as Tuple +import qualified LLVM.Extra.MaybeContinuation as MaybeCont +import qualified LLVM.Extra.Memory as Memory +import qualified LLVM.Extra.Arithmetic as A + +import LLVM.Core (CodeGenFunction) +import qualified LLVM.Core as LLVM + +import qualified Number.Ratio as Ratio +import qualified Algebra.Transcendental as Trans +import qualified Algebra.Algebraic as Algebraic +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import qualified Control.Monad.Trans.State as State +import qualified Control.Monad.Trans.Class as MT +import Control.Monad.Trans.State (StateT) + +import qualified Data.Vault.Lazy as Vault +import Data.Vault.Lazy (Vault) +import qualified Control.Category as Cat +import Control.Arrow (Arrow, (>>^), (&&&), arr, first) +import Control.Category (Category, (.)) +import Control.Applicative (Applicative, (<*>), pure, liftA2) + +import Data.Tuple.Strict (zipPair) +import Data.Tuple.HT (fst3, snd3, thd3) + +import qualified System.Unsafe as Unsafe + +import Prelude hiding ((.)) + + +newtype T inp out = Cons (Code inp out) + + +-- | similar to @Causal.T a b@ +data Code a b = + forall global local state. + (Memory.C global, LLVM.IsSized local, Memory.C state) => + Code (forall r c. + (Tuple.Phi c) => + global -> LLVM.Value (LLVM.Ptr local) -> a -> state -> + StateT Vault (MaybeCont.T r c) (b, state)) + -- compute next value + (forall r. CodeGenFunction r (global, state)) + -- initial state + (forall r. global -> CodeGenFunction r ()) + -- cleanup + + +instance Category Code where + id = arr id + Code nextB startB stopB . Code nextA startA stopA = Code + (\(globalA, globalB) local a (sa0,sb0) -> do + (localA,localB) <- MT.lift $ getPairPtrs local + (b,sa1) <- nextA globalA localA a sa0 + (c,sb1) <- nextB globalB localB b sb0 + return (c, (sa1,sb1))) + (liftA2 zipPair startA startB) + (\(globalA, globalB) -> stopA globalA >> stopB globalB) + + +instance Arrow Code where + arr f = Code + (\() -> noLocalPtr $ \a () -> return (f a, ())) + (return ((),())) + (\() -> return ()) + first (Code next start stop) = Code (CausalCore.firstNext next) start stop + + +{- +We must not define Category and Arrow instances +because in osci***osci the result of osci would be shared, +although it depends on the particular input. + +instance Category T where + id = tagUnique Cat.id + Cons a . Cons b = tagUnique (a . b) + +instance Arrow T where + arr f = tagUnique $ arr f + first (Cons a) = tagUnique $ first a +-} + +instance Functor (T inp) where + fmap f (Cons x) = + tagUnique $ x >>^ f + +instance Applicative (T inp) where + pure a = tagUnique $ arr (const a) + f <*> x = fmap (uncurry ($)) $ f &|& x + + +lift0 :: (forall r. CodeGenFunction r out) -> T inp out +lift0 f = lift (CausalCore.map (const f)) + +lift1 :: (forall r. a -> CodeGenFunction r out) -> T inp a -> T inp out +lift1 f x = CausalCore.map f $& x + +lift2 :: + (forall r. a -> b -> CodeGenFunction r out) -> + T inp a -> T inp b -> T inp out +lift2 f x y = CausalCore.zipWith f $& x&|&y + + +instance (A.PseudoRing b, A.Real b, A.IntegerConstant b) => Num (T a b) where + fromInteger n = pure (A.fromInteger' n) + (+) = lift2 A.add + (-) = lift2 A.sub + (*) = lift2 A.mul + abs = lift1 A.abs + signum = lift1 A.signum + +instance (A.Field b, A.Real b, A.RationalConstant b) => Fractional (T a b) where + fromRational x = pure (A.fromRational' x) + (/) = lift2 A.fdiv + + +instance (A.Additive b) => Additive.C (T a b) where + zero = pure A.zero + (+) = lift2 A.add + (-) = lift2 A.sub + negate = lift1 A.neg + +instance (A.PseudoRing b, A.IntegerConstant b) => Ring.C (T a b) where + one = pure A.one + fromInteger n = pure (A.fromInteger' n) + (*) = lift2 A.mul + +instance (A.Field b, A.RationalConstant b) => Field.C (T a b) where + fromRational' x = pure (A.fromRational' $ Ratio.toRational98 x) + (/) = lift2 A.fdiv + +instance (A.Transcendental b, A.RationalConstant b) => Algebraic.C (T a b) where + sqrt = lift1 A.sqrt + root n x = lift2 A.pow x (Field.recip $ Ring.fromInteger n) + x^/r = lift2 A.pow x (Field.fromRational' r) + +instance (A.Transcendental b, A.RationalConstant b) => Trans.C (T a b) where + pi = lift0 A.pi + sin = lift1 A.sin + cos = lift1 A.cos + (**) = lift2 A.pow + exp = lift1 A.exp + log = lift1 A.log + + asin _ = error "LLVM missing intrinsic: asin" + acos _ = error "LLVM missing intrinsic: acos" + atan _ = error "LLVM missing intrinsic: atan" + + +infixr 0 $& + +($&) :: Causal.T b c -> T a b -> T a c +f $& (Cons b) = + tagUnique $ liftCode f . b + + +infixr 3 &|& + +(&|&) :: T a b -> T a c -> T a (b,c) +Cons b &|& Cons c = + tagUnique $ b &&& c + + +liftCode :: Causal.T inp out -> Code inp out +liftCode (CausalCore.Cons next start stop) = + Code + (\p l a state -> MT.lift (next p l a state)) + start stop + +lift :: Causal.T inp out -> T inp out +lift = tagUnique . liftCode + +fromSignal :: Signal.T out -> T inp out +fromSignal = lift . CausalClass.fromSignal + +tag :: Vault.Key out -> Code inp out -> T inp out +tag key (Code next start stop) = + Cons $ + Code + (\p l a s0 -> do + mb <- State.gets (Vault.lookup key) + case mb of + Just b -> return (b,s0) + Nothing -> do + bs@(b,_) <- next p l a s0 + State.modify (Vault.insert key b) + return bs) + start stop + +-- dummy for debugging +_tag :: Vault.Key out -> Code inp out -> T inp out +_tag _ = Cons + +tagUnique :: Code inp out -> T inp out +tagUnique code = + Unsafe.performIO $ + fmap (flip tag code) Vault.newKey + +initialize :: Code inp out -> Causal.T inp out +initialize (Code next start stop) = + CausalCore.Cons + (\p l a state -> State.evalStateT (next p l a state) Vault.empty) + start stop + +compile :: T inp out -> Causal.T inp out +compile (Cons code) = initialize code + +compileSignal :: T () out -> Signal.T out +compileSignal f = CausalClass.toSignal $ compile f + + +{- | +Using 'withArgs' you can simplify + +> let x = F.lift (arr fst) +> y = F.lift (arr (fst.snd)) +> z = F.lift (arr (snd.snd)) +> in F.compile (f x y z) + +to + +> withArgs $ \(x,(y,z)) -> f x y z +-} +withArgs :: + (MakeArguments inp) => + (Arguments (T inp) inp -> T inp out) -> Causal.T inp out +withArgs f = withId $ f . makeArgs + +withId :: (T inp inp -> T inp out) -> Causal.T inp out +withId f = compile $ f $ lift Cat.id + + +type family Arguments (f :: * -> *) arg + +class MakeArguments arg where + makeArgs :: Functor f => f arg -> Arguments f arg + + +{- +I have thought about an Arg type, that marks where to stop descending. +This way we can throw away all of these FlexibleContext instances +and the user can freely choose the granularity of arguments. +However this does not work so easily, +because we would need a functional depedency from, say, +@(Arg a, Arg b)@ to @(a,b)@. +This is the opposite direction to the dependency we use currently. +The 'AnyArg' type provides a solution in this spirit. +-} +type instance Arguments f (LLVM.Value a) = f (LLVM.Value a) +instance MakeArguments (LLVM.Value a) where + makeArgs = id + +type instance Arguments f (MultiValue.T a) = f (MultiValue.T a) +instance MakeArguments (MultiValue.T a) where + makeArgs = id + +{- | +Consistent with pair instance. +You may use 'AnyArg' or 'withGuidedArgs' +to stop descending into the stereo channels. +-} +type instance Arguments f (Stereo.T a) = Stereo.T (Arguments f a) +instance (MakeArguments a) => MakeArguments (Stereo.T a) where + makeArgs = fmap makeArgs . Stereo.sequence + +type instance Arguments f (Serial.Constant n a) = f (Serial.Constant n a) +instance MakeArguments (Serial.Constant n a) where + makeArgs = id + +type instance Arguments f () = f () +instance MakeArguments () where + makeArgs = id + +type instance Arguments f (a,b) = (Arguments f a, Arguments f b) +instance (MakeArguments a, MakeArguments b) => + MakeArguments (a,b) where + makeArgs f = (makeArgs $ fmap fst f, makeArgs $ fmap snd f) + +type instance Arguments f (a,b,c) = + (Arguments f a, Arguments f b, Arguments f c) +instance (MakeArguments a, MakeArguments b, MakeArguments c) => + MakeArguments (a,b,c) where + makeArgs f = + (makeArgs $ fmap fst3 f, makeArgs $ fmap snd3 f, makeArgs $ fmap thd3 f) + + +{- | +You can use this to explicitly stop breaking of composed data types. +It might be more comfortable to do this using 'withGuidedArgs'. +-} +newtype AnyArg a = AnyArg {getAnyArg :: a} + +type instance Arguments f (AnyArg a) = f a +instance MakeArguments (AnyArg a) where + makeArgs = fmap getAnyArg + + + +{- | +This is similar to 'withArgs' +but it requires to specify the decomposition depth +using constructors in the arguments. +-} +withGroundArgs :: + (MakeGroundArguments (T inp) args, + GroundArguments args ~ inp) => + (args -> T inp out) -> Causal.T inp out +withGroundArgs f = withId $ f . makeGroundArgs + + +newtype Ground f a = Ground (f a) + + +type family GroundArguments args + +class (Functor f) => MakeGroundArguments f args where + makeGroundArgs :: f (GroundArguments args) -> args + + +type instance GroundArguments (Ground f a) = a +instance (Functor f, f ~ g) => MakeGroundArguments f (Ground g a) where + makeGroundArgs = Ground + +type instance GroundArguments (Stereo.T a) = Stereo.T (GroundArguments a) +instance MakeGroundArguments f a => MakeGroundArguments f (Stereo.T a) where + makeGroundArgs f = + Stereo.cons + (makeGroundArgs $ fmap Stereo.left f) + (makeGroundArgs $ fmap Stereo.right f) + +type instance GroundArguments () = () +instance (Functor f) => MakeGroundArguments f () where + makeGroundArgs _ = () + + +type instance + GroundArguments (a,b) = + (GroundArguments a, GroundArguments b) +instance + (MakeGroundArguments f a, MakeGroundArguments f b) => + MakeGroundArguments f (a,b) where + makeGroundArgs f = + (makeGroundArgs $ fmap fst f, + makeGroundArgs $ fmap snd f) + +type instance + GroundArguments (a,b,c) = + (GroundArguments a, GroundArguments b, GroundArguments c) +instance + (MakeGroundArguments f a, MakeGroundArguments f b, + MakeGroundArguments f c) => + MakeGroundArguments f (a,b,c) where + makeGroundArgs f = + (makeGroundArgs $ fmap fst3 f, + makeGroundArgs $ fmap snd3 f, + makeGroundArgs $ fmap thd3 f) + + + +{- | +This is similar to 'withArgs' +but it allows to specify the decomposition depth using a pattern. +-} +withGuidedArgs :: + (MakeGuidedArguments pat, PatternArguments pat ~ inp) => + pat -> + (GuidedArguments (T inp) pat -> T inp out) -> Causal.T inp out +withGuidedArgs p f = withId $ f . makeGuidedArgs p + + +data Atom a = Atom + +atom :: Atom a +atom = Atom + + +type family GuidedArguments (f :: * -> *) pat +type family PatternArguments pat + +class MakeGuidedArguments pat where + makeGuidedArgs :: + Functor f => + pat -> f (PatternArguments pat) -> GuidedArguments f pat + + +type instance GuidedArguments f (Atom a) = f a +type instance PatternArguments (Atom a) = a +instance MakeGuidedArguments (Atom a) where + makeGuidedArgs Atom = id + +type instance GuidedArguments f (Stereo.T a) = Stereo.T (GuidedArguments f a) +type instance PatternArguments (Stereo.T a) = Stereo.T (PatternArguments a) +instance MakeGuidedArguments a => MakeGuidedArguments (Stereo.T a) where + makeGuidedArgs pat f = + Stereo.cons + (makeGuidedArgs (Stereo.left pat) $ fmap Stereo.left f) + (makeGuidedArgs (Stereo.right pat) $ fmap Stereo.right f) + +type instance GuidedArguments f () = f () +type instance PatternArguments () = () +instance MakeGuidedArguments () where + makeGuidedArgs () = id + +type instance + GuidedArguments f (a,b) = + (GuidedArguments f a, GuidedArguments f b) +type instance + PatternArguments (a,b) = + (PatternArguments a, PatternArguments b) +instance (MakeGuidedArguments a, MakeGuidedArguments b) => + MakeGuidedArguments (a,b) where + makeGuidedArgs (pa,pb) f = + (makeGuidedArgs pa $ fmap fst f, + makeGuidedArgs pb $ fmap snd f) + +type instance + GuidedArguments f (a,b,c) = + (GuidedArguments f a, GuidedArguments f b, GuidedArguments f c) +type instance + PatternArguments (a,b,c) = + (PatternArguments a, PatternArguments b, PatternArguments c) +instance + (MakeGuidedArguments a, MakeGuidedArguments b, MakeGuidedArguments c) => + MakeGuidedArguments (a,b,c) where + makeGuidedArgs (pa,pb,pc) f = + (makeGuidedArgs pa $ fmap fst3 f, + makeGuidedArgs pb $ fmap snd3 f, + makeGuidedArgs pc $ fmap thd3 f) + + + +{- | +Alternative to withGuidedArgs. +This way of pattern construction is even Haskell 98. +-} +withPreparedArgs :: + PrepareArguments (T inp) inp a -> + (a -> T inp out) -> Causal.T inp out +withPreparedArgs (PrepareArguments prepare) f = withId $ f . prepare + +withPreparedArgs2 :: + PrepareArguments (T (inp0, inp1)) inp0 a -> + PrepareArguments (T (inp0, inp1)) inp1 b -> + (a -> b -> T (inp0, inp1) out) -> + Causal.T (inp0, inp1) out +withPreparedArgs2 prepareA prepareB f = + withPreparedArgs (pairArgs prepareA prepareB) (uncurry f) + +newtype PrepareArguments f merged separated = + PrepareArguments (f merged -> separated) + +atomArg :: PrepareArguments f a (f a) +atomArg = PrepareArguments id + +stereoArgs :: + (Functor f) => + PrepareArguments f a b -> + PrepareArguments f (Stereo.T a) (Stereo.T b) +stereoArgs (PrepareArguments p) = + PrepareArguments $ fmap p . Stereo.sequence + +pairArgs :: + (Functor f) => + PrepareArguments f a0 b0 -> + PrepareArguments f a1 b1 -> + PrepareArguments f (a0,a1) (b0,b1) +pairArgs (PrepareArguments p0) (PrepareArguments p1) = + PrepareArguments $ \f -> (p0 $ fmap fst f, p1 $ fmap snd f) + +tripleArgs :: + (Functor f) => + PrepareArguments f a0 b0 -> + PrepareArguments f a1 b1 -> + PrepareArguments f a2 b2 -> + PrepareArguments f (a0,a1,a2) (b0,b1,b2) +tripleArgs (PrepareArguments p0) (PrepareArguments p1) (PrepareArguments p2) = + PrepareArguments $ \f -> + (p0 $ fmap fst3 f, p1 $ fmap snd3 f, p2 $ fmap thd3 f) diff --git a/src/Synthesizer/LLVM/Causal/FunctionalPlug.hs b/src/Synthesizer/LLVM/Causal/FunctionalPlug.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Causal/FunctionalPlug.hs @@ -0,0 +1,376 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE FlexibleContexts #-} +module Synthesizer.LLVM.Causal.FunctionalPlug ( + T, + ($&), (&|&), + run, runPlugOut, + fromSignal, plug, askParameter, Input, + withArgs, withArgsPlugOut, + MakeArguments, Arguments, makeArgs, + ) where + +import qualified Synthesizer.LLVM.Plug.Input as PIn +import qualified Synthesizer.LLVM.Plug.Output as POut + +import qualified Synthesizer.LLVM.Causal.Parametric as Parametric +import qualified Synthesizer.LLVM.Causal.Render as CausalRender +import qualified Synthesizer.LLVM.Causal.Private as CausalPriv +import qualified Synthesizer.LLVM.Causal.Process as Causal +import qualified Synthesizer.LLVM.Generator.Signal as Sig + +import qualified Synthesizer.Causal.Class as CausalClass +import qualified Synthesizer.CausalIO.Process as PIO +import qualified Synthesizer.Generic.Cut as CutG +import qualified Synthesizer.Zip as Zip + +import qualified Data.EventList.Relative.BodyTime as EventListBT +import qualified Data.StorableVector as SV + +import LLVM.DSL.Expression (Exp(Exp)) + +import qualified LLVM.Extra.Multi.Value.Marshal as Marshal +import qualified LLVM.Extra.MaybeContinuation as MaybeCont +import qualified LLVM.Extra.Arithmetic as A +import LLVM.Core (CodeGenFunction) + +import Data.IORef (newIORef, readIORef) + +import qualified Number.Ratio as Ratio +import qualified Algebra.Transcendental as Trans +import qualified Algebra.Algebraic as Algebraic +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import qualified Control.Monad.Trans.Reader as MR +import qualified Control.Monad.Trans.State as MS +import Control.Monad.IO.Class (liftIO) + +import qualified Data.Set as Set +import qualified Data.Vault.Lazy as Vault +import Data.Vault.Lazy (Vault) +import Data.Unique (Unique, newUnique) +import Data.Maybe (fromMaybe) + +import Control.Arrow ((^<<), (<<^), arr, first, second) +import Control.Category (id, (.)) +import Control.Applicative (Applicative, (<*>), pure, liftA2, liftA3) + +import qualified System.Unsafe as Unsafe + +import Prelude hiding (id, (.)) + + +{- | +This data type detects sharing. +-} +{- +There are two levels of the use of keys. +At the top level, in T's State monad, +we store an object id in order to check, +whether we have already seen a certain object. +If we encounter a known object +then we use the Simple constructor +and fetch the stored CausalP output +within the causal process enclosed in Simple. +This and the causal process in the Plugged constructor +are the second level. +These arrows handle a Vault like a state monad +and insert all values they produce into the Vault. +-} +newtype T pp inp out = + Cons (MS.State (Set.Set Unique) (Core pp inp out)) + +{- +We need to hide the x and y types +since these types grow when combining Cores, +and then we could not define numeric instances. +-} +data Core pp inp out = + forall x y. CutG.Read x => + Plugged + (pp -> inp -> x) + (PIn.T x y) + (Causal.T (y, Vault) (out, Vault)) + | + {- + The Simple constructor is needed for reusing shared CausalP processes + and for input without external representation. (a Plug.Input) + -} + Simple (Causal.T Vault (out, Vault)) + + +applyCore :: + Causal.T (a, Vault) (b, Vault) -> + Core pp inp a -> + Core pp inp b +applyCore f core = + case core of + Plugged prep plg process -> Plugged prep plg (f . process) + Simple process -> Simple (f . process) + +combineCore :: + Core pp inp a -> + Core pp inp b -> + Core pp inp (a,b) +combineCore (Plugged prepA plugA processA) (Plugged prepB plugB processB) = + Plugged + (\p -> Zip.arrowFanout (prepA p) (prepB p)) + (PIn.split plugA plugB) + ((\(a,(b,v)) -> ((a,b), v)) ^<< second processB + . arr (\((a,v),b) -> (a,(b,v))) . + first processA <<^ (\((a,b),v) -> ((a,v),b))) +combineCore (Simple processA) (Plugged prepB plugB processB) = + Plugged prepB plugB + ((\(b,(a,v)) -> ((a,b), v)) ^<< second processA . processB) +combineCore (Plugged prepA plugA processA) (Simple processB) = + Plugged prepA plugA + ((\(a,(b,v)) -> ((a,b), v)) ^<< second processB . processA) +combineCore (Simple processA) (Simple processB) = + Simple ((\(a,(b,v)) -> ((a,b), v)) ^<< second processB . processA) + + +reuseCore :: Vault.Key out -> Core pp inp out +reuseCore key = + Simple $ arr $ \vault -> + (fromMaybe (error "key must have been lost") $ Vault.lookup key vault, + vault) + + +tag :: + Unique -> Vault.Key out -> + MS.State (Set.Set Unique) (Core pp inp out) -> + T pp inp out +tag unique key stateCore = Cons $ do + alreadySeen <- MS.gets (Set.member unique) + if alreadySeen + then return $ reuseCore key + else do + MS.modify (Set.insert unique) + fmap (applyCore (arr $ \(a,v) -> (a, Vault.insert key a v))) stateCore + +tagUnique :: + MS.State (Set.Set Unique) (Core pp inp out) -> + T pp inp out +tagUnique core = + Unsafe.performIO $ + liftA3 tag newUnique Vault.newKey (pure core) + + +infixr 0 $& + +($&) :: + Causal.T a b -> + T pp inp a -> + T pp inp b +f $& Cons core = + tagUnique $ fmap (applyCore $ first f) core + + +infixr 3 &|& + +(&|&) :: + T pp inp a -> + T pp inp b -> + T pp inp (a,b) +Cons coreA &|& Cons coreB = + tagUnique $ liftA2 combineCore coreA coreB + + +instance Functor (Core pp inp) where + fmap f (Simple process) = Simple (fmap (first f) process) + fmap f (Plugged prep plg process) = Plugged prep plg (fmap (first f) process) + +instance Applicative (Core pp inp) where + pure a = lift0Core $ pure a + f <*> x = fmap (uncurry ($)) $ combineCore f x + +lift0Core :: (forall r. CodeGenFunction r out) -> Core pp inp out +lift0Core f = Simple (CausalPriv.map (\v -> fmap (flip (,) v) f)) + + +instance Functor (T pp inp) where + fmap f (Cons x) = tagUnique $ fmap (fmap f) x + +instance Applicative (T pp inp) where + pure a = tagUnique $ pure $ pure a + f <*> x = fmap (uncurry ($)) $ f &|& x + + +lift0 :: (forall r. CodeGenFunction r out) -> T pp inp out +lift0 f = tagUnique $ pure $ lift0Core f + +lift1 :: + (forall r. a -> CodeGenFunction r out) -> + T pp inp a -> T pp inp out +lift1 f x = CausalPriv.map f $& x + +lift2 :: + (forall r. a -> b -> CodeGenFunction r out) -> + T pp inp a -> T pp inp b -> T pp inp out +lift2 f x y = CausalPriv.zipWith f $& x&|&y + + +instance + (A.PseudoRing b, A.Real b, A.IntegerConstant b) => + Num (T pp a b) where + fromInteger n = pure (A.fromInteger' n) + (+) = lift2 A.add + (-) = lift2 A.sub + (*) = lift2 A.mul + abs = lift1 A.abs + signum = lift1 A.signum + +instance + (A.Field b, A.Real b, A.RationalConstant b) => + Fractional (T pp a b) where + fromRational x = pure (A.fromRational' x) + (/) = lift2 A.fdiv + + +instance (A.Additive b) => Additive.C (T pp a b) where + zero = pure A.zero + (+) = lift2 A.add + (-) = lift2 A.sub + negate = lift1 A.neg + +instance (A.PseudoRing b, A.IntegerConstant b) => Ring.C (T pp a b) where + one = pure A.one + fromInteger n = pure (A.fromInteger' n) + (*) = lift2 A.mul + +instance (A.Field b, A.RationalConstant b) => Field.C (T pp a b) where + fromRational' x = pure (A.fromRational' $ Ratio.toRational98 x) + (/) = lift2 A.fdiv + +instance + (A.Transcendental b, A.RationalConstant b) => + Algebraic.C (T pp a b) where + sqrt = lift1 A.sqrt + root n x = lift2 A.pow x (Field.recip $ Ring.fromInteger n) + x^/r = lift2 A.pow x (Field.fromRational' r) + +instance + (A.Transcendental b, A.RationalConstant b) => + Trans.C (T pp a b) where + pi = lift0 A.pi + sin = lift1 A.sin + cos = lift1 A.cos + (**) = lift2 A.pow + exp = lift1 A.exp + log = lift1 A.log + + asin _ = error "LLVM missing intrinsic: asin" + acos _ = error "LLVM missing intrinsic: acos" + atan _ = error "LLVM missing intrinsic: atan" + + + +fromSignal :: Sig.T a -> T pp inp a +fromSignal sig = + tagUnique $ pure $ Simple (CausalClass.feedFst sig) + + + +type Input pp a = MR.Reader (pp, a) + +plug :: + (CutG.Read b, PIn.Default b) => + Input pp a b -> + T pp a (PIn.Element b) +plug accessor = + tagUnique $ pure $ + Plugged + (curry $ MR.runReader accessor) + PIn.deflt + id + +askParameter :: Input pp a pp +askParameter = MR.asks fst + + +runPlugOut :: + (Marshal.C pl) => + (Exp pl -> T pp a x) -> POut.T x b -> + IO (pp -> pl -> PIO.T a b) +runPlugOut func pout = do + let name = "FunctionalPlug.runPlugOut" + ref <- newIORef $ error $ name ++ ": uninitialized parameter reference" + case func (Exp (liftIO (readIORef ref))) of + Cons core -> + case MS.evalState core Set.empty of + Simple _ -> error $ name ++ ": no substantial input available" + -- Simple process -> + -- CausalRender.processIOCore pin process pout + Plugged prep pin process -> + fmap (\f pp pl -> f (return (pl, return ())) <<^ prep pp) $ + case fst ^<< process <<^ flip (,) Vault.empty of + CausalPriv.Cons next start stop -> + (\paramd -> + CausalRender.processIOParametric pin paramd pout) $ + Parametric.Cons + (\p global local a state -> + MaybeCont.lift (Parametric.loadParam ref p) >> + next global local a state) + (\p -> + Parametric.loadParam ref p >> start) + (\p global -> + Parametric.loadParam ref p >> stop global) + +run :: + (Marshal.C pl) => + (POut.Default b) => + (Exp pl -> T pp a (POut.Element b)) -> + IO (pp -> pl -> PIO.T a b) +run f = runPlugOut f POut.deflt + + +{- | +Cf. 'F.withArgs'. +-} +withArgs :: + (Marshal.C pl) => + (MakeArguments a, POut.Default b) => + (Arguments (Input pp a) a -> Exp pl -> T pp a (POut.Element b)) -> + IO (pp -> pl -> PIO.T a b) +withArgs f = withArgsPlugOut f POut.deflt + +withArgsPlugOut :: + (Marshal.C pl) => + (MakeArguments a) => + (Arguments (Input pp a) a -> Exp pl -> T pp a x) -> + POut.T x b -> + IO (pp -> pl -> PIO.T a b) +withArgsPlugOut = withArgsPlugOutStart (MR.asks snd) + +withArgsPlugOutStart :: + (Marshal.C pl) => + (MakeArguments a) => + Input pp a a -> + (Arguments (Input pp a) a -> Exp pl -> T pp a x) -> + POut.T x b -> + IO (pp -> pl -> PIO.T a b) +withArgsPlugOutStart fid f = runPlugOut (f (makeArgs fid)) + + + +type family Arguments (f :: * -> *) arg + +class MakeArguments arg where + makeArgs :: Functor f => f arg -> Arguments f arg + + +type instance Arguments f (EventListBT.T i a) = f (EventListBT.T i a) +instance MakeArguments (EventListBT.T i a) where + makeArgs = id + +type instance Arguments f (SV.Vector a) = f (SV.Vector a) +instance MakeArguments (SV.Vector a) where + makeArgs = id + +type instance Arguments f (Zip.T a b) = (Arguments f a, Arguments f b) +instance (MakeArguments a, MakeArguments b) => + MakeArguments (Zip.T a b) where + makeArgs f = (makeArgs $ fmap Zip.first f, makeArgs $ fmap Zip.second f) diff --git a/src/Synthesizer/LLVM/Causal/Helix.hs b/src/Synthesizer/LLVM/Causal/Helix.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Causal/Helix.hs @@ -0,0 +1,622 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE RebindableSyntax #-} +{- | + +-} +module Synthesizer.LLVM.Causal.Helix ( + -- * time and phase control based on the helix model + static, + staticPacked, + dynamic, + dynamicLimited, + + -- * useful control curves + zigZag, + zigZagPacked, + zigZagLong, + zigZagLongPacked, + ) where + +import qualified Synthesizer.LLVM.Causal.ProcessPacked as CausalPS +import qualified Synthesizer.LLVM.Causal.Private as CausalPriv +import qualified Synthesizer.LLVM.Causal.Process as Causal +import qualified Synthesizer.LLVM.Causal.Functional as Func +import qualified Synthesizer.LLVM.Generator.Source as Source +import qualified Synthesizer.LLVM.Generator.SignalPacked as SigPS +import qualified Synthesizer.LLVM.Generator.Private as SigPriv +import qualified Synthesizer.LLVM.Generator.Signal as Sig +import qualified Synthesizer.LLVM.Causal.RingBufferForward as RingBuffer +import qualified Synthesizer.LLVM.Frame.SerialVector as SerialExp +import qualified Synthesizer.LLVM.Frame.SerialVector.Code as Serial +import qualified Synthesizer.LLVM.Frame.SerialVector.Class as SerialClass +import qualified Synthesizer.LLVM.Interpolation as Ip +import Synthesizer.LLVM.Causal.Functional (($&), (&|&)) +import Synthesizer.LLVM.Private (noLocalPtr) + +import Synthesizer.Causal.Class (($*), ($<)) + +import qualified LLVM.DSL.Expression.Vector as ExprVec +import qualified LLVM.DSL.Expression as Expr +import LLVM.DSL.Expression (Exp, (<*), (>=*)) + +import qualified LLVM.Extra.Multi.Value.Storable as Storable +import qualified LLVM.Extra.Multi.Value.Marshal as Marshal +import qualified LLVM.Extra.Multi.Value.Vector as MultiValueVec +import qualified LLVM.Extra.Multi.Value as MultiValue +import qualified LLVM.Extra.Multi.Vector as MultiVector +import qualified LLVM.Extra.Arithmetic as A +import qualified LLVM.Extra.Memory as Memory + +import qualified LLVM.Core as LLVM + +import qualified Type.Data.Num.Decimal as TypeNum + +import Data.Word (Word) + +import Control.Arrow (first, (<<<)) +import Control.Category (id) +import Control.Functor.HT (unzip) +import Data.Traversable (mapM) +import Data.Tuple.HT (mapPair, mapFst) + +import qualified Algebra.Ring as Ring + +import NumericPrelude.Numeric hiding (splitFraction) +import NumericPrelude.Base hiding (unzip, zip, mapM, id) + +import Prelude () + + +{- | +Inputs are @(shape, phase)@. + +The shape parameter is limited at the beginning and at the end +such that only available data is used for interpolation. +Actually, we allow almost one step less than possible, +since the right boundary of the interval of admissible @shape@ values is open. +-} +static :: + (Ip.C nodesStep, Ip.C nodesLeap) => + (Storable.C vh, MultiValue.T vh ~ v) => + (Marshal.C a, MultiValue.Field a, MultiValue.RationalConstant a) => + (MultiValue.Fraction a, MultiValue.NativeFloating a ar) => + (MultiValueVec.NativeFloating a ar, MultiValue.T a ~ am) => + (forall r. Ip.T r nodesLeap am v) -> + (forall r. Ip.T r nodesStep am v) -> + Exp Int -> + Exp a -> + Exp (Source.StorableVector vh) -> + Causal.T (am, am) v +static ipLeap ipStep periodInt period vec = + let periodWord = wordFromInt periodInt + cellMargin = combineMarginParams ipLeap ipStep periodInt + in interpolateCell ipLeap ipStep + <<< + first (peekCell cellMargin periodWord vec) + <<< + flattenShapePhaseProc periodWord period + <<< + first + (limitShape cellMargin periodInt + (intFromWord $ Source.storableVectorLength vec)) + +intFromWord :: Exp Word -> Exp Int +intFromWord = Expr.liftReprM LLVM.bitcast + +wordFromInt :: Exp Int -> Exp Word +wordFromInt = Expr.liftReprM LLVM.bitcast + +staticPacked :: + (Ip.C nodesStep, Ip.C nodesLeap) => + (Storable.C vh, MultiValue.T vh ~ ve, SerialClass.Element v ~ ve) => + (SerialClass.Size (nodesLeap (nodesStep v)) ~ n, + SerialClass.Write (nodesLeap (nodesStep v)), + SerialClass.Element (nodesLeap (nodesStep v)) ~ + nodesLeap (nodesStep (SerialClass.Element v))) => + (TypeNum.Positive n) => + (Marshal.C a, MultiVector.Field a, MultiVector.Real a, + MultiVector.Fraction a, MultiVector.RationalConstant a, + MultiVector.NativeFloating n a ar) => + (forall r. Ip.T r nodesLeap (Serial.Value n a) v) -> + (forall r. Ip.T r nodesStep (Serial.Value n a) v) -> + Exp Int -> + Exp a -> + Exp (Source.StorableVector vh) -> + Causal.T (Serial.Value n a, Serial.Value n a) v +staticPacked ipLeap ipStep periodInt period vec = + let periodWord = wordFromInt periodInt + cellMargin = combineMarginParams ipLeap ipStep periodInt + in interpolateCell ipLeap ipStep + <<< + first (CausalPS.pack + (peekCell (elementMargin cellMargin) periodWord vec)) + <<< + flattenShapePhaseProcPacked periodWord period + <<< + first + (limitShapePacked cellMargin periodInt + (intFromWord $ Source.storableVectorLength vec)) + + +{- | +In contrast to 'dynamic' this one ends +when the end of the manipulated signal is reached. +-} +dynamicLimited :: + (Ip.C nodesStep, Ip.C nodesLeap) => + (Marshal.C a, MultiValue.Field a, MultiValue.Fraction a, + MultiValue.Select a, MultiValue.Comparison a, + MultiValue.NativeFloating a ar, + MultiValue.RationalConstant a, + MultiValueVec.NativeFloating a ar) => + (MultiValue.T a ~ am) => + (Memory.C v) => + (forall r. Ip.T r nodesLeap am v) -> + (forall r. Ip.T r nodesStep am v) -> + Exp Int -> + Exp a -> + Sig.T v -> + Causal.T (am, am) v +dynamicLimited ipLeap ipStep periodInt period sig = + dynamicGen + (\cellMargin (skips, fracs) -> + let windows = + (RingBuffer.trackSkip + (wordFromInt $ Ip.marginNumberExp cellMargin) sig) + $& skips + in (windows, + Causal.delay1 zero $& skips, + Causal.delay1 zero $& fracs)) + ipLeap ipStep periodInt period + +{- | +If the time control exceeds the end of the input signal, +then the last waveform is locked. +This is analogous to 'static'. +-} +dynamic :: + (Ip.C nodesStep, Ip.C nodesLeap) => + (Marshal.C a, MultiValue.Field a, MultiValue.Fraction a, + MultiValue.Select a, MultiValue.Comparison a, + MultiValue.NativeFloating a ar, + MultiValue.RationalConstant a, + MultiValueVec.NativeFloating a ar) => + (MultiValue.T a ~ am) => + (Memory.C v) => + (forall r. Ip.T r nodesLeap am v) -> + (forall r. Ip.T r nodesStep am v) -> + Exp Int -> + Exp a -> + Sig.T v -> + Causal.T (am, am) v +dynamic ipLeap ipStep periodInt period sig = + dynamicGen + (\cellMargin (skips, fracs) -> + let {- + For conformance with 'static' + we stop one step before the definite end. + We achieve this by using a buffer + that is one step longer than necessary. + -} + ((running, actualSkips), windows) = + mapFst unzip $ unzip $ + (RingBuffer.trackSkipHold + (wordFromInt (Ip.marginNumberExp cellMargin) + 1) sig) + $& skips + holdFracs = + Causal.zipWith (\r fr -> Expr.select r fr 1) + $& + running &|& (Causal.delay1 zero $& fracs) + in (windows, actualSkips, holdFracs)) + ipLeap ipStep periodInt period + +dynamicGen :: + (Ip.C nodesStep, Ip.C nodesLeap) => + (Marshal.C a, MultiValue.Field a, MultiValue.Fraction a, + MultiValue.Select a, MultiValue.Comparison a, + MultiValue.NativeFloating a ar, + MultiValue.RationalConstant a, + MultiValueVec.NativeFloating a ar) => + (MultiValue.T a ~ am) => + (Memory.C v) => + (Exp (Ip.Margin (nodesLeap (nodesStep v))) -> + (Func.T (am, am) (MultiValue.T Word), + Func.T (am, am) am) -> + (Func.T (am, am) (RingBuffer.T v), + Func.T (am, am) (MultiValue.T Word), + Func.T (am, am) am)) -> + (forall r. Ip.T r nodesLeap am v) -> + (forall r. Ip.T r nodesStep am v) -> + Exp Int -> + Exp a -> + Causal.T (am, am) v +dynamicGen limitMaxShape ipLeap ipStep periodInt period = + let periodWord = wordFromInt periodInt + cellMargin = combineMarginParams ipLeap ipStep periodInt + minShape = wordFromInt $ fst $ shapeMargin cellMargin periodInt + + in Func.withArgs $ \(shape, phase) -> + let (windows, skips, fracs) = + limitMaxShape cellMargin $ + unzip (integrateFrac $& (limitMinShape minShape $& shape)) + (offsets, shapePhases) = + unzip + (flattenShapePhaseProc periodWord period $& + (constantFromWord minShape + fracs) + &|& + (Causal.osciCoreSync $& + phase + &|& + negate + (Causal.map ((/period)) $& + (Causal.map Expr.fromIntegral $& skips)))) + in interpolateCell ipLeap ipStep $& + (CausalPriv.map + (\(buffer, offset) -> do + p <- Expr.unExp periodWord + cellFromBuffer p buffer offset) + $& + windows + &|& + offsets) + &|& + shapePhases + +constantFromWord :: + (MultiValue.NativeFloating a ar) => + Exp Word -> Func.T inp (MultiValue.T a) +constantFromWord x = + Func.fromSignal (Causal.map Expr.fromIntegral $* Sig.constant x) + +limitMinShape :: + (Marshal.C a, MultiValue.Select a, MultiValue.Comparison a, + MultiValue.NativeFloating a ar) => + Exp Word -> + Causal.T (MultiValue.T a) (MultiValue.T a) +limitMinShape xLim = + Causal.mapAccum + (\x lim -> + Expr.unzip $ + Expr.select (x>=*lim) (Expr.zip (x-lim) zero) (Expr.zip zero (lim-x))) + (Expr.fromIntegral xLim) + +integrateFrac :: + (Marshal.C a, MultiValue.Additive a, + MultiValueVec.NativeFloating a ar, LLVM.IsPrimitive ar) => + Causal.T (MultiValue.T a) (MultiValue.T Word, MultiValue.T a) +integrateFrac = + Causal.mapAccum + (\a frac -> + let s = ExprVec.splitFractionToInt (a+frac) + in (s, snd s)) + zero + + +interpolateCell :: + (Ip.C nodesStep, Ip.C nodesLeap) => + (forall r. Ip.T r nodesLeap a v) -> + (forall r. Ip.T r nodesStep a v) -> + Causal.T (nodesLeap (nodesStep v), (a, a)) v +interpolateCell ipLeap ipStep = + CausalPriv.map + (\(nodes, (leap,step)) -> + ipLeap leap =<< mapM (ipStep step) nodes) + +cellFromBuffer :: + (Memory.C a, Ip.C nodesLeap, Ip.C nodesStep) => + MultiValue.T Word -> + RingBuffer.T a -> + MultiValue.T Word -> + LLVM.CodeGenFunction r (nodesLeap (nodesStep a)) +cellFromBuffer periodInt buffer offset = + Ip.indexNodesExp + (Ip.indexNodesExp (flip RingBuffer.index buffer) A.one) + periodInt offset + +elementMargin :: + Exp (Ip.Margin (nodesLeap (nodesStep v))) -> + Exp (Ip.Margin (nodesLeap (nodesStep (SerialClass.Element v)))) +elementMargin = Expr.liftReprM return + +peekCell :: + (Storable.C a, MultiValue.T a ~ value, Ip.C nodesLeap, Ip.C nodesStep) => + Exp (Ip.Margin (nodesLeap (nodesStep value))) -> + Exp Word -> + Exp (Source.StorableVector a) -> + Causal.T (MultiValue.T Word) (nodesLeap (nodesStep value)) +peekCell margin periodWord vec = + CausalPriv.map + (\n -> do + ~(MultiValue.Cons (ptr,_l)) <- Expr.unExp vec + ~(MultiValue.Cons offset) <- + Expr.unExp $ intFromWord (Expr.lift0 n) - Ip.marginOffsetExp margin + perInt <- Expr.unExp $ intFromWord periodWord + Ip.loadNodesExp (Ip.loadNodesExp Storable.load A.one) perInt + =<< Storable.advancePtr offset ptr) + + +flattenShapePhaseProc :: + (MultiValue.Field a, MultiValue.RationalConstant a, MultiValue.Fraction a) => + (MultiValue.NativeFloating a ar, MultiValueVec.NativeFloating a ar) => + Exp Word -> + Exp a -> + Causal.T + (MultiValue.T a, MultiValue.T a) + (MultiValue.T Word, (MultiValue.T a, MultiValue.T a)) +flattenShapePhaseProc periodInt period = + Causal.map + (\(shape, phase) -> flattenShapePhase periodInt period shape phase) + +_flattenShapePhaseProc :: + (MultiValue.Field a, MultiValue.RationalConstant a, MultiValue.Fraction a) => + (MultiValue.NativeFloating a ar) => + Exp Word -> + Exp a -> + Causal.T + (MultiValue.T a, MultiValue.T a) + (MultiValue.T Word, (MultiValue.T a, MultiValue.T a)) +_flattenShapePhaseProc period32 period = + CausalPriv.map + (\(shape, phase) -> do + perInt <- Expr.unExp period32 + per <- Expr.unExp period + _flattenShapePhase perInt per shape phase) + +flattenShapePhaseProcPacked :: + (TypeNum.Positive n, MultiVector.Field a, MultiVector.RationalConstant a) => + (MultiVector.Fraction a, MultiVector.NativeFloating n a ar) => + Exp Word -> + Exp a -> + Causal.T + (Serial.Value n a, Serial.Value n a) + (Serial.Value n Word, (Serial.Value n a, Serial.Value n a)) +flattenShapePhaseProcPacked periodInt period = + Causal.zipWith + (flattenShapePhase + (SerialExp.upsample periodInt) (SerialExp.upsample period)) + +flattenShapePhase :: + (MultiValue.Field a, MultiValue.RationalConstant a, MultiValue.Fraction a) => + (MultiValueVec.NativeFloating a ar, MultiValueVec.NativeInteger i ir) => + (LLVM.ShapeOf ir ~ LLVM.ShapeOf ar) => + Exp i -> Exp a -> + Exp a -> Exp a -> + (Exp i, (Exp a, Exp a)) +flattenShapePhase periodInt period shape phase = + let qLeap = Expr.fraction $ shape/period - phase + (n,qStep) = + ExprVec.splitFractionToInt $ + {- + If 'shape' is correctly limited, + the value is always non-negative algebraically, + but maybe not numerically. + -} + Expr.max zero $ + shape - qLeap * ExprVec.fromIntegral periodInt + in (n,(qLeap,qStep)) + +_flattenShapePhase :: + (MultiValue.Field a, MultiValue.RationalConstant a, MultiValue.Fraction a) => + (MultiValue.NativeFloating a ar, MultiValue.NativeInteger i ir) => + MultiValue.T i -> + MultiValue.T a -> + MultiValue.T a -> MultiValue.T a -> + LLVM.CodeGenFunction r (MultiValue.T i, (MultiValue.T a, MultiValue.T a)) +_flattenShapePhase = Expr.unliftM4 $ \periodInt period shape phase -> + let qLeap = Expr.fraction $ shape/period - phase + (n,qStep) = + Expr.splitFractionToInt $ + {- + If 'shape' is correctly limited, + the value is always non-negative algebraically, + but maybe not numerically. + -} + Expr.max zero $ + shape - qLeap * Expr.fromIntegral periodInt + in (n,(qLeap,qStep)) + + +limitShape :: + (Ip.C nodesStep, Ip.C nodesLeap) => + (Marshal.C t, MultiValue.Real t, MultiValue.NativeFloating t tr) => + (i ~ Int) => + Exp (Ip.Margin (nodesLeap (nodesStep value))) -> + Exp i -> Exp i -> Causal.MV t t +limitShape margin periodInt len = + Causal.zipWith Expr.limit + $< + limitShapeSignal margin periodInt len + +limitShapePacked :: + (Ip.C nodesStep, Ip.C nodesLeap) => + (Marshal.C t, MultiValue.NativeFloating t tr) => + (TypeNum.Positive n, MultiVector.Real t) => + (i ~ Int) => + Exp (Ip.Margin (nodesLeap (nodesStep value))) -> + Exp i -> + Exp i -> + Causal.T (Serial.Value n t) (Serial.Value n t) +limitShapePacked margin periodInt len = + Causal.zipWith + (\(minShape,maxShape) shape -> + SerialExp.limit + (SerialExp.upsample minShape, + SerialExp.upsample maxShape) + shape) + $< + limitShapeSignal margin periodInt len + +limitShapeSignal :: + (Ip.C nodesStep, Ip.C nodesLeap) => + (Marshal.C t, MultiValue.NativeFloating t tr) => + (i ~ Int) => + Exp (Ip.Margin (nodesLeap (nodesStep value))) -> + Exp i -> + Exp i -> + Sig.T (MultiValue.T t, MultiValue.T t) +limitShapeSignal margin periodInt len = + SigPriv.Cons + (\minMax -> noLocalPtr $ \() -> return (minMax, ())) + (do + limits <- + Expr.bundle + (mapPair (Expr.fromIntegral, Expr.fromIntegral) $ + shapeLimits margin periodInt len) + return (limits, ())) + (const $ return ()) + + +shapeLimits :: + (Ip.C nodesLeap, Ip.C nodesStep, Exp Int ~ t) => + Exp (Ip.Margin (nodesLeap (nodesStep value))) -> + t -> t -> (t, t) +shapeLimits margin periodInt len = + case shapeMargin margin periodInt of + (leftMargin, rightMargin) -> (leftMargin, len - rightMargin) + +shapeMargin :: + (Ip.C nodesLeap, Ip.C nodesStep, Exp Int ~ i) => + Exp (Ip.Margin (nodesLeap (nodesStep value))) -> + i -> (i, i) +shapeMargin margin periodInt = + let (marginNumber, marginOffset) = + Expr.unzip $ + Expr.lift1 (uncurry MultiValue.zip . Ip.unzipMargin) margin + leftMargin = marginOffset + periodInt + rightMargin = marginNumber - leftMargin + in (leftMargin, rightMargin) + +_shapeLimits :: + (Ip.C nodesLeap, Ip.C nodesStep) => + (MultiValue.NativeFloating t tr) => + (MultiValue.Additive t) => + Ip.Margin (nodesLeap (nodesStep value)) -> + Exp Word -> Exp t -> (Exp t, Exp t) +_shapeLimits margin periodInt len = + let (leftMargin, rightMargin) = _shapeMargin margin periodInt + in (Expr.fromIntegral leftMargin, len - Expr.fromIntegral rightMargin) + +_shapeMargin :: + (Ip.C nodesLeap, Ip.C nodesStep, Ring.C i) => + Ip.Margin (nodesLeap (nodesStep value)) -> + i -> (i, i) +_shapeMargin margin periodInt = + let leftMargin = fromIntegral (Ip.marginOffset margin) + periodInt + rightMargin = fromIntegral (Ip.marginNumber margin) - leftMargin + in (leftMargin, rightMargin) + +combineMarginParams :: + (Ip.C nodesStep, Ip.C nodesLeap) => + (forall r. Ip.T r nodesLeap a v) -> + (forall r. Ip.T r nodesStep a v) -> + Exp Int -> + Exp (Ip.Margin (nodesLeap (nodesStep v))) +combineMarginParams ipLeap ipStep periodInt = + let marginLeap = Ip.toMargin ipLeap in + let marginStep = Ip.toMargin ipStep in + Expr.lift2 Ip.zipMargin + (fromIntegral (Ip.marginNumber marginStep) + + fromIntegral (Ip.marginNumber marginLeap) * periodInt) + (fromIntegral (Ip.marginOffset marginStep) + + fromIntegral (Ip.marginOffset marginLeap) * periodInt) + +_combineMargins :: + Ip.Margin (nodesLeap value) -> + Ip.Margin (nodesStep value) -> + Int -> + Ip.Margin (nodesLeap (nodesStep value)) +_combineMargins marginLeap marginStep periodInt = + Ip.Margin { + Ip.marginNumber = + Ip.marginNumber marginStep + + Ip.marginNumber marginLeap * periodInt, + Ip.marginOffset = + Ip.marginOffset marginStep + + Ip.marginOffset marginLeap * periodInt + } + + +{- | +@zigZagLong loopStart loopLength@ +creates a curve that starts at 0 +and is linear until it reaches @loopStart+loopLength@. +Then it begins looping in a ping-pong manner +between @loopStart+loopLength@ and @loopStart@. +It is useful as @shape@ control for looping a sound. +Input of the causal process is the slope (or frequency) control. +Slope values must not be negative. + +*Main> Sig.renderChunky SVL.defaultChunkSize (Causal.take 25 <<< Helix.zigZagLong 6 10 $* 2) () :: SVL.Vector Float +VectorLazy.fromChunks [Vector.pack [0.0,1.999999,3.9999995,6.0,8.0,10.0,12.0,14.0,15.999999,14.000001,12.0,10.0,7.999999,6.0,8.0,10.0,12.0,14.0,16.0,14.0,11.999999,9.999998,7.999998,6.0000024,8.000002]] +-} +zigZagLong :: + (Marshal.C a) => + (MultiValue.Select a, MultiValue.Comparison a, MultiValue.Fraction a) => + (MultiValue.Field a, MultiValue.RationalConstant a) => + Exp a -> Exp a -> Causal.MV a a +zigZagLong = + zigZagLongGen (Causal.fromSignal . Sig.constant) zigZag + +zigZagLongPacked :: + (Marshal.Vector n a) => + (MultiVector.Field a, MultiVector.Fraction a) => + (MultiVector.RationalConstant a) => + (MultiVector.Select a, MultiVector.Comparison a) => + Exp a -> Exp a -> Causal.T (Serial.Value n a) (Serial.Value n a) +zigZagLongPacked = + zigZagLongGen (Causal.fromSignal . SigPS.constant) zigZagPacked + +zigZagLongGen :: + (MultiValue.RationalConstant a, MultiValue.Field a) => + (A.RationalConstant al, A.Field al) => + (Exp a -> Causal.T al al) -> + (Exp a -> Causal.T al al) -> + Exp a -> Exp a -> Causal.T al al +zigZagLongGen constant zz prefix loop = + zz (negate $ prefix/loop) * constant loop + constant prefix + <<< + id / constant loop + +{- | +@zigZag start@ creates a zig-zag curve with values between 0 and 1, inclusively, +that is useful as @shape@ control for looping a sound. +Input of the causal process is the slope (or frequency) control. +Slope values must not be negative. +The start value must be at most 2 and may be negative. +-} +zigZag :: + (Marshal.C a) => + (MultiValue.Select a, MultiValue.Comparison a, MultiValue.Fraction a) => + (MultiValue.Field a, MultiValue.RationalConstant a) => + Exp a -> Causal.MV a a +zigZag start = + Causal.map (\x -> 1 - abs (1-x)) + <<< + Causal.mapAccum + (\d t0 -> let t1 = t0+d in (t0, wrap Expr.select (0<*) t1)) + start + +zigZagPacked :: + (TypeNum.Positive n) => + (Marshal.C a) => + (MultiVector.Field a, MultiVector.Fraction a) => + (MultiVector.RationalConstant a) => + (MultiVector.Select a, MultiVector.Comparison a) => + Exp a -> Causal.T (Serial.Value n a) (Serial.Value n a) +zigZagPacked start = + Causal.map (\x -> 1 - abs (1-x)) + <<< + Causal.mapAccum + (\d t0 -> + let (t1,cum) = SerialExp.cumulate t0 d + in (wrap SerialExp.select (SerialExp.cmp LLVM.CmpLT zero) cum, t1)) + start + +wrap :: + (MultiValue.Field a, MultiValue.Fraction a, MultiValue.RationalConstant a) => + (Exp b -> Exp a -> Exp a -> Exp a) -> + (Exp a -> Exp b) -> + Exp a -> Exp a +wrap select positive a = select (positive a) (2 * Expr.fraction (a/2)) a diff --git a/src/Synthesizer/LLVM/Causal/Parametric.hs b/src/Synthesizer/LLVM/Causal/Parametric.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Causal/Parametric.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE Rank2Types #-} +module Synthesizer.LLVM.Causal.Parametric where + +import qualified Synthesizer.LLVM.Causal.Private as Causal + +import LLVM.DSL.Expression (Exp(Exp)) + +import qualified LLVM.Extra.Multi.Value.Marshal as Marshal +import qualified LLVM.Extra.Multi.Value as MultiValue +import qualified LLVM.Extra.Memory as Memory +import qualified LLVM.Extra.MaybeContinuation as MaybeCont +import qualified LLVM.Extra.Tuple as Tuple + +import qualified LLVM.Core as LLVM + +import Control.Monad.IO.Class (liftIO) + +import Data.IORef (IORef, newIORef, readIORef, writeIORef) + + +data T p a b = + forall global local state. + (Memory.C global, LLVM.IsSized local, Memory.C state) => + Cons (forall r c. + (Tuple.Phi c) => + p -> global -> LLVM.Value (LLVM.Ptr local) -> + a -> state -> MaybeCont.T r c (b, state)) + (forall r. p -> LLVM.CodeGenFunction r (global, state)) + (forall r. p -> global -> LLVM.CodeGenFunction r ()) + + +fromProcess :: String -> (Exp p -> Causal.T a b) -> IO (T (MultiValue.T p) a b) +fromProcess name f = do + ref <- newIORef $ error $ name ++ ": uninitialized parameter reference" + return $ + case f (Exp (liftIO (readIORef ref))) of + Causal.Cons next start stop -> + Cons + (\p global local a state -> + liftIO (writeIORef ref p) >> next global local a state) + (\p -> liftIO (writeIORef ref p) >> start) + (\p global -> liftIO (writeIORef ref p) >> stop global) + + +type MarshalPtr a = LLVM.Ptr (Marshal.Struct a) + +fromProcessPtr :: + (Marshal.C p) => + String -> (Exp p -> Causal.T a b) -> + IO (T (LLVM.Value (MarshalPtr p)) a b) +fromProcessPtr name f = do + ref <- newIORef $ error $ name ++ ": uninitialized parameter reference" + return $ + case f (Exp (liftIO (readIORef ref))) of + Causal.Cons next start stop -> + Cons + (\p global local a state -> + MaybeCont.lift (loadParam ref p) >> next global local a state) + (\p -> loadParam ref p >> start) + (\p global -> loadParam ref p >> stop global) + +loadParam :: + (Marshal.C param) => + IORef (MultiValue.T param) -> + LLVM.Value (MarshalPtr param) -> + LLVM.CodeGenFunction r () +loadParam ref ptr = liftIO . writeIORef ref =<< Memory.load ptr diff --git a/src/Synthesizer/LLVM/Causal/Private.hs b/src/Synthesizer/LLVM/Causal/Private.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Causal/Private.hs @@ -0,0 +1,301 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE Rank2Types #-} +module Synthesizer.LLVM.Causal.Private where + +import qualified Synthesizer.LLVM.Generator.Private as Sig +import Synthesizer.LLVM.Private (getPairPtrs, noLocalPtr, unbool) + +import qualified Synthesizer.Causal.Class as CausalClass +import qualified Synthesizer.Causal.Utility as ArrowUtil +import Synthesizer.Causal.Class (($>)) + +import qualified LLVM.DSL.Expression as Expr +import LLVM.DSL.Expression (Exp) + +import qualified LLVM.Extra.Multi.Value.Marshal as Marshal +import qualified LLVM.Extra.Multi.Value as MultiValue +import qualified LLVM.Extra.Memory as Memory +import qualified LLVM.Extra.MaybeContinuation as MaybeCont +import qualified LLVM.Extra.Control as C +import qualified LLVM.Extra.Arithmetic as A +import qualified LLVM.Extra.Tuple as Tuple + +import qualified LLVM.Core as LLVM +import LLVM.Core (CodeGenFunction) + +import qualified Type.Data.Num.Decimal as TypeNum + +import qualified Control.Category as Cat +import Control.Arrow (Arrow, arr, first, (&&&), (<<<)) +import Control.Category (Category) +import Control.Applicative (Applicative, pure, liftA2, (<*>), (<$>)) + +import Data.Tuple.Strict (mapFst, zipPair) +import Data.Word (Word) + +import qualified Number.Ratio as Ratio +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import NumericPrelude.Base hiding (map, zip, zipWith, init) + +import qualified Prelude as P + + +data T a b = + forall global local state. + (Memory.C global, LLVM.IsSized local, Memory.C state) => + Cons (forall r c. + (Tuple.Phi c) => + global -> LLVM.Value (LLVM.Ptr local) -> + a -> state -> MaybeCont.T r c (b, state)) + -- compute next value + (forall r. CodeGenFunction r (global, state)) + -- initial state + (forall r. global -> CodeGenFunction r ()) + -- cleanup + + +type instance CausalClass.ProcessOf Sig.T = T + +instance CausalClass.C T where + type SignalOf T = Sig.T + toSignal (Cons next start stop) = Sig.Cons + (\global local -> next global local ()) + start + stop + fromSignal (Sig.Cons next start stop) = Cons + (\global local _ -> next global local) + start + stop + + +noGlobal :: + (LLVM.IsSized local, Memory.C state) => + (forall r c. + (Tuple.Phi c) => + LLVM.Value (LLVM.Ptr local) -> a -> state -> MaybeCont.T r c (b, state)) -> + (forall r. CodeGenFunction r state) -> + T a b +noGlobal next start = + Cons (const next) (fmap ((,) ()) start) return + +simple :: + (Memory.C state) => + (forall r c. (Tuple.Phi c) => a -> state -> MaybeCont.T r c (b, state)) -> + (forall r. CodeGenFunction r state) -> + T a b +simple next start = noGlobal (noLocalPtr next) start + +mapAccum :: + (Memory.C state) => + (forall r. a -> state -> CodeGenFunction r (b, state)) -> + (forall r. CodeGenFunction r state) -> + T a b +mapAccum next = + simple (\a s -> MaybeCont.lift $ next a s) + +map :: + (forall r. a -> CodeGenFunction r b) -> + T a b +map f = + mapAccum (\a s -> fmap (flip (,) s) $ f a) (return ()) + +zipWith :: + (forall r. a -> b -> CodeGenFunction r c) -> + T (a,b) c +zipWith f = map (uncurry f) + + +instance Category T where + id = map return + Cons nextB startB stopB . Cons nextA startA stopA = Cons + (\(globalA, globalB) local a (sa0,sb0) -> do + (localA,localB) <- getPairPtrs local + (b,sa1) <- nextA globalA localA a sa0 + (c,sb1) <- nextB globalB localB b sb0 + return (c, (sa1,sb1))) + (liftA2 zipPair startA startB) + (\(globalA, globalB) -> stopA globalA >> stopB globalB) + +instance Arrow T where + arr f = map (return . f) + first (Cons next start stop) = Cons (firstNext next) start stop + +firstNext :: + (Functor m) => + (global -> local -> a -> s -> m (b, s)) -> + global -> local -> (a, c) -> s -> m ((b, c), s) +firstNext next global local (b,d) s0 = + fmap + (\(c,s1) -> ((c,d), s1)) + (next global local b s0) + + +instance Functor (T a) where + fmap = flip (>>^) + +instance Applicative (T a) where + pure = ArrowUtil.pure + (<*>) = ArrowUtil.apply + + +infixr 1 >>^, ^>> + +(>>^) :: T a b -> (b -> c) -> T a c +Cons next start stop >>^ f = + Cons + (\global local a state -> mapFst f <$> next global local a state) + start stop + +(^>>) :: (a -> b) -> T b c -> T a c +f ^>> Cons next start stop = + Cons + (\global local -> next global local . f) + start stop + + +mapProc :: + (forall r. b -> CodeGenFunction r c) -> + T a b -> T a c +mapProc f x = map f <<< x + +zipProcWith :: + (forall r. b -> c -> CodeGenFunction r d) -> + T a b -> T a c -> T a d +zipProcWith f x y = zipWith f <<< x&&&y + + +instance (A.Additive b) => Additive.C (T a b) where + zero = pure A.zero + negate = mapProc A.neg + (+) = zipProcWith A.add + (-) = zipProcWith A.sub + +instance (A.PseudoRing b, A.IntegerConstant b) => Ring.C (T a b) where + one = pure A.one + fromInteger n = pure (A.fromInteger' n) + (*) = zipProcWith A.mul + +instance (A.Field b, A.RationalConstant b) => Field.C (T a b) where + fromRational' x = pure (A.fromRational' $ Ratio.toRational98 x) + (/) = zipProcWith A.fdiv + + +instance (A.PseudoRing b, A.Real b, A.IntegerConstant b) => P.Num (T a b) where + fromInteger n = pure (A.fromInteger' n) + negate = mapProc A.neg + (+) = zipProcWith A.add + (-) = zipProcWith A.sub + (*) = zipProcWith A.mul + abs = mapProc A.abs + signum = mapProc A.signum + +instance + (A.Field b, A.Real b, A.RationalConstant b) => P.Fractional (T a b) where + fromRational x = pure (A.fromRational' x) + (/) = zipProcWith A.fdiv + + +{- | +Not quite the loop of ArrowLoop +because we need a delay of one time step +and thus an initialization value. + +For a real ArrowLoop.loop, that is a zero-delay loop, +we would formally need a MonadFix instance of CodeGenFunction. +But this will not become reality, since LLVM is not able to re-order code +in a way that allows to access a result before creating the input. +-} +loop :: + (Memory.C c) => + (forall r. CodeGenFunction r c) -> T (a,c) (b,c) -> T a b +loop initial (Cons next start stop) = Cons + (\global local a0 (c0,s0) -> do + ((b1,c1), s1) <- next global local (a0,c0) s0 + return (b1,(c1,s1))) + (liftA2 (\ini (global,s) -> (global,(ini,s))) initial start) + stop + + +replicateSerial :: + (Tuple.Undefined a, Tuple.Phi a) => + Exp Word -> T a a -> T a a +replicateSerial n proc = + (\a -> ((),a)) ^>> replicateControlled n (snd^>>proc) + +replicateControlled :: + (Tuple.Undefined a, Tuple.Phi a) => + Exp Word -> T (c,a) a -> T (c,a) a +replicateControlled n (Cons next start stop) = Cons + (\(len,globalStates) local (c,a) () -> + MaybeCont.fromMaybe $ fmap (\(_,ms) -> flip (,) () <$> ms) $ + MaybeCont.arrayLoop len globalStates a $ + \globalStatePtr a0 -> do + (global, s0) <- MaybeCont.lift $ Memory.load globalStatePtr + (a1,s1) <- next global local (c,a0) s0 + MaybeCont.lift $ + Memory.store s1 =<< + LLVM.getElementPtr0 globalStatePtr (TypeNum.d1, ()) + return a1) + (do + MultiValue.Cons len <- Expr.unExp n + globalStates <- LLVM.arrayMalloc len + C.arrayLoop len globalStates () $ \globalStatePtr () -> + flip Memory.store globalStatePtr =<< start + return ((len,globalStates), ())) + (\(len,globalStates) -> do + C.arrayLoop len globalStates () $ \globalStatePtr () -> + stop =<< Memory.load + =<< LLVM.getElementPtr0 globalStatePtr (TypeNum.d0, ()) + LLVM.free globalStates) + +{- +We can implement 'replicateControlled' in terms of 'replicateSerial' +but this adds constraints @(Tuple.Undefined c, Tuple.Phi c)@. +-} +replicateControlledAlt :: + (Tuple.Undefined a, Tuple.Phi a) => + (Tuple.Undefined c, Tuple.Phi c) => + Exp Word -> T (c,a) a -> T (c,a) a +replicateControlledAlt n proc = + replicateSerial n (arr fst &&& proc) >>^ snd + +replicateParallel :: + (Tuple.Undefined b, Tuple.Phi b) => + Exp Word -> Sig.T b -> T (b,b) b -> T a b -> T a b +replicateParallel n z cum p = + replicateControlled n (cum <<< first p) $> z + + +quantizeLift :: + (Memory.C b, Marshal.C c, MultiValue.IntegerConstant c, + MultiValue.Additive c, MultiValue.Comparison c) => + T a b -> T (MultiValue.T c, a) b +quantizeLift (Cons next start stop) = Cons + (\global local (k, a0) yState0 -> do + (yState1, frac1) <- + MaybeCont.fromBool $ + C.whileLoop + (LLVM.valueOf True, yState0) + (\(cont1, (_, frac0)) -> + LLVM.and cont1 . unbool + =<< MultiValue.cmp LLVM.CmpLE frac0 A.zero) + (\(_,((_,state01), frac0)) -> + MaybeCont.toBool $ liftA2 (,) + (next global local a0 state01) + (MaybeCont.lift $ A.add frac0 k)) + + frac2 <- MaybeCont.lift $ A.sub frac1 A.one + return (fst yState1, (yState1, frac2))) +{- using this initialization code we would not need undefined values + (do (global,s) <- start + (a,_) <- next s + return (global, ((a,s), A.zero)) +-} + (do + (global,s) <- start + return (global, ((Tuple.undef, s), A.zero))) + stop diff --git a/src/Synthesizer/LLVM/Causal/Process.hs b/src/Synthesizer/LLVM/Causal/Process.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Causal/Process.hs @@ -0,0 +1,787 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE Rank2Types #-} +module Synthesizer.LLVM.Causal.Process ( + Causal.T, MV, + CausalClass.fromSignal, + CausalClass.toSignal, + (CausalClass.$<), (CausalClass.$>), (CausalClass.$*), + ($<#), ($>#), ($*#), + map, + zipWith, + takeWhile, + take, + mix, + raise, + envelope, + envelopeStereo, + amplify, + amplifyStereo, + mapLinear, + mapExponential, + loop, + loopZero, + integrate, + integrateZero, + delay1, + delayControlled, + delayControlledInterpolated, + differentiate, + feedbackControlled, + feedbackControlledZero, + mapAccum, + fromModifier, + osciCoreSync, + osciCore, + osci, + shapeModOsci, + skip, + frequencyModulation, + frequencyModulationLinear, + Causal.quantizeLift, + track, + delay, + delayZero, + Causal.replicateControlled, + replicateControlledParam, + stereoFromMono, + stereoFromMonoControlled, + stereoFromMonoParametric, + comb, + combStereo, + reverbExplicit, + reverbParams, + trigger, + arrayElement, + vectorize, + pipeline, + ) where + +import qualified Synthesizer.LLVM.Causal.Parametric as Parametric +import qualified Synthesizer.LLVM.Causal.Private as Causal +import qualified Synthesizer.LLVM.Generator.Private as SigPriv +import qualified Synthesizer.LLVM.Generator.Signal as Sig +import qualified Synthesizer.LLVM.RingBuffer as RingBuffer +import qualified Synthesizer.LLVM.Interpolation as Interpolation +import qualified Synthesizer.LLVM.Frame.Stereo as Stereo +import qualified Synthesizer.LLVM.Frame as Frame +import Synthesizer.LLVM.Generator.Private (arraySize) +import Synthesizer.LLVM.Private (noLocalPtr, unbool) + +import qualified Synthesizer.Plain.Modifier as Modifier +import qualified Synthesizer.Causal.Class as CausalClass +import Synthesizer.Causal.Class (($*), ($<)) + +import qualified LLVM.DSL.Expression as Expr +import LLVM.DSL.Expression (Exp) + +import qualified LLVM.Extra.Multi.Vector as MultiVector +import qualified LLVM.Extra.Multi.Value.Marshal as Marshal +import qualified LLVM.Extra.Multi.Value as MultiValue +import qualified LLVM.Extra.Memory as Memory +import qualified LLVM.Extra.MaybeContinuation as MaybeCont +import qualified LLVM.Extra.Maybe as Maybe +import qualified LLVM.Extra.Tuple as Tuple +import qualified LLVM.Extra.Iterator as Iter +import qualified LLVM.Extra.Control as C +import qualified LLVM.Extra.Arithmetic as A + +import qualified LLVM.Core as LLVM + +import qualified Type.Data.Num.Decimal as TypeNum +import Type.Data.Num.Decimal ((:<:)) +import Type.Base.Proxy (Proxy(Proxy)) + +import qualified Data.List as List +import Data.Traversable (sequenceA) +import Data.Tuple.HT (mapSnd, swap) +import Data.Word (Word) + +import qualified Control.Arrow as Arrow +import qualified Control.Category as Cat +import qualified Control.Monad.Trans.State as MS +import qualified Control.Functor.HT as FuncHT +import qualified Control.Applicative.HT as App +import Control.Arrow (Arrow, arr, (<<<), (^<<), (<<^), (>>>), (***), (&&&)) +import Control.Applicative (pure, liftA2, liftA3, (<$>)) + +import qualified System.Unsafe as Unsafe +import System.Random (Random, RandomGen, randomR) + +import qualified Algebra.Additive as Additive +import NumericPrelude.Numeric +import NumericPrelude.Base hiding (map, zipWith, takeWhile, take) +import Prelude () + + +type MV a b = Causal.T (MultiValue.T a) (MultiValue.T b) + + +infixl 0 $<#, $>#, $*# + +{- | +provide constant input in a comfortable way +-} +($*#) :: + (CausalClass.C process, CausalClass.SignalOf process ~ signal, + MultiValue.C a) => + process (MultiValue.T a) b -> a -> signal b +proc $*# x = CausalClass.applyConst proc $ MultiValue.cons x + +($<#) :: + (CausalClass.C process, MultiValue.C a) => + process (MultiValue.T a, b) c -> a -> process b c +proc $<# x = CausalClass.applyConstFst proc $ MultiValue.cons x + +($>#) :: + (CausalClass.C process, MultiValue.C b) => + process (a, MultiValue.T b) c -> b -> process a c +proc $># x = CausalClass.applyConstSnd proc $ MultiValue.cons x + + + +map :: + (Expr.Aggregate ae a, Expr.Aggregate be b) => + (ae -> be) -> Causal.T a b +map f = Causal.map (\a -> Expr.bundle (f (Expr.dissect a))) + +zipWith :: + (Expr.Aggregate ae a, Expr.Aggregate be b, Expr.Aggregate ce c) => + (ae -> be -> ce) -> Causal.T (a,b) c +zipWith f = map (uncurry f) + +takeWhile :: (Expr.Aggregate ae a) => (ae -> Exp Bool) -> Causal.T a a +takeWhile p = Causal.simple + (\a () -> do + MaybeCont.guard . unbool =<< MaybeCont.lift (Expr.unliftM1 p a) + return (a,())) + (return ()) + +take :: Exp Word -> Causal.T a a +take len = + arr snd $< (takeWhile (0 Expr.<*) $* Sig.iterate (subtract 1) len) + + +{- | +You may also use '(+)'. +-} +mix :: (A.Additive a) => Causal.T (a,a) a +mix = Causal.zipWith Frame.mix + +{- | +You may also use '(+)' and a 'Sig.constant' signal or a number literal. +-} +raise :: (Marshal.C a, MultiValue.Additive a) => Exp a -> MV a a +raise x = mix $< Sig.constant x + + +{- | +You may also use '(*)'. +-} +envelope :: (A.PseudoRing a) => Causal.T (a, a) a +envelope = Causal.zipWith Frame.amplifyMono + +envelopeStereo :: (A.PseudoRing a) => Causal.T (a, Stereo.T a) (Stereo.T a) +envelopeStereo = Causal.zipWith Frame.amplifyStereo + +{- | +You may also use '(*)' and a 'Sig.constant' signal or a number literal. +-} +amplify :: + (Expr.Aggregate ea a, Memory.C a, A.PseudoRing a) => + ea -> Causal.T a a +amplify x = envelope $< Sig.constant x + +amplifyStereo :: + (Marshal.C a, MultiValue.PseudoRing a, Stereo.T (MultiValue.T a) ~ stereo) => + Exp a -> Causal.T stereo stereo +amplifyStereo x = envelopeStereo $< Sig.constant x + + +mapLinear :: + (Marshal.C a, MultiValue.T a ~ am, + MultiValue.PseudoRing a, MultiValue.IntegerConstant a) => + Exp a -> Exp a -> Causal.T am am +mapLinear depth center = map (\x -> center + depth*x) + +-- ToDo: use base 2 +mapExponential :: + (Marshal.C a, MultiValue.T a ~ am, + MultiValue.Transcendental a, MultiValue.RationalConstant a) => + Exp a -> Exp a -> Causal.T am am +mapExponential depth center = + let logDepth = log depth + in map (\x -> center * exp (logDepth * x)) + + +loop :: + (Expr.Aggregate ce c, Memory.C c) => + ce -> Causal.T (a,c) (b,c) -> Causal.T a b +loop initial = Causal.loop (Expr.bundle initial) + +loopZero :: + (A.Additive c, Memory.C c) => + Causal.T (a,c) (b,c) -> Causal.T a b +loopZero = Causal.loop (return A.zero) + +loopConst :: + (Memory.C c) => + c -> Causal.T (a,c) (b,c) -> Causal.T a b +loopConst c = Causal.loop (return c) + + +integrate :: + (Expr.Aggregate ae a, A.Additive a, Memory.C a) => ae -> Causal.T a a +integrate initial = loop initial (arr snd &&& Causal.zipWith A.add) + +integrateZero :: (A.Additive a, Memory.C a) => Causal.T a a +integrateZero = loopZero (arr snd &&& Causal.zipWith A.add) + + +feedbackControlledAux :: + (Arrow arrow) => + arrow ((ctrl,a),c) b -> + arrow (ctrl,b) c -> + arrow ((ctrl,a),c) (b,c) +feedbackControlledAux forth back = + arr snd &&& back <<< arr (fst.fst) &&& forth + +feedbackControlled :: + (Expr.Aggregate ce c, Memory.C c) => + ce -> Causal.T ((ctrl,a),c) b -> Causal.T (ctrl,b) c -> Causal.T (ctrl,a) b +feedbackControlled initial forth back = + loop initial (feedbackControlledAux forth back) + +feedbackControlledZero :: + (A.Additive c, Memory.C c) => + Causal.T ((ctrl,a),c) b -> Causal.T (ctrl,b) c -> Causal.T (ctrl,a) b +feedbackControlledZero forth back = + loopZero (feedbackControlledAux forth back) + + +arrayPtr :: + (TypeNum.Natural n, LLVM.IsSized a) => + LLVM.Value (LLVM.Ptr a) -> + LLVM.CodeGenFunction r (LLVM.Value (LLVM.Ptr (LLVM.Array n a))) +arrayPtr = LLVM.bitcast + +replicateControlledParam :: + (TypeNum.Natural n) => + (Tuple.Undefined a, Tuple.Phi a) => + (Marshal.C b, (n TypeNum.:*: LLVM.SizeOf (Marshal.Struct b)) ~ bSize, + TypeNum.Natural bSize) => + (Exp b -> Causal.T (c,a) a) -> + Exp (MultiValue.Array n b) -> Causal.T (c,a) a +replicateControlledParam f ps = Unsafe.performIO $ do + let n :: Word + n = TypeNum.integralFromProxy $ arraySize ps + paramd <- Parametric.fromProcessPtr "Causal.replicateControlledParam" f + return $ + case paramd of + Parametric.Cons next start stop -> + Causal.Cons + (\(bPtr,globalPtr) localPtr (c,a0) statePtr -> do + a1 <- + MaybeCont.fromBool $ + Iter.mapWhileState_ + (\(biPtr,globalIPtr,localIPtr,stateIPtr) + (_cont,ai0) -> do + global <- Memory.load globalIPtr + local <- Memory.load localIPtr + state0 <- Memory.load stateIPtr + (conti,(ai1,state1)) <- + MaybeCont.toBool $ + next biPtr global local (c,ai0) state0 + flip LLVM.store stateIPtr =<< Memory.compose state1 + return (conti,(conti,ai1))) + (Iter.take (LLVM.valueOf n) $ + App.lift4 (,,,) + (Iter.arrayPtrs bPtr) + (Iter.arrayPtrs globalPtr) + (Iter.arrayPtrs localPtr) + (Iter.arrayPtrs statePtr)) + (LLVM.valueOf True, a0) + return (a1, statePtr)) + (do + bArr <- Expr.unExp ps + bPtr <- LLVM.arrayMalloc n + Memory.store bArr =<< arrayPtr bPtr + {- + ToDo: + Instead of a pointer to a malloced with dynamic length + we could use LLVM.Array. + However, we would have to establish the constraint + Natural (n :*: LLVM.SizeOf (Marshal.Struct a)) + This is pretty cumbersome + with current decimal number representation. + It would be feasible with type-level natural numbers, though. + -} + globalPtr <- LLVM.arrayMalloc n + statePtr <- LLVM.arrayMalloc n + Iter.mapM_ + (\(biPtr,globalIPtr,stateIPtr) -> do + (global,state) <- start biPtr + flip LLVM.store globalIPtr =<< Memory.compose global + flip LLVM.store stateIPtr =<< Memory.compose state) + (Iter.take (LLVM.valueOf n) $ + liftA3 (,,) + (Iter.arrayPtrs bPtr) + (Iter.arrayPtrs globalPtr) + (Iter.arrayPtrs statePtr)) + return ((bPtr,globalPtr), statePtr)) + (\(bPtr,globalPtr) -> + Iter.mapM_ + (\(biPtr,globalIPtr) -> do + stop biPtr =<< Memory.load globalIPtr) + (Iter.take (LLVM.valueOf n) $ + liftA2 (,) + (Iter.arrayPtrs bPtr) + (Iter.arrayPtrs globalPtr))) + + +{- | +Run a causal process independently on each stereo channel. +-} +stereoFromMono :: + (Tuple.Phi a, Tuple.Undefined a, Tuple.Phi b, Tuple.Undefined b) => + Causal.T a b -> Causal.T (Stereo.T a) (Stereo.T b) +stereoFromMono proc = + snd + ^<< + Causal.replicateSerial 2 + ((\((x,a),b) -> (Stereo.swap a, Stereo.cons (Stereo.right b) x)) + ^<< + Arrow.first ((proc <<^ Stereo.left) &&& Cat.id)) + <<^ + (\a -> (a, Tuple.undef)) + +stereoFromMonoControlled :: + (Tuple.Phi a, Tuple.Phi b, Tuple.Phi c, + Tuple.Undefined a, Tuple.Undefined b, Tuple.Undefined c) => + Causal.T (c,a) b -> Causal.T (c, Stereo.T a) (Stereo.T b) +stereoFromMonoControlled proc = + stereoFromMono proc <<^ (\(c,sa) -> (,) c <$> sa) + +arrayFromStereo :: + (Marshal.C a) => + Stereo.T (MultiValue.T a) -> + LLVM.CodeGenFunction r (MultiValue.T (MultiValue.Array TypeNum.D2 a)) +arrayFromStereo a = + MultiValue.insertArrayValue TypeNum.d0 (Stereo.left a) =<< + MultiValue.insertArrayValue TypeNum.d1 (Stereo.right a) MultiValue.undef + +stereoFromMonoParametric :: + (Marshal.C x, + Tuple.Phi a, Tuple.Undefined a, Tuple.Phi b, Tuple.Undefined b) => + ((TypeNum.D2 TypeNum.:*: LLVM.SizeOf (Marshal.Struct x)) ~ xSize, + TypeNum.Natural xSize) => + (Exp x -> Causal.T a b) -> + Stereo.T (Exp x) -> Causal.T (Stereo.T a) (Stereo.T b) +stereoFromMonoParametric f sx = + snd + ^<< + replicateControlledParam + (\x -> + (\((y,a),b) -> (Stereo.swap a, Stereo.cons (Stereo.right b) y)) + ^<< + Arrow.first ((f x <<^ Stereo.left) &&& Cat.id) + <<^ + snd) + (Expr.liftM arrayFromStereo sx) + <<^ + (\a -> ((),(a,Tuple.undef))) + + +mapAccum :: + (Expr.Aggregate state statel, Memory.C statel, + Expr.Aggregate a al, Expr.Aggregate b bl) => + (a -> state -> (b, state)) -> state -> Causal.T al bl +mapAccum next start = + Causal.mapAccum + (\a s -> Expr.bundle $ next (Expr.dissect a) (Expr.dissect s)) + (Expr.bundle start) + +fromModifier :: + (Expr.Aggregate ae al, + Expr.Aggregate be bl, + Expr.Aggregate ce cl, + Expr.Aggregate se sl, Memory.C sl) => + Modifier.Simple se ce ae be -> Causal.T (cl,al) bl +fromModifier (Modifier.Simple initial step) = + mapAccum (\(c,a) -> MS.runState (step c a)) initial + + +delay1 :: (Expr.Aggregate ae a, Memory.C a) => ae -> Causal.T a a +delay1 initial = loop initial (arr swap) + +differentiate :: + (A.Additive a, Expr.Aggregate ae a, Memory.C a) => ae -> Causal.T a a +differentiate initial = Cat.id - delay1 initial + + +{- | +Compute the phases from phase distortions and frequencies. + +It's like integrate but with wrap-around performed by @fraction@. +For FM synthesis we need also negative phase distortions, +thus we use 'A.addToPhase' which supports that. +-} +osciCore, _osciCore, osciCoreSync :: + (Memory.C t, A.Fraction t) => Causal.T (t, t) t +_osciCore = + Causal.zipWith A.addToPhase <<< + Arrow.second + (Causal.mapAccum + (\a s -> do + b <- A.incPhase a s + return (s,b)) + (return A.zero)) + +{- +This could be implemented using a generalized frequencyModulation, +however, osciCoreSync allows for negative phase differences. +-} +osciCoreSync = + Causal.zipWith A.addToPhase <<< + Arrow.second + (Causal.mapAccum + (\a s -> do + b <- A.incPhase a s + return (b,b)) + (return A.zero)) + +osciCore = + Causal.zipWith A.addToPhase <<< + Arrow.second (loopZero (arr snd &&& Causal.zipWith A.incPhase)) + +osci :: + (Memory.C t, A.Fraction t) => + (forall r. t -> LLVM.CodeGenFunction r y) -> + Causal.T (t, t) y +osci wave = Causal.map wave <<< osciCore + +shapeModOsci :: + (Memory.C t, A.Fraction t) => + (forall r. c -> t -> LLVM.CodeGenFunction r y) -> + Causal.T (c, (t, t)) y +shapeModOsci wave = Causal.zipWith wave <<< Arrow.second osciCore + + +{- | +Feeds a signal into a causal process while holding or skipping signal elements +according to the process input. +The skip happens after a value is passed from the fed signal. + +@skip x $* 0@ repeats the first signal value in the output. +@skip x $* 1@ feeds the signal to the output as is. +@skip x $* 2@ feeds the signal to the output with double speed. +-} +skip :: + (Tuple.Undefined a, Tuple.Phi a, Memory.C a) => + Sig.T a -> Causal.T (MultiValue.T Word) a +skip (SigPriv.Cons next start stop) = Causal.Cons + (\global local n1 (yState0, MultiValue.Cons n0) -> do + yState1@(y,_) <- + MaybeCont.fromMaybe $ fmap snd $ + MaybeCont.fixedLengthLoop n0 yState0 $ + next global local . snd + return (y, (yState1,n1))) + (mapSnd (\s -> ((Tuple.undef, s), A.one)) <$> start) + stop + +frequencyModulation :: + (Marshal.C a, + MultiValue.IntegerConstant a, + MultiValue.Additive a, + MultiValue.Comparison a, + Tuple.Undefined nodes, Tuple.Phi nodes, Memory.C nodes) => + (forall r. MultiValue.T a -> nodes -> LLVM.CodeGenFunction r v) -> + SigPriv.T nodes -> Causal.T (MultiValue.T a) v +frequencyModulation ip (SigPriv.Cons next start stop) = Causal.Cons + (\global local k yState0 -> do + ((nodes2,state2), ss2) <- + MaybeCont.fromBool $ + C.whileLoop + (LLVM.valueOf True, yState0) + (\(cont0, (_, ss0)) -> + LLVM.and cont0 . unbool =<< MultiValue.cmp LLVM.CmpGE ss0 A.one) + (\(_,((_,state0), ss0)) -> + MaybeCont.toBool $ liftA2 (,) + (next global local state0) + (MaybeCont.lift $ A.sub ss0 A.one)) + + MaybeCont.lift $ do + y <- ip ss2 nodes2 + ss3 <- A.add ss2 k + return (y, ((nodes2, state2), ss3))) + (fmap (\(global,sa) -> (global, ((Tuple.undef, sa), A.one))) start) + stop + +frequencyModulationLinear :: + (MultiValue.PseudoRing a, MultiValue.IntegerConstant a, + MultiValue.Comparison a, Marshal.C a) => + Sig.MV a -> MV a a +frequencyModulationLinear sig = + frequencyModulation Interpolation.linear (Sig.adjacentNodes02 sig) + + +track :: + (Expr.Aggregate ae al, Memory.C al) => + ae -> Exp Word -> Causal.T al (RingBuffer.T al) +track initial time = Causal.Cons + (\(size0,ptr) -> noLocalPtr $ \a remain0 -> MaybeCont.lift $ do + Memory.store a =<< LLVM.getElementPtr ptr (remain0, ()) + cont <- A.cmp LLVM.CmpGT remain0 A.zero + remain1 <- C.ifThenSelect cont size0 (A.dec remain0) + size1 <- A.inc size0 + return (RingBuffer.Cons ptr size1 remain0 remain1, remain1)) + (do + MultiValue.Cons size0 <- Expr.unExp time + size1 <- A.inc size0 + ptr <- LLVM.arrayMalloc size1 + a <- Expr.bundle initial + -- cf. LLVM.Storable.Signal.fill + C.arrayLoop size1 ptr () $ \ ptri () -> Memory.store a ptri + return ((size0,ptr), size0)) + (LLVM.free . snd) + +{- | +Delay time must be non-negative. +-} +delay :: + (Expr.Aggregate ae al, Memory.C al) => + ae -> Exp Word -> Causal.T al al +delay initial time = Causal.map RingBuffer.oldest <<< track initial time + +delayZero :: + (Expr.Aggregate ae al, Additive.C ae, Memory.C al) => + Exp Word -> Causal.T al al +delayZero = delay zero + +{- | +Delay time must be greater than zero! +-} +comb :: + (Marshal.C a, MultiValue.PseudoRing a) => + Exp a -> Exp Word -> MV a a +comb gain time = + loopZero (mix >>> (Cat.id &&& (delayZero (time-1) >>> amplify gain))) + +combStereo :: + (Marshal.C a, MultiValue.PseudoRing a, Stereo.T (MultiValue.T a) ~ stereo) => + Exp a -> Exp Word -> Causal.T stereo stereo +combStereo gain time = + loopZero (mix >>> (Cat.id &&& (delayZero (time-1) >>> amplifyStereo gain))) + +reverbExplicit :: + (TypeNum.Natural n, (n TypeNum.:*: LLVM.UnknownSize) ~ paramSize, + TypeNum.Natural paramSize) => + (Marshal.C a, + MultiValue.Field a, MultiValue.Real a, MultiValue.IntegerConstant a) => + Exp (MultiValue.Array n (a,Word)) -> MV a a +reverbExplicit params = + amplify (Expr.recip $ TypeNum.integralFromProxy $ arraySize params) + <<< + replicateControlledParam + (\p -> Arrow.first (comb (Expr.fst p) (Expr.snd p)) >>> mix) + params + <<^ + (\a -> (a,a)) + +reverbParams :: + (RandomGen g, TypeNum.Integer n, Random a) => + g -> Proxy n -> (a,a) -> (Word, Word) -> MultiValue.Array n (a, Word) +reverbParams rnd Proxy gainRange timeRange = + flip MS.evalState rnd $ + sequenceA $ pure $ + liftA2 (,) + (MS.state (randomR gainRange)) + (MS.state (randomR timeRange)) + + +{- | +Delay by a variable amount of samples. +The momentum delay must be between @0@ and @maxTime@, inclusively. +How about automated clipping? +-} +delayControlled :: + (Expr.Aggregate ae al, Memory.C al) => + ae -> Exp Word -> Causal.T (MultiValue.T Word, al) al +delayControlled initial maxTime = + Causal.zipWith RingBuffer.index + <<< + arr (\(MultiValue.Cons i) -> i) *** track initial maxTime + +{- | +Delay by a variable fractional amount of samples. +Non-integer delays are achieved by interpolation. +The momentum delay must be between @0@ and @maxTime@, inclusively. +-} +delayControlledInterpolated :: + (Interpolation.C nodes) => + (MultiValue.T a ~ am) => + (MultiValue.NativeFloating a ar, MultiValue.Additive a) => + (Expr.Aggregate ve v, Memory.C v) => + (forall r. Interpolation.T r nodes am v) -> + ve -> Exp Word -> Causal.T (am, v) v +delayControlledInterpolated ip initial maxTime = + let margin = Interpolation.toMargin ip + in Causal.zipWith + (\del buf -> do + let offset = + A.fromInteger' $ fromIntegral $ + Interpolation.marginOffset margin + n <- A.max offset =<< MultiValue.truncateToInt del + k <- A.sub del =<< MultiValue.fromIntegral n + ~(MultiValue.Cons m) <- A.sub n (offset :: MultiValue.T Word) + ip k =<< + Interpolation.indexNodes (flip RingBuffer.index buf) A.one m) + <<< + Arrow.second + (track initial + (fromIntegral (Interpolation.marginNumber margin) + maxTime)) + + +{- | +This allows to compute a chain of equal processes efficiently, +if all of these processes can be bundled in one vectorial process. +Applications are an allpass cascade or an FM operator cascade. + +The function expects that the vectorial input process +works like parallel scalar processes. +The different pipeline stages may be controlled by different parameters, +but the structure of all pipeline stages must be equal. +Our function feeds the input of the pipelined process +to the zeroth element of the Vector. +The result of processing the i-th element (the i-th channel, so to speak) +is fed to the (i+1)-th element. +The (n-1)-th element of the vectorial process is emitted +as output of the pipelined process. + +The pipeline necessarily introduces a delay of (n-1) values. +For simplification we extend this to n values delay. +If you need to combine the resulting signal from the pipeline +with another signal in a 'zip'-like way, +you may delay that signal with @pipeline id@. +The first input values in later stages of the pipeline +are initialized with zero. +If this is not appropriate for your application, +then we may add a more sensible initialization. +-} +pipeline :: + (TypeNum.Positive n, MultiVector.C x, + v ~ MultiVector.T n x, + a ~ MultiValue.T x, + Tuple.Zero v, Memory.C v) => + Causal.T v v -> Causal.T a a +pipeline vectorProcess = + loopConst MultiVector.zero $ + Causal.map (uncurry MultiVector.shiftUp) + >>> + Arrow.second vectorProcess + + +{- +insert and extract instructions will be in opposite order, +no matter whether we use foldr or foldl +and independent from the order of proc and channel in replaceChannel. +However, LLVM neglects the order anyway. +-} +vectorize :: + (TypeNum.Positive n, + MultiVector.C x, MultiValue.T x ~ a, MultiVector.T n x ~ va, + MultiVector.C y, MultiValue.T y ~ b, MultiVector.T n y ~ vb) => + Causal.T a b -> Causal.T va vb +vectorize proc = + withSize $ \n -> + foldl + (\acc i -> replaceChannel i proc acc) + (arr (const Tuple.undef)) $ + List.take (TypeNum.integralFromSingleton n) [0 ..] + +withSize :: + (TypeNum.Positive n, MultiVector.T n a ~ v) => + (TypeNum.Singleton n -> f v) -> + f v +withSize f = f TypeNum.singleton + +{- | +Given a vector process, replace the i-th output by output +that is generated by a scalar process from the i-th input. +-} +replaceChannel :: + (TypeNum.Positive n, + MultiVector.C x, MultiValue.T x ~ a, MultiVector.T n x ~ va, + MultiVector.C y, MultiValue.T y ~ b, MultiVector.T n y ~ vb) => + Int -> Causal.T a b -> Causal.T va vb -> Causal.T va vb +replaceChannel i channel proc = + let li = LLVM.valueOf $ fromIntegral i + in Causal.zipWith (MultiVector.insert li) <<< + (channel <<< Causal.map (MultiVector.extract li)) &&& + proc + + +{- | +Read the i-th element from each array. +-} +arrayElement :: + (Marshal.C a, Marshal.Struct a ~ aStruct, LLVM.IsFirstClass aStruct, + TypeNum.Natural i, TypeNum.Natural n, i :<: n) => + Proxy i -> Causal.T (MultiValue.T (MultiValue.Array n a)) (MultiValue.T a) +arrayElement i = Causal.map (MultiValue.extractArrayValue i) + + +{- | +@trigger fill signal@ sends @signal@ to the output +and restarts it whenever the process input is 'Just'. +Before the Arrow.first occurrence of 'Just' +and between instances of the signal the output is filled with 'Maybe.nothing'. +-} +trigger :: + (Marshal.C a, Tuple.Undefined b, Tuple.Phi b) => + (Exp a -> Sig.T b) -> + Causal.T (Maybe.T (MultiValue.T a)) (Maybe.T b) +trigger f = Unsafe.performIO $ do + paramd <- + Parametric.fromProcess "Causal.trigger" (CausalClass.fromSignal . f) + return $ + case paramd of + Parametric.Cons next start stop -> Causal.Cons + (\globalPtr local ma ms0 -> MaybeCont.lift $ do + ms1 <- + Maybe.run ma + (return ms0) + (\a -> do + stopAndFree stop globalPtr + (global2,state2) <- start a + Memory.store (Maybe.just (a,global2)) globalPtr + return $ Maybe.just state2) + mc1 <- Memory.load globalPtr + mcs1 <- Maybe.lift2 (,) mc1 ms1 + as2 <- + Maybe.run mcs1 (return Maybe.nothing) $ \((p1,c1),s1) -> + MaybeCont.toMaybe $ next p1 c1 local () s1 + return $ FuncHT.unzip as2) + (do + globalPtr <- LLVM.malloc + Memory.store (nothingFromFunc f stop) globalPtr + return (globalPtr, Maybe.nothing)) + (\globalPtr -> do + stopAndFree stop globalPtr + LLVM.free globalPtr) + +stopAndFree :: + (Memory.C global, Memory.C am) => + (am -> global -> LLVM.CodeGenFunction r ()) -> + LLVM.Value (LLVM.Ptr (Memory.Struct (Maybe.T (am, global)))) -> + LLVM.CodeGenFunction r () +stopAndFree stop globalPtr = do + maybeGlobal <- Memory.load globalPtr + Maybe.for maybeGlobal $ \(a,global) -> stop a global + +nothingFromFunc :: + (MultiValue.C a, Tuple.Undefined global) => + (Exp a -> Sig.T b) -> + (ap -> global -> code) -> + Maybe.T (MultiValue.T a, global) +nothingFromFunc _ _ = Maybe.nothing diff --git a/src/Synthesizer/LLVM/Causal/ProcessPacked.hs b/src/Synthesizer/LLVM/Causal/ProcessPacked.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Causal/ProcessPacked.hs @@ -0,0 +1,180 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE Rank2Types #-} +module Synthesizer.LLVM.Causal.ProcessPacked where + +import qualified Synthesizer.LLVM.Causal.Private as CausalPriv +import qualified Synthesizer.LLVM.Causal.Process as Causal +import qualified Synthesizer.LLVM.Frame.SerialVector as Serial +import qualified Synthesizer.LLVM.Frame.SerialVector.Code as SerialCode +import qualified Synthesizer.LLVM.Frame.SerialVector.Class as SerialClass +import qualified Synthesizer.LLVM.Frame.Stereo as Stereo +import qualified Synthesizer.LLVM.Frame as Frame + +import qualified LLVM.DSL.Expression as Expr +import LLVM.DSL.Expression (Exp) + +import qualified LLVM.Extra.Multi.Vector as MultiVector +import qualified LLVM.Extra.Multi.Value.Marshal as Marshal +import qualified LLVM.Extra.Multi.Value as MultiValue +import qualified LLVM.Extra.Tuple as Tuple +import qualified LLVM.Extra.MaybeContinuation as Maybe +import qualified LLVM.Extra.Control as C +import qualified LLVM.Extra.Arithmetic as A + +import qualified Type.Data.Num.Decimal as TypeNum +import Type.Data.Num.Decimal ((:<:)) +import Type.Base.Proxy (Proxy) + +import qualified LLVM.Core as LLVM + +import qualified Control.Arrow as Arrow +import qualified Control.Category as Cat +import qualified Control.Monad.Trans.Class as MT +import qualified Control.Monad.Trans.State as MS +import Control.Arrow ((<<<)) + +import Data.Tuple.HT (swap) +import Data.Word (Word) + +import NumericPrelude.Numeric +import NumericPrelude.Base hiding (map, zipWith, takeWhile) +import Prelude () + + +type Serial n a = MultiValue.T (Serial.T n a) + + +{- | +Run a scalar process on packed data. +If the signal length is not divisible by the chunk size, +then the last chunk is dropped. +-} +pack :: + (SerialClass.Read va, n ~ SerialClass.Size va, a ~ SerialClass.Element va, + SerialClass.Write vb, n ~ SerialClass.Size vb, b ~ SerialClass.Element vb) + => + Causal.T a b -> Causal.T va vb +pack (CausalPriv.Cons next start stop) = CausalPriv.Cons + (\global local a s -> do + r <- Maybe.lift $ SerialClass.readStart a + ((_,w2),(_,s2)) <- + Maybe.fromBool $ + C.whileLoop + (LLVM.valueOf True, + let w = Tuple.undef + in ((r,w), + (LLVM.valueOf (SerialClass.sizeOfIterator w :: Word), s))) + (\(cont,(_rw0,(i0,_s0))) -> + A.and cont =<< A.cmp LLVM.CmpGT i0 A.zero) + (\(_,((r0,w0),(i0,s0))) -> Maybe.toBool $ do + (ai,r1) <- Maybe.lift $ SerialClass.readNext r0 + (bi,s1) <- next global local ai s0 + Maybe.lift $ do + w1 <- SerialClass.writeNext bi w0 + i1 <- A.dec i0 + return ((r1,w1),(i1,s1))) + b <- Maybe.lift $ SerialClass.writeStop w2 + return (b, s2)) + start + stop + +{- | +Like 'pack' but duplicates the code for the scalar process. +That is, for vectors of size n, +the code for the scalar causal process will be written n times. +This is efficient only for simple input processes. +-} +packSmall :: + (SerialClass.Read va, n ~ SerialClass.Size va, a ~ SerialClass.Element va, + SerialClass.Write vb, n ~ SerialClass.Size vb, b ~ SerialClass.Element vb) + => + Causal.T a b -> Causal.T va vb +packSmall (CausalPriv.Cons next start stop) = CausalPriv.Cons + (\global local a -> + MS.runStateT $ + MT.lift . Maybe.lift . SerialClass.assemble + =<< + mapM (MS.StateT . next global local) + =<< + (MT.lift $ Maybe.lift $ SerialClass.dissect a)) + start + stop + + +raise :: + (TypeNum.Positive n, MultiVector.Additive a) => + Exp a -> Causal.T (Serial n a) (Serial n a) +raise x = + CausalPriv.map + (\y -> Expr.unExp (Serial.upsample x) >>= flip Frame.mix y) + +amplify :: + (TypeNum.Positive n, MultiVector.PseudoRing a) => + Exp a -> Causal.T (Serial n a) (Serial n a) +amplify x = + CausalPriv.map + (\y -> Expr.unExp (Serial.upsample x) >>= flip Frame.amplifyMono y) + +amplifyStereo :: + (TypeNum.Positive n, MultiVector.PseudoRing a) => + Exp a -> Causal.T (Stereo.T (Serial n a)) (Stereo.T (Serial n a)) +amplifyStereo x = + CausalPriv.map + (\y -> Expr.unExp (Serial.upsample x) >>= flip Frame.amplifyStereo y) + + +delay1 :: + (LLVM.Positive n, Marshal.C a, + MultiVector.C a, SerialCode.Value n a ~ v) => + Exp a -> Causal.T v v +delay1 initial = + Causal.loop initial $ + Causal.map (swap . uncurry Serial.shiftUp . swap) + +differentiate :: + (LLVM.Positive n, Marshal.C a, + MultiVector.Additive a, SerialCode.Value n a ~ v) => + Exp a -> Causal.T v v +differentiate initial = Cat.id - delay1 initial + +integrate :: + (LLVM.Positive n, Marshal.C a, + MultiVector.Additive a, SerialCode.Value n a ~ v) => + Exp a -> Causal.T v v +integrate = + Causal.mapAccum (\a acc0 -> swap $ Serial.cumulate acc0 a) + + +osciCore :: + (TypeNum.Positive n, Marshal.C t, MultiVector.Fraction t) => + Causal.T (Serial n t, Serial n t) (Serial n t) +osciCore = + CausalPriv.zipWith A.addToPhase <<< + Arrow.second + (Causal.mapAccum + (\a phase0 -> + let (phase1,b1) = Serial.cumulate phase0 a + in (b1, Expr.liftM A.signedFraction phase1)) + Expr.zero) + +osci :: + (TypeNum.Positive n, Marshal.C t, MultiVector.Fraction t) => + (forall r. Serial n t -> LLVM.CodeGenFunction r y) -> + Causal.T (Serial n t, Serial n t) y +osci wave = CausalPriv.map wave <<< osciCore + +shapeModOsci :: + (TypeNum.Positive n, Marshal.C t, MultiVector.Fraction t) => + (forall r. c -> Serial n t -> LLVM.CodeGenFunction r y) -> + Causal.T (c, (Serial n t, Serial n t)) y +shapeModOsci wave = CausalPriv.zipWith wave <<< Arrow.second osciCore + + +arrayElement :: + (TypeNum.Positive n, + MultiVector.C a, Marshal.C a, + Marshal.Struct a ~ aStruct, LLVM.IsFirstClass aStruct, + TypeNum.Natural i, TypeNum.Natural d, i :<: d) => + Proxy i -> Causal.T (MultiValue.T (MultiValue.Array d a)) (Serial n a) +arrayElement i = Causal.map Serial.upsample <<< Causal.arrayElement i diff --git a/src/Synthesizer/LLVM/Causal/ProcessValue.hs b/src/Synthesizer/LLVM/Causal/ProcessValue.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Causal/ProcessValue.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE Rank2Types #-} +module Synthesizer.LLVM.Causal.ProcessValue ( + Causal.T, + mapAccum, + fromModifier, + ) where + +import qualified Synthesizer.LLVM.Causal.Private as Causal + +import qualified Synthesizer.LLVM.Value as Value + +import qualified Synthesizer.Plain.Modifier as Modifier + +import qualified LLVM.Extra.MaybeContinuation as MaybeCont +import qualified LLVM.Extra.Memory as Memory + +import qualified LLVM.Core as LLVM + +import Control.Monad.Trans.State (runState) + + + +mapAccum :: + (Memory.C state) => + (forall r. a -> state -> LLVM.CodeGenFunction r (b, state)) -> + (forall r. LLVM.CodeGenFunction r state) -> + Causal.T a b +mapAccum next = Causal.simple (\a s -> MaybeCont.lift $ next a s) + +fromModifier :: + (Value.Flatten ah, Value.Registers ah ~ al, + Value.Flatten bh, Value.Registers bh ~ bl, + Value.Flatten ch, Value.Registers ch ~ cl, + Value.Flatten sh, Value.Registers sh ~ sl, + Memory.C sl) => + Modifier.Simple sh ch ah bh -> Causal.T (cl,al) bl +fromModifier (Modifier.Simple initial step) = + mapAccum + (\(c,a) s -> + Value.flatten $ + runState + (step (Value.unfold c) (Value.unfold a)) + (Value.unfold s)) + (Value.flatten initial) diff --git a/src/Synthesizer/LLVM/Causal/Render.hs b/src/Synthesizer/LLVM/Causal/Render.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Causal/Render.hs @@ -0,0 +1,389 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ForeignFunctionInterface #-} +module Synthesizer.LLVM.Causal.Render ( + -- * type driven + RunArg, DSLArg, + run, + runPlugged, + processIO, + Render.Buffer, Render.buffer, + + -- * explicit argument converters + runPluggedExplicit, + build, -- ToDo: better name + Plugs, + + -- * internally used in FunctionalPlug + processIOParametric, + ) where + +import qualified Synthesizer.LLVM.Private.Render as Render +import qualified Synthesizer.LLVM.Causal.Parametric as Parametric +import Synthesizer.LLVM.Causal.Private (T(Cons)) +import Synthesizer.LLVM.Private.Render + (RunArg (DSLArg, buildArg), + Triple, tripleStruct, derefStartPtr, derefStopPtr) + +import qualified Synthesizer.LLVM.Plug.Input as PIn +import qualified Synthesizer.LLVM.Plug.Output as POut + +import qualified Synthesizer.CausalIO.Process as PIO +import qualified Synthesizer.Generic.Cut as Cut + +import qualified LLVM.DSL.Render.Run as Run +import qualified LLVM.DSL.Render.Argument as Arg +import qualified LLVM.DSL.Execution as Exec +import LLVM.DSL.Render.Run ((*->)) +import LLVM.DSL.Expression (Exp(Exp)) + +import qualified LLVM.Extra.Multi.Value.Storable as Storable +import qualified LLVM.Extra.Multi.Value.Marshal as Marshal +import qualified LLVM.Extra.Multi.Value as MultiValue +import qualified LLVM.Extra.Memory as Memory +import qualified LLVM.Extra.MaybeContinuation as MaybeCont +import qualified LLVM.Extra.Maybe as Maybe +import qualified LLVM.Extra.Tuple as Tuple + +import qualified LLVM.Core as LLVM + +import qualified Type.Data.Num.Decimal as TypeNum + +import qualified Data.StorableVector.Base as SVB +import qualified Data.StorableVector as SV + +import qualified Control.Monad.Trans.Reader as MR +import Control.Monad (when, join) +import Control.Applicative (liftA3) + +import Foreign.Ptr (Ptr) + +import Data.Tuple.HT (snd3) +import Data.Word (Word) + + + +foreign import ccall safe "dynamic" derefFillPtr :: + Exec.Importer (LLVM.Ptr global -> Word -> Ptr a -> Ptr b -> IO Word) + + +compile :: + (Storable.C a, MultiValue.T a ~ al, + Storable.C b, MultiValue.T b ~ bl, + Marshal.C param, Marshal.Struct param ~ paramStruct) => + (Exp param -> T al bl) -> + IO (LLVM.Ptr paramStruct -> Word -> Ptr a -> Ptr b -> IO Word) +compile proc = + Exec.compile "process" $ + Exec.createFunction derefFillPtr "fill" $ \paramPtr size aPtr bPtr -> + case proc (Exp (Memory.load paramPtr)) of + Cons next start stop -> do + (global,s) <- start + local <- LLVM.alloca + (pos,_) <- Storable.arrayLoopMaybeCont2 size aPtr bPtr s $ + \aPtri bPtri s0 -> do + a <- MaybeCont.lift $ Storable.load aPtri + (b,s1) <- next global local a s0 + MaybeCont.lift $ Storable.store b bPtri + return s1 + stop global + return pos + +runAux :: + (Marshal.C p, + Storable.C a, MultiValue.T a ~ al, + Storable.C b, MultiValue.T b ~ bl) => + (Exp p -> T al bl) -> + IO (IO () -> p -> SV.Vector a -> IO (SV.Vector b)) +runAux proc = do + fill <- compile proc + return $ \final param as -> + Marshal.with param $ \paramPtr -> + SVB.withStartPtr as $ \ aPtr len -> + SVB.createAndTrim len $ \bPtr -> do + n <- fill paramPtr (fromIntegral len) aPtr bPtr + final + return $ fromIntegral n + +_run :: + (Marshal.C p, + Storable.C a, MultiValue.T a ~ al, + Storable.C b, MultiValue.T b ~ bl) => + (Exp p -> T al bl) -> IO (p -> SV.Vector a -> IO (SV.Vector b)) +_run = fmap ($ return ()) . runAux + + + +foreign import ccall safe "dynamic" derefChunkPtr :: + Exec.Importer (LLVM.Ptr globalState -> Word -> Ptr a -> Ptr b -> IO Word) + +_compileChunky :: + (LLVM.IsSized paramStruct, LLVM.Value (LLVM.Ptr paramStruct) ~ pPtr, + Memory.C state, Memory.Struct state ~ stateStruct, + Memory.C global, Memory.Struct global ~ globalStruct, + Triple paramStruct globalStruct stateStruct ~ triple, + LLVM.IsSized local, + Storable.C a, MultiValue.T a ~ valueA, + Storable.C b, MultiValue.T b ~ valueB) => + (forall r z. (Tuple.Phi z) => + pPtr -> + global -> LLVM.Value (LLVM.Ptr local) -> + valueA -> state -> MaybeCont.T r z (valueB, state)) -> + (forall r. pPtr -> LLVM.CodeGenFunction r (global, state)) -> + (forall r. pPtr -> global -> LLVM.CodeGenFunction r ()) -> + IO (LLVM.Ptr paramStruct -> IO (LLVM.Ptr triple), + Exec.Finalizer triple, + LLVM.Ptr triple -> Word -> Ptr a -> Ptr b -> IO Word) +_compileChunky next start stop = + Exec.compile "process-chunky" $ + liftA3 (,,) + (Exec.createFunction derefStartPtr "startprocess" $ + \paramPtr -> do + paramGlobalStatePtr <- LLVM.malloc + (global,state) <- start paramPtr + flip LLVM.store paramGlobalStatePtr =<< + join + (liftA3 tripleStruct + (LLVM.load paramPtr) + (Memory.compose global) + (Memory.compose state)) + return paramGlobalStatePtr) + (Exec.createFinalizer derefStopPtr "stopprocess" $ + \paramGlobalStatePtr -> do + paramPtr <- + LLVM.getElementPtr0 paramGlobalStatePtr (TypeNum.d0, ()) + stop paramPtr =<< + Memory.load =<< + LLVM.getElementPtr0 paramGlobalStatePtr (TypeNum.d1, ()) + LLVM.free paramGlobalStatePtr) + (Exec.createFunction derefChunkPtr "fillprocess" $ + \paramGlobalStatePtr loopLen aPtr bPtr -> do + paramPtr <- + LLVM.getElementPtr0 paramGlobalStatePtr (TypeNum.d0, ()) + globalPtr <- + LLVM.getElementPtr0 paramGlobalStatePtr (TypeNum.d1, ()) + statePtr <- + LLVM.getElementPtr0 paramGlobalStatePtr (TypeNum.d2, ()) + global <- Memory.load globalPtr + sInit <- Memory.load statePtr + local <- LLVM.alloca + (pos,sExit) <- + Storable.arrayLoopMaybeCont2 loopLen aPtr bPtr sInit $ + \ aPtri bPtri s0 -> do + a <- MaybeCont.lift $ Storable.load aPtri + (b,s1) <- next paramPtr global local a s0 + MaybeCont.lift $ Storable.store b bPtri + return s1 + Memory.store (Maybe.fromJust sExit) statePtr + return pos) + + +foreign import ccall safe "dynamic" derefChunkPluggedPtr :: + Exec.Importer + (LLVM.Ptr globalStateStruct -> Word -> + LLVM.Ptr inp -> LLVM.Ptr out -> IO Word) + +compilePlugged :: + (Tuple.Undefined stateIn, Tuple.Phi stateIn) => + (Tuple.Undefined stateOut, Tuple.Phi stateOut) => + (LLVM.IsSized paramStruct, LLVM.Value (LLVM.Ptr paramStruct) ~ pPtr, + Memory.C state, Memory.Struct state ~ stateStruct, + Memory.C global, Memory.Struct global ~ globalStruct, + Triple paramStruct globalStruct stateStruct ~ triple) => + (LLVM.IsSized local) => + (Memory.C paramIn, Memory.Struct paramIn ~ inStruct) => + (Memory.C paramOut, Memory.Struct paramOut ~ outStruct) => + (forall r. + paramIn -> stateIn -> LLVM.CodeGenFunction r (valueA, stateIn)) -> + (forall r. + paramIn -> LLVM.CodeGenFunction r stateIn) -> + (forall r z. (Tuple.Phi z) => + pPtr -> global -> LLVM.Value (LLVM.Ptr local) -> + valueA -> state -> MaybeCont.T r z (valueB, state)) -> + (forall r. pPtr -> LLVM.CodeGenFunction r (global, state)) -> + (forall r. pPtr -> global -> LLVM.CodeGenFunction r ()) -> + (forall r. + paramOut -> valueB -> stateOut -> LLVM.CodeGenFunction r stateOut) -> + (forall r. + paramOut -> LLVM.CodeGenFunction r stateOut) -> + IO (LLVM.Ptr paramStruct -> IO (LLVM.Ptr triple), + LLVM.Ptr triple -> IO (), + LLVM.Ptr triple -> + Word -> LLVM.Ptr inStruct -> LLVM.Ptr outStruct -> IO Word) +compilePlugged nextIn startIn next start stop nextOut startOut = + Exec.compile "process-plugged" $ + liftA3 (,,) + (Exec.createFunction derefStartPtr "startprocess" $ + \paramPtr -> do + paramGlobalStatePtr <- LLVM.malloc + (global,state) <- start paramPtr + flip LLVM.store paramGlobalStatePtr =<< + join + (liftA3 tripleStruct + (LLVM.load paramPtr) + (Memory.compose global) + (Memory.compose state)) + return paramGlobalStatePtr) + (Exec.createFunction derefStopPtr "stopprocess" $ + \paramGlobalStatePtr -> do + paramPtr <- + LLVM.getElementPtr0 paramGlobalStatePtr (TypeNum.d0, ()) + stop paramPtr =<< + Memory.load =<< + LLVM.getElementPtr0 paramGlobalStatePtr (TypeNum.d1, ()) + LLVM.free paramGlobalStatePtr) + (Exec.createFunction derefChunkPluggedPtr "fillprocess" $ + \paramGlobalStatePtr loopLen inPtr outPtr -> do + paramPtr <- + LLVM.getElementPtr0 paramGlobalStatePtr (TypeNum.d0, ()) + globalPtr <- + LLVM.getElementPtr0 paramGlobalStatePtr (TypeNum.d1, ()) + statePtr <- + LLVM.getElementPtr0 paramGlobalStatePtr (TypeNum.d2, ()) + global <- Memory.load globalPtr + sInit <- Memory.load statePtr + inParam <- Memory.load inPtr + outParam <- Memory.load outPtr + inInit <- startIn inParam + outInit <- startOut outParam + local <- LLVM.alloca + (pos,sExit) <- + MaybeCont.fixedLengthLoop loopLen (inInit, sInit, outInit) $ + \ (in0,s0,out0) -> do + (a,in1) <- MaybeCont.lift $ nextIn inParam in0 + (b,s1) <- next paramPtr global local a s0 + out1 <- MaybeCont.lift $ nextOut outParam b out0 + return (in1, s1, out1) + Memory.store (snd3 $ Maybe.fromJust sExit) statePtr + return pos) + + +{- +I liked to write something with signature + +> import qualified Synthesizer.Causal.Process as Causal +> +> liftStorableChunk :: +> (Exp param -> T valueA valueB) -> +> IO (param -> Causal.T (SV.Vector a) (SV.Vector b)) + +but it does not quite work this way. +@Causal.T@ from @synthesizer-core@ uses an immutable state internally, +whereas @T@ uses mutable states. +In principle the immutable state of @Causal.T@ +could be used for breaking the processing of a stream +and continue it on two different streams in parallel. +I have no function that makes use of this feature, +and thus an @ST@ monad might be a way out. + +With this function we can convert an LLVM causal process to a causal IO arrow. +We also need the plugs in order +to read and write LLVM values from and to Haskell data chunks. + +In a second step we could convert this to a processor of lazy lists, +and thus to a processor of chunky storable vectors. +-} +processIOParametric :: + (Marshal.C p, Cut.Read a, x ~ LLVM.Value (LLVM.Ptr (Marshal.Struct p))) => + PIn.T a b -> Parametric.T x b c -> POut.T c d -> + IO (Arg.Creator p -> PIO.T a d) +processIOParametric + (PIn.Cons nextIn startIn createIn deleteIn) + paramd + (POut.Cons nextOut startOut createOut deleteOut) = do + case paramd of + Parametric.Cons next start stop -> do + (startFunc, stopFunc, fill) <- + compilePlugged + nextIn startIn + next start stop + nextOut startOut + return $ \createContext -> PIO.Cons + (\a s@(_,statePtr) -> do + let maximumSize = Cut.length a + (contextIn, paramIn) <- createIn a + (contextOut,paramOut) <- createOut maximumSize + actualSize <- + Marshal.with paramIn $ \inptr -> + Marshal.with paramOut $ \outptr -> + fill statePtr (fromIntegral maximumSize) inptr outptr + -- print actualSize + when (fromIntegral actualSize > maximumSize) $ + error $ "CausalParametrized.Process: " ++ + "output size " ++ show actualSize ++ + " > input size " ++ show maximumSize + deleteIn contextIn + b <- deleteOut (fromIntegral actualSize) contextOut + return (b, s)) + (do + (p, deleteContext) <- createContext + ptr <- Marshal.with p startFunc + return (deleteContext, ptr)) + (\(deleteContext, ptr) -> stopFunc ptr >> deleteContext) + +processIOCore :: + (Marshal.C p, Cut.Read a) => + PIn.T a b -> (Exp p -> T b c) -> POut.T c d -> + IO (Arg.Creator p -> PIO.T a d) +processIOCore pin proc pout = do + paramd <- Parametric.fromProcessPtr "Causal.process" proc + processIOParametric pin paramd pout + +processIO :: + (Marshal.C p, Cut.Read a, PIn.Default a, POut.Default d) => + (Exp p -> T (PIn.Element a) (POut.Element d)) -> + IO (p -> PIO.T a d) +processIO proc = + fmap (\f p -> f (return (p, return ()))) $ + processIOCore PIn.deflt proc POut.deflt + + +type Plugs f a b = MR.ReaderT (PIn.T (In f) a, POut.T b (Out f)) IO + +class Run f where + type DSL f a b + type In f + type Out f + build :: (Marshal.C p) => Run.T (Plugs f a b) p (DSL f a b) f + +instance (Cut.Read a) => Run (PIO.T a b) where + type DSL (PIO.T a b) al bl = T al bl + type In (PIO.T a b) = a + type Out (PIO.T a b) = b + build = + Run.Cons $ \proc -> + MR.ReaderT $ \(pin,pout) -> processIOCore pin proc pout + +instance (RunArg a, Run f) => Run (a -> f) where + type DSL (a -> f) al bl = DSLArg a -> DSL f al bl + type In (a -> f) = In f + type Out (a -> f) = Out f + build = buildArg *-> build + + +runPluggedExplicit :: + Run.T (Plugs f a b) () (DSL f a b) f -> + PIn.T (In f) a -> DSL f a b -> POut.T b (Out f) -> IO f +runPluggedExplicit builder pin proc pout = + MR.runReaderT (Run.run builder proc) (pin,pout) + +runPlugged :: + (Run f) => PIn.T (In f) a -> DSL f a b -> POut.T b (Out f) -> IO f +runPlugged = runPluggedExplicit build + +run :: + (Run f) => + (In f ~ a, PIn.Default a, PIn.Element a ~ al) => + (Out f ~ b, POut.Default b, POut.Element b ~ bl) => + DSL f al bl -> IO f +run proc = runPlugged PIn.deflt proc POut.deflt + +_exampleExplicit :: + (Exp Float -> Exp Word -> T (MultiValue.T Float) (MultiValue.T Word)) -> + IO (Float -> Word -> PIO.T (SV.Vector Float) (SV.Vector Word)) +_exampleExplicit proc = + runPluggedExplicit + (Arg.primitive *-> Arg.primitive *-> build) + PIn.storableVector proc POut.storableVector diff --git a/src/Synthesizer/LLVM/Causal/RingBufferForward.hs b/src/Synthesizer/LLVM/Causal/RingBufferForward.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Causal/RingBufferForward.hs @@ -0,0 +1,281 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE Rank2Types #-} +module Synthesizer.LLVM.Causal.RingBufferForward ( + T, track, trackSkip, trackSkipHold, + index, mapIndex, + ) where + +import qualified Synthesizer.LLVM.Causal.Private as CausalPriv +import qualified Synthesizer.LLVM.Causal.Process as Causal +import qualified Synthesizer.LLVM.Generator.Private as Sig +import Synthesizer.LLVM.RingBuffer (MemoryPtr) + +import Synthesizer.LLVM.Causal.Process (($*#)) +import Synthesizer.Causal.Class (($<), ($*)) + +import qualified LLVM.DSL.Expression as Expr +import LLVM.DSL.Expression (Exp) + +import qualified LLVM.Extra.Multi.Value as MultiValue +import qualified LLVM.Extra.MaybeContinuation as MaybeCont +import qualified LLVM.Extra.Maybe as Maybe +import qualified LLVM.Extra.Memory as Memory +import qualified LLVM.Extra.Control as C +import qualified LLVM.Extra.Arithmetic as A +import qualified LLVM.Extra.Tuple as Tuple + +import qualified LLVM.Core as LLVM +import LLVM.Core (CodeGenFunction, Value) + +import qualified Control.Arrow as Arrow +import Control.Arrow ((<<<), (<<^)) +import Data.Tuple.HT (mapSnd, mapPair) + +import Data.Word (Word) + +import Prelude hiding (length) + + + +{- | +This type is very similar to 'Synthesizer.LLVM.RingBuffer.T' +but differs in several details: + +* It stores values in time order, + whereas 'Synthesizer.LLVM.RingBuffer.T' stores in opposite order. + +* Since it stores future values it is not causal + and can only track signal generators. + +* There is no need for an initial value. + +* It stores one value less than 'Synthesizer.LLVM.RingBuffer.T' + since it is meant to provide infixes of the signal + rather than providing the basis for a delay line. + +Those differences in detail would not justify a new type, +you could achieve the same by a combination of +'Synthesizer.LLVM.RingBuffer.track' +and +'Synthesizer.LLVM.CausalParameterized.Process.skip'. +The fundamental problem of this combination is +that it requires to keep the ring buffer alive +longer than the providing signal exists. +This is not possible with the current design. +That's why we provide the combination of @track@ and @skip@ +in a way that does not suffer from that problem. +This functionality is critical for +'Synthesizer.LLVM.CausalParameterized.Helix.dynamic'. +-} +data T a = + Cons { + buffer :: Value (MemoryPtr a), + length :: Value Word, + current :: Value Word + } + +{- | +This function does not check for range violations. +If the ring buffer was generated by @track time@, +then the minimum index is zero and the maximum index is @time-1@. +Index zero refers to the current sample +and index @time-1@ refers to the one that is farthermost in the future. +-} +index :: (Memory.C a) => MultiValue.T Word -> T a -> CodeGenFunction r a +index (MultiValue.Cons i) rb = do + k <- flip A.irem (length rb) =<< A.add (current rb) i + Memory.load =<< LLVM.getElementPtr (buffer rb) (k, ()) + +mapIndex :: (Memory.C a) => Exp Word -> Causal.T (T a) a +mapIndex k = CausalPriv.map (\buf -> flip index buf =<< Expr.unExp k) + + +{- | +@track time signal@ bundles @time@ successive values of @signal@. +The values can be accessed using 'index' with indices +ranging from 0 to @time-1@. + +The @time@ parameter must be non-negative. +-} +track :: (Memory.C a) => Exp Word -> Sig.T a -> Sig.T (T a) +track time input = trackSkip time input $* 1 + +{- | +@trackSkip time input $* skips@ +is like +@Process.skip (track time input) $* skips@ +but this composition would require a @Memory@ constraint for 'T' +which we cannot provide. +-} +trackSkip :: + (Memory.C a) => + Exp Word -> Sig.T a -> Causal.T (MultiValue.T Word) (T a) +trackSkip time (Sig.Cons next start stop) = + CausalPriv.Cons + (trackNext next) + (trackStart start time) + (trackStop stop) + <<^ + (\(MultiValue.Cons skip) -> skip) + +{- | +Like @trackSkip@ but repeats the last buffer content +when the end of the input signal is reached. +The returned 'Bool' flag is 'True' if a skip could be performed completely +and it is 'False' if the skip exceeds the end of the input. +That is, once a 'False' is returned all following values are tagged with 'False'. +The returned 'Word' value is the number of actually skipped values. +This lags one step behind the input of skip values. +The number of an actual number of skips +is at most the number of requested skips. +If the flag is 'False', then the number of actual skips is zero. +The converse does not apply. + +If the input signal is too short, the output is undefined. +(Before the available data the buffer will be filled with arbitrary values.) +We could fill the buffer with zeros, +but this would require an Arithmetic constraint +and the generated signal would not be very meaningful. +We could also return an empty signal if the input is too short. +However this would require a permanent check. +-} +trackSkipHold :: + (Memory.C a) => + Exp Word -> Sig.T a -> + Causal.T (MultiValue.T Word) ((MultiValue.T Bool, MultiValue.T Word), T a) +trackSkipHold time xs = + Arrow.first + (Arrow.second clearFirst <<^ mapPair (MultiValue.Cons, MultiValue.Cons)) + <<< + trackSkipHold_ time xs + <<^ + (\(MultiValue.Cons skip) -> skip) + +clearFirst :: + (MultiValue.PseudoRing a, MultiValue.Real a, + MultiValue.IntegerConstant a, MultiValue.Select a) => + Causal.MV a a +clearFirst = + Causal.zipWith (\b x -> Expr.select b x 0) + $< (Causal.delay1 Expr.false $*# True) + +trackSkipHold_ :: + (Memory.C a) => + Exp Word -> Sig.T a -> + Causal.T (Value Word) ((Value Bool, Value Word), T a) +trackSkipHold_ time (Sig.Cons next start stop) = + CausalPriv.Cons + (trackNextHold next) + (trackStartHold start time) + (trackStopHold stop) + + +trackNext :: + (Memory.C al, Tuple.Phi z, + Tuple.Phi state, Tuple.Undefined state) => + (forall z0. (Tuple.Phi z0) => + context -> local -> state -> MaybeCont.T r z0 (al, state)) -> + (context, (Value Word, Value (MemoryPtr al))) -> local -> + Value Word -> + (Value Word, (state, Value Word)) -> + MaybeCont.T r z (T al, (Value Word, (state, Value Word))) +trackNext next (context, (size0,ptr)) local n1 (n0, statePos) = do + (state3, pos3) <- + MaybeCont.fromMaybe $ fmap snd $ + MaybeCont.fixedLengthLoop n0 statePos $ \(state0, pos0) -> do + (a, state1) <- next context local state0 + MaybeCont.lift $ + fmap ((,) state1) $ storeNext (size0,ptr) a pos0 + return (Cons ptr size0 pos3, (n1, (state3, pos3))) + +trackStart :: + (LLVM.IsSized am, Tuple.Phi state, Tuple.Undefined state) => + CodeGenFunction r (context, state) -> + Exp Word -> + CodeGenFunction r + ((context, (Value Word, Value (LLVM.Ptr am))), + (Value Word, (state, Value Word))) +trackStart start size = do + (context, state) <- start + ~(MultiValue.Cons size0) <- Expr.unExp size + ptr <- LLVM.arrayMalloc size0 + return ((context, (size0,ptr)), (size0, (state, A.zero))) + +trackStop :: + (LLVM.IsType am) => + (context -> CodeGenFunction r ()) -> + (context, (tl, Value (LLVM.Ptr am))) -> + CodeGenFunction r () +trackStop stop (context, (_size,ptr)) = do + LLVM.free ptr + stop context + + +trackNextHold :: + (Memory.C al, Tuple.Phi z, + Tuple.Phi state, Tuple.Undefined state) => + (forall z0. (Tuple.Phi z0) => + context -> local -> state -> MaybeCont.T r z0 (al, state)) -> + (context, (Value Word, Value (MemoryPtr al))) -> local -> + Value Word -> + (Value Word, (Maybe.T state, Value Word)) -> + MaybeCont.T r z + (((Value Bool, Value Word), T al), + (Value Word, (Maybe.T state, Value Word))) +trackNextHold next (context, (size0,ptr)) local nNext (n0, (mstate0, pos0)) = + MaybeCont.lift $ do + (n3, (pos3, state3)) <- + Maybe.run mstate0 + (return (n0, (pos0, mstate0))) + (\state0 -> + Maybe.loopWithExit (n0, (state0, pos0)) + (\(n1, (state1, pos1)) -> do + cont <- A.cmp LLVM.CmpGT n1 A.zero + fmap (mapSnd ((,) n1 . (,) pos1)) $ + C.ifThen cont + (Maybe.nothing, Maybe.just state1) + (do aState <- + MaybeCont.toMaybe $ next context local state1 + return (aState, fmap snd aState))) + (\((a,state), (n1, (pos1, _mstate))) -> do + pos2 <- storeNext (size0,ptr) a pos1 + n2 <- A.dec n1 + return (n2, (state, pos2)))) + skipped <- A.sub n0 n3 + return (((Maybe.isJust state3, skipped), Cons ptr size0 pos3), + (nNext, (state3, pos3))) + +storeNext :: + (Memory.C al) => + (Value Word, Value (MemoryPtr al)) -> + al -> Value Word -> CodeGenFunction r (Value Word) +storeNext (size0,ptr) a pos0 = do + Memory.store a =<< LLVM.getElementPtr ptr (pos0, ()) + pos1 <- A.inc pos0 + cont <- A.cmp LLVM.CmpLT pos1 size0 + C.select cont pos1 A.zero + + +trackStartHold :: + (LLVM.IsSized am, + Tuple.Phi state, Tuple.Undefined state) => + CodeGenFunction r (context, state) -> + Exp Word -> + CodeGenFunction r + ((context, (Value Word, Value (LLVM.Ptr am))), + (Value Word, (Maybe.T state, Value Word))) +trackStartHold start size = do + (context, state) <- start + ~(MultiValue.Cons size0) <- Expr.unExp size + ptr <- LLVM.arrayMalloc size0 + return ((context, (size0,ptr)), (size0, (Maybe.just state, A.zero))) + +trackStopHold :: + (LLVM.IsType am) => + (context -> CodeGenFunction r ()) -> + (context, (Value Word, Value (LLVM.Ptr am))) -> + CodeGenFunction r () +trackStopHold stop (context, (_size,ptr)) = do + LLVM.free ptr + stop context diff --git a/src/Synthesizer/LLVM/Complex.hs b/src/Synthesizer/LLVM/Complex.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Complex.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Synthesizer.LLVM.Complex ( + Complex.T(Complex.real, Complex.imag), + Struct, + (+:), + Complex.cis, + Complex.scale, + constOf, unfold, + ) where + +import qualified Synthesizer.LLVM.Value as Value + +import qualified LLVM.Extra.Multi.Value.Marshal as Marshal +import qualified LLVM.Extra.Multi.Value as MultiValue +import qualified LLVM.Extra.Memory as Memory +import qualified LLVM.Extra.Tuple as Tuple + +import qualified LLVM.Core as LLVM +import LLVM.Core (Value, ConstValue, IsConst) + +import qualified Type.Data.Num.Decimal as TypeNum + +import Control.Applicative (liftA2) + +import qualified Number.Complex as Complex +import Number.Complex ((+:)) + + +type Struct a = LLVM.Struct (a, (a, ())) + +constOf :: IsConst a => + Complex.T a -> ConstValue (Struct a) +constOf x = + LLVM.constStruct + (LLVM.constOf $ Complex.real x, + (LLVM.constOf $ Complex.imag x, + ())) + +unfold :: + Value (Struct a) -> Complex.T (Value.T (Value a)) +unfold x = + Value.lift0 (LLVM.extractvalue x TypeNum.d0) + +: + Value.lift0 (LLVM.extractvalue x TypeNum.d1) + + +instance (Tuple.Undefined a) => Tuple.Undefined (Complex.T a) where + undef = Tuple.undef +: Tuple.undef + +instance (Tuple.Phi a) => Tuple.Phi (Complex.T a) where + phi bb v = + liftA2 (+:) + (Tuple.phi bb (Complex.real v)) + (Tuple.phi bb (Complex.imag v)) + addPhi bb x y = do + Tuple.addPhi bb (Complex.real x) (Complex.real y) + Tuple.addPhi bb (Complex.imag x) (Complex.imag y) + + +memory :: + (Memory.C l) => + Memory.Record r (Struct (Memory.Struct l)) (Complex.T l) +memory = + liftA2 (+:) + (Memory.element Complex.real TypeNum.d0) + (Memory.element Complex.imag TypeNum.d1) + +instance (Memory.C l) => Memory.C (Complex.T l) where + type Struct (Complex.T l) = Struct (Memory.Struct l) + load = Memory.loadRecord memory + store = Memory.storeRecord memory + decompose = Memory.decomposeRecord memory + compose = Memory.composeRecord memory + + + +instance (MultiValue.C a) => MultiValue.C (Complex.T a) where + type Repr (Complex.T a) = Complex.T (MultiValue.Repr a) + cons x = + consMV + (MultiValue.cons $ Complex.real x) + (MultiValue.cons $ Complex.imag x) + undef = consMV MultiValue.undef MultiValue.undef + zero = consMV MultiValue.zero MultiValue.zero + phi bb a = + case deconsMV a of + (a0,a1) -> liftA2 consMV (MultiValue.phi bb a0) (MultiValue.phi bb a1) + addPhi bb a b = + case (deconsMV a, deconsMV b) of + ((a0,a1), (b0,b1)) -> + MultiValue.addPhi bb a0 b0 >> MultiValue.addPhi bb a1 b1 + +consMV :: MultiValue.T a -> MultiValue.T a -> MultiValue.T (Complex.T a) +consMV (MultiValue.Cons a) (MultiValue.Cons b) = MultiValue.Cons (a+:b) + +deconsMV :: MultiValue.T (Complex.T a) -> (MultiValue.T a, MultiValue.T a) +deconsMV (MultiValue.Cons x) = + (MultiValue.Cons $ Complex.real x, MultiValue.Cons $ Complex.imag x) + + +instance (Marshal.C a) => Marshal.C (Complex.T a) where + pack x = + LLVM.consStruct + (Marshal.pack $ Complex.real x) + (Marshal.pack $ Complex.imag x) + unpack = LLVM.uncurryStruct $ \a b -> Marshal.unpack a +: Marshal.unpack b diff --git a/src/Synthesizer/LLVM/ConstantPiece.hs b/src/Synthesizer/LLVM/ConstantPiece.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/ConstantPiece.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{- | +Data type that allows handling of piecewise constant signals +independently from the source. +-} +module Synthesizer.LLVM.ConstantPiece ( + T(..), + Struct, + parameterMemory, + flatten, + causalMap, + ) where + +import qualified Synthesizer.LLVM.Causal.Private as Causal +import qualified Synthesizer.LLVM.Generator.Private as Sig + +import qualified LLVM.DSL.Expression as Expr + +import qualified LLVM.Extra.MaybeContinuation as Maybe +import qualified LLVM.Extra.Memory as Memory +import qualified LLVM.Extra.Tuple as Tuple +import qualified LLVM.Extra.Arithmetic as A +import LLVM.Extra.Control (whileLoop) + +import qualified LLVM.Core as LLVM +import LLVM.Core (Value, valueOf) + +import Type.Data.Num.Decimal (d0, d1) + +import Data.Tuple.HT (mapSnd) +import Data.Word (Word) + +import Control.Applicative (liftA2, (<$>)) + +import NumericPrelude.Numeric () +import NumericPrelude.Base + + +data T a = Cons (Value Word) a + +instance Functor T where + fmap f (Cons len y) = Cons len (f y) + +instance (Tuple.Phi a) => Tuple.Phi (T a) where + phi bb (Cons len y) = + liftA2 Cons (Tuple.phi bb len) (Tuple.phi bb y) + addPhi bb (Cons lenA ya) (Cons lenB yb) = + Tuple.addPhi bb lenA lenB >> Tuple.addPhi bb ya yb + +instance (Tuple.Undefined a) => Tuple.Undefined (T a) where + undef = Cons Tuple.undef Tuple.undef + +instance (Tuple.Zero a) => Tuple.Zero (T a) where + zero = Cons Tuple.zero Tuple.zero + +type Struct a = LLVM.Struct (Word, (a, ())) + +parameterMemory :: + (Memory.C a) => + Memory.Record r (Struct (Memory.Struct a)) (T a) +parameterMemory = + liftA2 Cons + (Memory.element (\(Cons len _y) -> len) d0) + (Memory.element (\(Cons _len y) -> y) d1) + +instance (Memory.C a) => Memory.C (T a) where + type Struct (T a) = Struct (Memory.Struct a) + load = Memory.loadRecord parameterMemory + store = Memory.storeRecord parameterMemory + decompose = Memory.decomposeRecord parameterMemory + compose = Memory.composeRecord parameterMemory + + +causalMap :: + (Expr.Aggregate a am, Expr.Aggregate b bm) => + (a -> b) -> Causal.T (T am) (T bm) +causalMap f = Causal.map (\(Cons len y) -> Cons len <$> Expr.unliftM1 f y) + + +flatten :: (Memory.C a) => Sig.T (T a) -> Sig.T a +flatten (Sig.Cons next start stop) = + Sig.Cons + (\global local state0 -> do + ~(Cons length1 y1, s1) <- + Maybe.fromBool $ + whileLoop (valueOf True, state0) + (\(cont, (Cons len _y, _s)) -> + LLVM.and cont =<< A.cmp LLVM.CmpEQ len A.zero) + (\(_cont, (Cons _len _y, s)) -> + Maybe.toBool $ next global local s) + length2 <- Maybe.lift (A.dec length1) + return (y1, (Cons length2 y1, s1))) + (mapSnd ((,) (Cons A.zero Tuple.undef)) <$> start) + stop diff --git a/src/Synthesizer/LLVM/EventIterator.hs b/src/Synthesizer/LLVM/EventIterator.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/EventIterator.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ForeignFunctionInterface #-} +module Synthesizer.LLVM.EventIterator where + +import qualified Data.EventList.Relative.BodyTime as EventList +import qualified Numeric.NonNegative.Wrapper as NonNeg + +import qualified LLVM.Extra.Multi.Value.Marshal as Marshal +import qualified LLVM.Core as LLVM + +import Foreign.StablePtr + (StablePtr, newStablePtr, freeStablePtr, deRefStablePtr) +import Foreign.Ptr (FunPtr) +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import Data.Word (Word) + +import Control.Monad ((<=<)) + +import qualified LLVM.DSL.Debug.StablePtr as DebugStable + + +{- +For problems on constraints, see ChunkIterator. +-} +data T a = (Marshal.C a) => Cons (IORef (EventList.T NonNeg.Int a)) + +type MarshalPtr a = LLVM.Ptr (Marshal.Struct a) + + +foreign import ccall "&nextConstantExp" + nextCallBack :: FunPtr (StablePtr (T a) -> MarshalPtr a -> IO Word) + +foreign export ccall "nextConstantExp" + next :: StablePtr (T a) -> MarshalPtr a -> IO Word + + +{- | +Events with subsequent duration 0 are ignored +(and for performance reasons it should not contain too many small values, +say below 100). +-} +new :: (Marshal.C a) => EventList.T NonNeg.Int a -> IO (StablePtr (T a)) +new evs = + DebugStable.trace "new" =<< + newStablePtr . Cons + =<< newIORef + (EventList.fromPairList $ + filter ((/=0) . snd) $ + EventList.toPairList evs) + +dispose :: StablePtr (T a) -> IO () +dispose = freeStablePtr <=< DebugStable.trace "dispose" + +next :: StablePtr (T a) -> MarshalPtr a -> IO Word +next stable eventPtr = + DebugStable.trace "next" stable >>= + deRefStablePtr >>= \state -> + case state of + Cons listRef -> + readIORef listRef >>= + EventList.switchL + (return 0) + (\body time xs -> + writeIORef listRef xs >> + Marshal.poke eventPtr body >> + return (fromIntegral time)) diff --git a/src/Synthesizer/LLVM/Filter/Allpass.hs b/src/Synthesizer/LLVM/Filter/Allpass.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Filter/Allpass.hs @@ -0,0 +1,510 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveTraversable #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Synthesizer.LLVM.Filter.Allpass ( + Parameter, Allpass.parameter, + CascadeParameter(CascadeParameter), flangerParameter, + cascadeParameterMultiValue, cascadeParameterUnMultiValue, + causal, cascade, phaser, + cascadePipeline, phaserPipeline, + causalPacked, cascadePacked, phaserPacked, + ) where + +import Synthesizer.Plain.Filter.Recursive.Allpass (Parameter(Parameter)) +import qualified Synthesizer.Plain.Filter.Recursive.Allpass as Allpass +import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1 + +import qualified Synthesizer.LLVM.Filter.FirstOrder as Filt1L + +import qualified Synthesizer.LLVM.Causal.Private as CausalPriv +import qualified Synthesizer.LLVM.Causal.Process as Causal +import qualified Synthesizer.LLVM.Causal.Functional as F +import qualified Synthesizer.LLVM.Frame.SerialVector.Class as Serial + +import qualified LLVM.DSL.Expression as Expr + +import qualified LLVM.Extra.Multi.Value.Marshal as MarshalMV +import qualified LLVM.Extra.Multi.Vector as MultiVector +import qualified LLVM.Extra.Multi.Value as MultiValue +import qualified LLVM.Extra.Vector as Vector +import qualified LLVM.Extra.Scalar as Scalar +import qualified LLVM.Extra.Storable as Storable +import qualified LLVM.Extra.Marshal as Marshal +import qualified LLVM.Extra.Memory as Memory +import qualified LLVM.Extra.Tuple as Tuple +import qualified LLVM.Extra.Arithmetic as A + +import qualified Type.Data.Num.Decimal as TypeNum +import Type.Base.Proxy (Proxy(Proxy)) + +import Foreign.Storable (Storable) + +import qualified Control.Category as Cat +import qualified Control.Applicative as App +import Control.Arrow ((<<<), (^<<), (<<^), (&&&), arr, first, second) + +import qualified Data.Traversable as Trav +import qualified Data.Foldable as Fold +import Data.Tuple.HT (mapFst) + +import qualified Algebra.Transcendental as Trans +import qualified Algebra.Module as Module + +import NumericPrelude.Numeric +import NumericPrelude.Base + + +instance (Tuple.Phi a) => Tuple.Phi (Parameter a) where + phi = Tuple.phiTraversable + addPhi = Tuple.addPhiFoldable + +instance Tuple.Undefined a => Tuple.Undefined (Parameter a) where + undef = Tuple.undefPointed + +instance Tuple.Zero a => Tuple.Zero (Parameter a) where + zero = Tuple.zeroPointed + +instance + (Expr.Aggregate e mv) => + Expr.Aggregate (Parameter e) (Parameter mv) where + type MultiValuesOf (Parameter e) = Parameter (Expr.MultiValuesOf e) + type ExpressionsOf (Parameter mv) = Parameter (Expr.ExpressionsOf mv) + bundle = Trav.traverse Expr.bundle + dissect = fmap Expr.dissect + +instance (Memory.C a) => Memory.C (Parameter a) where + type Struct (Parameter a) = Memory.Struct a + load = Memory.loadNewtype Parameter + store = Memory.storeNewtype (\(Parameter k) -> k) + decompose = Memory.decomposeNewtype Parameter + compose = Memory.composeNewtype (\(Parameter k) -> k) + +instance (Marshal.C a) => Marshal.C (Parameter a) where + pack (Parameter k) = Marshal.pack k + unpack = Parameter . Marshal.unpack + +instance (MarshalMV.C a) => MarshalMV.C (Parameter a) where + pack (Parameter k) = MarshalMV.pack k + unpack = Parameter . MarshalMV.unpack + +instance (Storable.C a) => Storable.C (Parameter a) where + load = Storable.loadNewtype Parameter Parameter + store = Storable.storeNewtype Parameter (\(Parameter k) -> k) + + +instance (Tuple.Value a) => Tuple.Value (Parameter a) where + type ValueOf (Parameter a) = Parameter (Tuple.ValueOf a) + valueOf = Tuple.valueOfFunctor + +instance (Tuple.VectorValue n a) => Tuple.VectorValue n (Parameter a) where + type VectorValueOf n (Parameter a) = Parameter (Tuple.VectorValueOf n a) + vectorValueOf = fmap Tuple.vectorValueOf . Trav.sequenceA + +instance (MultiValue.C a) => MultiValue.C (Allpass.Parameter a) where + type Repr (Parameter a) = Parameter (MultiValue.Repr a) + cons = paramFromPlainValue . MultiValue.cons . Allpass.getParameter + + undef = paramFromPlainValue MultiValue.undef + zero = paramFromPlainValue MultiValue.zero + + phi bb = + fmap paramFromPlainValue . + MultiValue.phi bb . + plainFromParamValue + addPhi bb a b = + MultiValue.addPhi bb + (plainFromParamValue a) + (plainFromParamValue b) + +instance (MultiVector.C a) => MultiVector.C (Allpass.Parameter a) where + type Repr n (Parameter a) = Parameter (MultiVector.Repr n a) + cons = paramFromPlainVector . MultiVector.cons . fmap Allpass.getParameter + undef = paramFromPlainVector MultiVector.undef + zero = paramFromPlainVector MultiVector.zero + + phi bb = + fmap paramFromPlainVector . + MultiVector.phi bb . + plainFromParamVector + addPhi bb a b = + MultiVector.addPhi bb + (plainFromParamVector a) + (plainFromParamVector b) + + shuffle is a b = + fmap paramFromPlainVector $ + MultiVector.shuffle is (plainFromParamVector a) (plainFromParamVector b) + extract i v = + fmap paramFromPlainValue $ + MultiVector.extract i $ + plainFromParamVector v + insert i a v = + fmap paramFromPlainVector $ + MultiVector.insert i (plainFromParamValue a) $ + plainFromParamVector v + +paramFromPlainVector :: + MultiVector.T n a -> + MultiVector.T n (Allpass.Parameter a) +paramFromPlainVector = + MultiVector.lift1 Allpass.Parameter + +plainFromParamVector :: + MultiVector.T n (Allpass.Parameter a) -> + MultiVector.T n a +plainFromParamVector = + MultiVector.lift1 Allpass.getParameter + +paramFromPlainValue :: + MultiValue.T a -> + MultiValue.T (Allpass.Parameter a) +paramFromPlainValue = + MultiValue.lift1 Allpass.Parameter + +plainFromParamValue :: + MultiValue.T (Allpass.Parameter a) -> + MultiValue.T a +plainFromParamValue = + MultiValue.lift1 Allpass.getParameter + + +instance (Vector.Simple v) => Vector.Simple (Parameter v) where + type Element (Parameter v) = Parameter (Vector.Element v) + type Size (Parameter v) = Vector.Size v + shuffleMatch = Vector.shuffleMatchTraversable + extract = Vector.extractTraversable + +instance (Vector.C v) => Vector.C (Parameter v) where + insert = Vector.insertTraversable + +type instance F.Arguments f (Parameter a) = f (Parameter a) +instance F.MakeArguments (Parameter a) where + makeArgs = id + + +newtype CascadeParameter n a = + CascadeParameter (Allpass.Parameter a) + deriving + (Tuple.Undefined, Tuple.Zero, Storable, + Functor, App.Applicative, Fold.Foldable, Trav.Traversable) + +instance (Tuple.Phi a) => Tuple.Phi (CascadeParameter n a) where + phi bb (CascadeParameter v) = fmap CascadeParameter $ Tuple.phi bb v + addPhi bb (CascadeParameter x) (CascadeParameter y) = Tuple.addPhi bb x y + + +instance (Memory.C a) => Memory.C (CascadeParameter n a) where + type Struct (CascadeParameter n a) = Memory.Struct a + load = Memory.loadNewtype CascadeParameter + store = Memory.storeNewtype (\(CascadeParameter k) -> k) + decompose = Memory.decomposeNewtype CascadeParameter + compose = Memory.composeNewtype (\(CascadeParameter k) -> k) + +instance (Marshal.C a) => Marshal.C (CascadeParameter n a) where + pack (CascadeParameter k) = Marshal.pack k + unpack = CascadeParameter . Marshal.unpack + +instance (MarshalMV.C a) => MarshalMV.C (CascadeParameter n a) where + pack (CascadeParameter k) = MarshalMV.pack k + unpack = CascadeParameter . MarshalMV.unpack + +instance (Storable.C a) => Storable.C (CascadeParameter n a) where + load = Storable.loadNewtype CascadeParameter id + store = Storable.storeNewtype CascadeParameter id + + +instance (Tuple.Value a) => Tuple.Value (CascadeParameter n a) where + type ValueOf (CascadeParameter n a) = Parameter (Tuple.ValueOf a) + valueOf (CascadeParameter a) = Tuple.valueOf a + +instance + (Tuple.VectorValue n a) => + Tuple.VectorValue n (CascadeParameter m a) where + type VectorValueOf n (CascadeParameter m a) = + Parameter (Tuple.VectorValueOf n a) + vectorValueOf = + fmap Tuple.vectorValueOf . Trav.traverse (\(CascadeParameter k) -> k) + +instance (MultiValue.C a) => MultiValue.C (CascadeParameter n a) where + type Repr (CascadeParameter n a) = Parameter (MultiValue.Repr a) + cons (CascadeParameter a) = cascadeFromParamValue $ MultiValue.cons a + + undef = cascadeFromParamValue MultiValue.undef + zero = cascadeFromParamValue MultiValue.zero + + phi bb = + fmap cascadeFromParamValue . + MultiValue.phi bb . + paramFromCascadeValue + addPhi bb a b = + MultiValue.addPhi bb + (paramFromCascadeValue a) + (paramFromCascadeValue b) + +instance (MultiVector.C a) => MultiVector.C (CascadeParameter m a) where + type Repr n (CascadeParameter m a) = Parameter (MultiVector.Repr n a) + cons = + cascadeFromParamVector . MultiVector.cons . + fmap (\(CascadeParameter a) -> a) + undef = cascadeFromParamVector MultiVector.undef + zero = cascadeFromParamVector MultiVector.zero + + phi bb = + fmap cascadeFromParamVector . + MultiVector.phi bb . + paramFromCascadeVector + addPhi bb a b = + MultiVector.addPhi bb + (paramFromCascadeVector a) + (paramFromCascadeVector b) + + shuffle is a b = + fmap cascadeFromParamVector $ + MultiVector.shuffle is + (paramFromCascadeVector a) (paramFromCascadeVector b) + extract i v = + fmap cascadeFromParamValue $ + MultiVector.extract i $ + paramFromCascadeVector v + insert i a v = + fmap cascadeFromParamVector $ + MultiVector.insert i (paramFromCascadeValue a) $ + paramFromCascadeVector v + +cascadeFromParamVector :: + MultiVector.T n (Allpass.Parameter a) -> + MultiVector.T n (CascadeParameter m a) +cascadeFromParamVector = MultiVector.lift1 id + +paramFromCascadeVector :: + MultiVector.T n (CascadeParameter m a) -> + MultiVector.T n (Allpass.Parameter a) +paramFromCascadeVector = MultiVector.lift1 id + +cascadeFromParamValue :: + MultiValue.T (Allpass.Parameter a) -> + MultiValue.T (CascadeParameter m a) +cascadeFromParamValue = MultiValue.lift1 id + +paramFromCascadeValue :: + MultiValue.T (CascadeParameter m a) -> + MultiValue.T (Allpass.Parameter a) +paramFromCascadeValue = MultiValue.lift1 id + + +instance (Vector.Simple v) => Vector.Simple (CascadeParameter n v) where + type Element (CascadeParameter n v) = CascadeParameter n (Vector.Element v) + type Size (CascadeParameter n v) = Vector.Size v + shuffleMatch = Vector.shuffleMatchTraversable + extract = Vector.extractTraversable + +instance (Vector.C v) => Vector.C (CascadeParameter n v) where + insert = Vector.insertTraversable + +type instance F.Arguments f (CascadeParameter n a) = f (CascadeParameter n a) +instance F.MakeArguments (CascadeParameter n a) where + makeArgs = id + + +instance + (Expr.Aggregate e mv, n ~ m) => + Expr.Aggregate (CascadeParameter n e) (CascadeParameter m mv) where + type MultiValuesOf (CascadeParameter n e) = + CascadeParameter n (Expr.MultiValuesOf e) + type ExpressionsOf (CascadeParameter m mv) = + CascadeParameter m (Expr.ExpressionsOf mv) + bundle = Trav.traverse Expr.bundle + dissect = fmap Expr.dissect + + +flangerParameter :: + (Trans.C a, TypeNum.Natural n) => + Proxy n -> a -> CascadeParameter n a +flangerParameter order freq = + CascadeParameter $ + Allpass.flangerParameter (TypeNum.integralFromProxy order) freq + + +causal :: + (Module.C ae ve, Expr.Aggregate ae a, Expr.Aggregate ve v, Memory.C v) => + Causal.T (Parameter a, v) v +causal = Causal.fromModifier Allpass.firstOrderModifier + + +replicateStage :: + (TypeNum.Natural n) => + (Tuple.Phi a, Tuple.Undefined a) => + (Tuple.Phi b, Tuple.Undefined b) => + Proxy n -> + Causal.T (Parameter a, b) b -> + Causal.T (CascadeParameter n a, b) b +replicateStage order stg = + Causal.replicateControlled + (TypeNum.integralFromProxy order) + (stg <<< first (arr (\(CascadeParameter p) -> p))) + +cascade :: + (TypeNum.Natural n) => + (Module.C ae ve, Expr.Aggregate ae a, Expr.Aggregate ve v, Memory.C v) => + (Tuple.Phi a, Tuple.Undefined a) => + (Tuple.Phi v, Tuple.Undefined v) => + Causal.T (CascadeParameter n a, v) v +cascade = replicateStage Proxy causal + +halfVector :: + (A.RationalConstant a, a ~ A.Scalar v, A.PseudoModule v) => + Causal.T v v +halfVector = CausalPriv.map (A.scale $ A.fromRational' 0.5) + +phaser :: + (TypeNum.Natural n) => + (Module.C ae ve, Expr.Aggregate ae a, Expr.Aggregate ve v, Memory.C v) => + (Tuple.Phi a, Tuple.Undefined a) => + (Tuple.Phi v, Tuple.Undefined v) => + (A.RationalConstant a, a ~ A.Scalar v, A.PseudoModule v) => + Causal.T (CascadeParameter n a, v) v +phaser = (cascade + arr snd) <<< second halfVector + + +paramFromCascadeParam :: + MultiValue.T (CascadeParameter n a) -> + Allpass.Parameter (MultiValue.T a) +paramFromCascadeParam (MultiValue.Cons a) = + fmap MultiValue.Cons a + +{- +It shouldn't be too hard to use vector operations for the code we generate, +but LLVM-2.6 does not yet do it. +-} +stage :: + (TypeNum.Positive n, MultiVector.C a, + MultiVector.T n (CascadeParameter n a, a) ~ v, + MultiValue.PseudoRing a, MultiValue.IntegerConstant a, + MarshalMV.C a) => + Proxy n -> Causal.T v v +stage _ = + Causal.vectorize $ + uncurry MultiValue.zip + ^<< + (arr fst &&& + (Scalar.decons + ^<< + causal + <<^ + (\(p, v) -> + (fmap Scalar.Cons $ paramFromCascadeParam p, Scalar.Cons v)))) + <<^ + MultiValue.unzip + +withSize :: + (Proxy n -> Causal.T (mv (CascadeParameter n a), b) c) -> + Causal.T (mv (CascadeParameter n a), b) c +withSize f = f Proxy + +{- | +Fast implementation of 'cascade' using vector instructions. +However, there must be at least one pipeline stage, +primitive element types +and we get a delay by the number of pipeline stages. +-} +cascadePipeline :: + (TypeNum.Positive n, MultiVector.C a, + Tuple.ValueOf a ~ ar, + MultiValue.PseudoRing a, MultiValue.IntegerConstant a, + MarshalMV.C a, MarshalMV.Vector n a) => + Causal.T + (MultiValue.T (CascadeParameter n a), MultiValue.T a) + (MultiValue.T a) +cascadePipeline = withSize $ \order -> + MultiValue.snd + ^<< + Causal.pipeline (stage order) + <<^ + uncurry MultiValue.zip + +vectorId :: + Proxy n -> Causal.T (MultiVector.T n a) (MultiVector.T n a) +vectorId _ = Cat.id + +half :: + (A.RationalConstant a, A.PseudoRing a) => + Causal.T a a +half = CausalPriv.map (A.mul (A.fromRational' 0.5)) + + +causalPacked, + causalNonRecursivePacked :: + (Serial.Write v, Serial.Element v ~ a, + A.PseudoRing a, A.IntegerConstant a, Memory.C a, + A.PseudoRing v, A.IntegerConstant v) => + Causal.T (Parameter a, v) v + +causalPacked = + Filt1L.causalRecursivePacked <<< + (CausalPriv.map (\(Parameter k, _) -> fmap Filt1.Parameter $ A.neg k) &&& + causalNonRecursivePacked) + +causalNonRecursivePacked = + CausalPriv.mapAccum + (\(Parameter k, v0) x1 -> do + (_,v1) <- Serial.shiftUp x1 v0 + y <- A.add v1 =<< A.mul v0 =<< Serial.upsample k + u0 <- Serial.last v0 + return (y, u0)) + (return A.zero) + +cascadePacked, phaserPacked :: + (TypeNum.Natural n, + Serial.Write v, Serial.Element v ~ a, + A.PseudoRing a, A.IntegerConstant a, Memory.C a, + A.PseudoRing v, A.RationalConstant v) => + Causal.T (CascadeParameter n a, v) v +cascadePacked = replicateStage Proxy causalPacked + +phaserPacked = + (cascadePacked + arr snd) <<< + second (CausalPriv.map (A.mul (A.fromRational' 0.5))) + + +-- ToDo: consistent naming with Exponential2 +cascadeParameterMultiValue :: + CascadeParameter n (MultiValue.T a) -> + MultiValue.T (CascadeParameter n a) +cascadeParameterMultiValue (CascadeParameter k) = + MultiValue.Cons $ fmap (\(MultiValue.Cons a) -> a) k + +cascadeParameterUnMultiValue :: + MultiValue.T (CascadeParameter n a) -> + CascadeParameter n (MultiValue.T a) +cascadeParameterUnMultiValue (MultiValue.Cons k) = + CascadeParameter $ fmap MultiValue.Cons k + + +phaserPipelineMV :: + (TypeNum.Positive n, + MultiValue.PseudoRing a, MultiValue.RationalConstant a, + Marshal.C a, MarshalMV.Vector n a) => + Causal.T + (MultiValue.T (CascadeParameter n a), MultiValue.T a) + (MultiValue.T a) +phaserPipelineMV = withSize $ \order -> + Causal.mix <<< + cascadePipeline &&& + (Causal.pipeline (vectorId order) <<^ snd) <<< +-- (Causal.delay (const zero) (const $ TypeNum.integralFromProxy order) <<^ snd) <<< + second half + +phaserPipeline :: + (TypeNum.Positive n, + MultiValue.PseudoRing a, MultiValue.RationalConstant a, + Marshal.C a, MarshalMV.Vector n a) => + Causal.T + (CascadeParameter n (MultiValue.T a), MultiValue.T a) + (MultiValue.T a) +phaserPipeline = phaserPipelineMV <<^ mapFst cascadeParameterMultiValue diff --git a/src/Synthesizer/LLVM/Filter/Butterworth.hs b/src/Synthesizer/LLVM/Filter/Butterworth.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Filter/Butterworth.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} +module Synthesizer.LLVM.Filter.Butterworth ( + parameter, parameterCausal, Cascade.ParameterValue, + Cascade.causal, Cascade.causalPacked, + Cascade.fixSize, + ) where + +import qualified Synthesizer.LLVM.Filter.SecondOrderCascade as Cascade +import qualified Synthesizer.LLVM.Filter.SecondOrder as Filt2 +import qualified Synthesizer.LLVM.Causal.Private as Causal +import qualified Synthesizer.LLVM.Generator.Private as Sig + +import qualified Synthesizer.Plain.Filter.Recursive.Butterworth as Butterworth +import Synthesizer.Plain.Filter.Recursive (Passband) +import Synthesizer.Causal.Class (($<)) + +import qualified LLVM.DSL.Expression as Expr + +import qualified LLVM.Extra.Multi.Value.Marshal as Marshal +import qualified LLVM.Extra.Multi.Value as MultiValue +import qualified LLVM.Extra.Memory as Memory +import qualified LLVM.Extra.Arithmetic as A +import qualified LLVM.Extra.Control as U + +import qualified LLVM.Core as LLVM + +import Data.Word (Word) + + +import qualified Type.Data.Num.Decimal as TypeNum +import Type.Data.Num.Decimal.Number ((:*:)) +import Type.Base.Proxy (Proxy) + +import qualified Algebra.Transcendental as Trans + +import NumericPrelude.Numeric +import NumericPrelude.Base + + + +parameterCausal :: + (TypeNum.Positive (n :*: LLVM.SizeOf (Marshal.Struct a)), + TypeNum.Natural (n :*: LLVM.UnknownSize), + TypeNum.Natural n, Trans.C a, + Marshal.C a, MultiValue.RationalConstant a, MultiValue.Transcendental a) => + Proxy n -> Passband -> + Causal.T (MultiValue.T a, MultiValue.T a) (Cascade.ParameterValue n a) +parameterCausal n kind = + Causal.map + (\((psine, ps), (ratio, freq)) -> + parameterCore n kind psine ps ratio freq) + $< + Sig.zipWith (curry return) Sig.alloca Sig.alloca + +parameter :: + (TypeNum.Positive (n :*: LLVM.SizeOf (Marshal.Struct a)), + TypeNum.Natural (n :*: LLVM.UnknownSize), + TypeNum.Natural n, Trans.C a, + Marshal.C a, MultiValue.RationalConstant a, MultiValue.Transcendental a) => + Proxy n -> Passband -> MultiValue.T a -> MultiValue.T a -> + LLVM.CodeGenFunction r (Cascade.ParameterValue n a) +parameter n kind ratio freq = do + psine <- LLVM.malloc + ps <- LLVM.malloc + pv <- parameterCore n kind psine ps ratio freq + LLVM.free ps + LLVM.free psine + return pv + +parameterCore :: + (TypeNum.Positive (n :*: LLVM.SizeOf (Marshal.Struct a)), + TypeNum.Natural (n :*: LLVM.UnknownSize), + TypeNum.Natural n, Trans.C a, + Marshal.C a, MultiValue.RationalConstant a, MultiValue.Transcendental a) => + Proxy n -> Passband -> + LLVM.Value (LLVM.Ptr (Marshal.Struct (MultiValue.Array n a))) -> + LLVM.Value (LLVM.Ptr (Cascade.ParameterStruct n a)) -> + MultiValue.T a -> MultiValue.T a -> + LLVM.CodeGenFunction r (Cascade.ParameterValue n a) +parameterCore n kind psine ps ratio freq = do + let order = 2 * TypeNum.integralFromProxy n + partialRatio <- Expr.unliftM1 (Butterworth.partialRatio order) ratio + let evalSines :: (Trans.C a) => mv a -> Int -> [a] + evalSines _ = Butterworth.makeSines + let sines = Cascade.constArray n $ evalSines freq order + Memory.store sines psine + s <- LLVM.getElementPtr0 psine (LLVM.valueOf (0::Word), ()) + p <- LLVM.getElementPtr0 ps (LLVM.valueOf (0::Word), ()) + let len = LLVM.valueOf (TypeNum.integralFromProxy n :: Word) + _ <- U.arrayLoop len p s $ \ptri si -> do + sinw <- Memory.load si + flip Memory.store ptri =<< + Filt2.composeParameterMV =<< + Expr.unliftM3 (Butterworth.partialParameter kind) + partialRatio sinw freq + A.advanceArrayElementPtr si + fmap Cascade.ParameterValue $ Memory.load ps diff --git a/src/Synthesizer/LLVM/Filter/Chebyshev.hs b/src/Synthesizer/LLVM/Filter/Chebyshev.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Filter/Chebyshev.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} +module Synthesizer.LLVM.Filter.Chebyshev ( + parameterCausalA, parameterCausalB, + parameterA, parameterB, Cascade.ParameterValue, + Cascade.causal, Cascade.causalPacked, + Cascade.fixSize, + ) where + +import qualified Synthesizer.LLVM.Filter.SecondOrderCascade as Cascade +import qualified Synthesizer.LLVM.Filter.SecondOrder as Filt2 +import qualified Synthesizer.LLVM.Causal.Private as Causal +import qualified Synthesizer.LLVM.Generator.Private as Sig + +import qualified Synthesizer.Plain.Filter.Recursive.Chebyshev as Chebyshev +import qualified Synthesizer.Plain.Filter.Recursive.SecondOrder as Filt2Core +import Synthesizer.Plain.Filter.Recursive (Passband) +import Synthesizer.Causal.Class (($<)) + +import qualified LLVM.DSL.Expression as Expr + +import qualified LLVM.Extra.Multi.Value.Marshal as Marshal +import qualified LLVM.Extra.Multi.Value as MultiValue +import qualified LLVM.Extra.Memory as Memory +import qualified LLVM.Extra.Arithmetic as A +import qualified LLVM.Extra.Control as U + +import qualified LLVM.Core as LLVM +import Data.Word (Word) + +import qualified Type.Data.Num.Decimal as TypeNum +import Type.Data.Num.Decimal.Number ((:*:)) +import Type.Base.Proxy (Proxy) + +import qualified Synthesizer.LLVM.Complex as Complex + +import Control.Applicative (liftA2) + +import qualified Algebra.Transcendental as Trans + +import NumericPrelude.Numeric +import NumericPrelude.Base + + +{- | +@n@ must be at least one in order to allow amplification +by the first partial filter. +The causal processes should be more efficient +than 'parameterA' and 'parameterB' +because they use stack-based @alloca@ instead of @malloc@. +-} +parameterCausalA, parameterCausalB :: + (TypeNum.Natural n, Trans.C a, + Marshal.C a, MultiValue.RationalConstant a, MultiValue.Transcendental a) => + (TypeNum.Positive (n :*: LLVM.SizeOf (Marshal.Struct a)), + TypeNum.Positive (n :*: LLVM.UnknownSize)) => + Proxy n -> Passband -> + Causal.T (MultiValue.T a, MultiValue.T a) (Cascade.ParameterValue n a) +parameterCausalA n kind = + Causal.map + (\((psine, ps), (ratio, freq)) -> + fmap Cascade.ParameterValue $ + adjustAmplitude ratio =<< + parameter Chebyshev.partialParameterA n kind psine ps ratio freq) + $< + allocaArrays + +parameterCausalB n kind = + Causal.map + (\((psine, ps), (ratio, freq)) -> + fmap Cascade.ParameterValue $ + parameter Chebyshev.partialParameterB n kind psine ps ratio freq) + $< + allocaArrays + +allocaArrays :: + (LLVM.IsSized a, LLVM.IsSized b) => + Sig.T (LLVM.Value (LLVM.Ptr a), LLVM.Value (LLVM.Ptr b)) +allocaArrays = liftA2 (,) Sig.alloca Sig.alloca + +parameterA, parameterB :: + (TypeNum.Natural n, Trans.C a, + Marshal.C a, MultiValue.RationalConstant a, MultiValue.Transcendental a) => + (TypeNum.Positive (n :*: LLVM.SizeOf (Marshal.Struct a)), + TypeNum.Positive (n :*: LLVM.UnknownSize)) => + Proxy n -> Passband -> MultiValue.T a -> MultiValue.T a -> + LLVM.CodeGenFunction r (Cascade.ParameterValue n a) +parameterA n kind ratio freq = + withArrays $ \psine ps -> + fmap Cascade.ParameterValue $ + adjustAmplitude ratio =<< + parameter Chebyshev.partialParameterA n kind psine ps ratio freq + +parameterB n kind ratio freq = + withArrays $ \psine ps -> + fmap Cascade.ParameterValue $ + parameter Chebyshev.partialParameterB n kind psine ps ratio freq + +withArrays :: + (LLVM.IsSized a, LLVM.IsSized b) => + (LLVM.Value (LLVM.Ptr a) -> LLVM.Value (LLVM.Ptr b) -> + LLVM.CodeGenFunction r c) -> + LLVM.CodeGenFunction r c +withArrays act = do + psine <- LLVM.malloc + ps <- LLVM.malloc + x <- act psine ps + LLVM.free psine + LLVM.free ps + return x + + +-- | adjust amplification of the first filter +adjustAmplitude :: + (TypeNum.Natural n, Filt2.Parameter a ~ filt2, + Marshal.C a, MultiValue.IntegerConstant a, MultiValue.PseudoRing a) => + MultiValue.T a -> MultiValue.T (MultiValue.Array n filt2) -> + LLVM.CodeGenFunction r (MultiValue.T (MultiValue.Array n filt2)) +adjustAmplitude ratio (MultiValue.Cons pv) = do + filt0 <- Filt2.decomposeParameterMV =<< LLVM.extractvalue pv (0::Word) + fmap MultiValue.Cons $ + flip (LLVM.insertvalue pv) (0::Word) =<< + Filt2.composeParameterMV =<< + Expr.unliftM2 Filt2Core.amplify ratio filt0 + +parameter :: + (TypeNum.Positive (n :*: LLVM.SizeOf (Marshal.Struct a)), + TypeNum.Positive (n :*: LLVM.UnknownSize), + TypeNum.Natural n, Trans.C a, + Marshal.C a, MultiValue.RationalConstant a, MultiValue.Transcendental a, + Expr.Exp a ~ ae) => + (Passband -> Int -> ae -> Complex.T ae -> ae -> Filt2Core.Parameter ae) -> + Proxy n -> Passband -> + LLVM.Value (LLVM.Ptr (Marshal.Struct (MultiValue.Array n (Complex.T a)))) -> + LLVM.Value (LLVM.Ptr (Cascade.ParameterStruct n a)) -> + MultiValue.T a -> MultiValue.T a -> + LLVM.CodeGenFunction r (MultiValue.T (Cascade.Parameter n a)) +parameter partialParameter n kind psine ps ratio freq = do + let order = TypeNum.integralFromProxy n + let evalSines :: (Trans.C a) => mv a -> Int -> [Complex.T a] + evalSines _ = Chebyshev.makeCirclePoints + let sines = Cascade.constArray n $ evalSines freq order + Memory.store sines psine + s <- LLVM.getElementPtr0 psine (LLVM.valueOf (0::Word), ()) + p <- LLVM.getElementPtr0 ps (LLVM.valueOf (0::Word), ()) + let len = LLVM.valueOf (TypeNum.integralFromProxy n :: Word) + _ <- U.arrayLoop len p s $ \ptri si -> do + c <- Memory.load si + flip Memory.store ptri =<< + Filt2.composeParameterMV =<< + Expr.unliftM3 (partialParameter kind order) ratio c freq + A.advanceArrayElementPtr si + + Memory.load ps diff --git a/src/Synthesizer/LLVM/Filter/ComplexFirstOrder.hs b/src/Synthesizer/LLVM/Filter/ComplexFirstOrder.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Filter/ComplexFirstOrder.hs @@ -0,0 +1,194 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module Synthesizer.LLVM.Filter.ComplexFirstOrder ( + Parameter(Parameter), parameter, causal, + parameterCode, causalExp, + ) where + +import qualified Synthesizer.LLVM.Causal.Process as CausalExp +import qualified Synthesizer.LLVM.Causal.Private as Causal +import qualified Synthesizer.LLVM.Value as Value + +import qualified Synthesizer.LLVM.Frame.Stereo as Stereo +import qualified Synthesizer.LLVM.Complex as Complex + +import qualified LLVM.DSL.Expression as Expr + +import qualified LLVM.Extra.Arithmetic as A +import qualified LLVM.Extra.Memory as Memory +import qualified LLVM.Extra.Tuple as Tuple + +import qualified LLVM.Core as LLVM +import LLVM.Core (CodeGenFunction) + +import Type.Data.Num.Decimal (d0, d1, d2) + +import qualified Control.Applicative as App +import Control.Applicative (liftA2, liftA3, (<*>)) + +import qualified Data.Traversable as Trav +import qualified Data.Foldable as Fold + +import qualified Algebra.Transcendental as Trans +import qualified Algebra.Ring as Ring + +import NumericPrelude.Numeric +import NumericPrelude.Base + + +data Parameter a = + Parameter a (Complex.T a) + +instance Functor Parameter where + {-# INLINE fmap #-} + fmap f (Parameter k c) = + Parameter (f k) (fmap f c) + +instance App.Applicative Parameter where + {-# INLINE pure #-} + pure x = Parameter x (x Complex.+: x) + {-# INLINE (<*>) #-} + Parameter fk fc <*> Parameter pk pc = + Parameter (fk pk) $ + (Complex.real fc $ Complex.real pc) + Complex.+: + (Complex.imag fc $ Complex.imag pc) + +instance Fold.Foldable Parameter where + {-# INLINE foldMap #-} + foldMap = Trav.foldMapDefault + +instance Trav.Traversable Parameter where + {-# INLINE sequenceA #-} + sequenceA (Parameter k c) = + liftA2 Parameter k $ + liftA2 (Complex.+:) (Complex.real c) (Complex.imag c) + + +instance (Tuple.Phi a) => Tuple.Phi (Parameter a) where + phi = Tuple.phiTraversable + addPhi = Tuple.addPhiFoldable + +instance Tuple.Undefined a => Tuple.Undefined (Parameter a) where + undef = Tuple.undefPointed + + +type ParameterStruct a = LLVM.Struct (a, (a, (a, ()))) + +parameterMemory :: + (Memory.C a) => + Memory.Record r (ParameterStruct (Memory.Struct a)) (Parameter a) +parameterMemory = + liftA3 (\amp kr ki -> Parameter amp (kr Complex.+: ki)) + (Memory.element (\(Parameter amp _) -> amp) d0) + (Memory.element (\(Parameter _amp k) -> Complex.real k) d1) + (Memory.element (\(Parameter _amp k) -> Complex.imag k) d2) + +instance (Memory.C a) => Memory.C (Parameter a) where + type Struct (Parameter a) = ParameterStruct (Memory.Struct a) + load = Memory.loadRecord parameterMemory + store = Memory.storeRecord parameterMemory + decompose = Memory.decomposeRecord parameterMemory + compose = Memory.composeRecord parameterMemory + +instance (Value.Flatten a) => Value.Flatten (Parameter a) where + type Registers (Parameter a) = Parameter (Value.Registers a) + flattenCode = Value.flattenCodeTraversable + unfoldCode = Value.unfoldCodeTraversable + +instance + (Expr.Aggregate e mv) => + Expr.Aggregate (Parameter e) (Parameter mv) where + type MultiValuesOf (Parameter e) = Parameter (Expr.MultiValuesOf e) + type ExpressionsOf (Parameter mv) = Parameter (Expr.ExpressionsOf mv) + bundle = Trav.traverse Expr.bundle + dissect = fmap Expr.dissect + + +parameterCode, _parameterCode :: + (A.Transcendental a, A.RationalConstant a) => + a -> a -> CodeGenFunction r (Parameter a) +parameterCode reson freq = + let amp = recip $ Value.unfold reson + in Value.flatten $ Parameter amp $ + Complex.scale (1-amp) $ Complex.cis $ + Value.unfold freq * Value.tau + +_parameterCode reson freq = do + amp <- A.fdiv A.one reson + k <- A.sub A.one amp + w <- A.mul freq =<< Value.decons Value.tau + kr <- A.mul k =<< A.cos w + ki <- A.mul k =<< A.sin w + return (Parameter amp (kr Complex.+: ki)) + +parameter :: (Trans.C a) => a -> a -> Parameter a +parameter reson freq = + let amp = recip reson + in Parameter amp $ + Complex.scale (1-amp) $ Complex.cis $ freq * 2*pi + + +{- +Synthesizer.Plain.Filter.Recursive.FirstOrderComplex.step +cannot be used directly, because Filt1C has complex amplitude +-} +next, _next :: + (A.PseudoRing a, A.IntegerConstant a) => + (Parameter a, Stereo.T a) -> + Complex.T a -> + CodeGenFunction r (Stereo.T a, Complex.T a) +next inp state = + let stereoFromComplexVal :: Complex.T (Value.T a) -> Stereo.T (Value.T a) + stereoFromComplexVal = stereoFromComplex + (Parameter amp k, x) = Value.unfold inp + xc = Stereo.left x Complex.+: Stereo.right x + y = Complex.scale amp xc + k * Value.unfold state + in Value.flatten (stereoFromComplexVal y, y) + +_next (Parameter amp k, x) s = do + let kr = Complex.real k + ki = Complex.imag k + sr = Complex.real s + si = Complex.imag s + yr <- Value.decons $ + Value.lift0 (A.mul (Stereo.left x) amp) + + Value.lift0 (A.mul kr sr) - Value.lift0 (A.mul ki si) + yi <- Value.decons $ + Value.lift0 (A.mul (Stereo.right x) amp) + + Value.lift0 (A.mul kr si) + Value.lift0 (A.mul ki sr) + return (Stereo.cons yr yi, yr Complex.+: yi) + + +start :: + (A.Additive a) => + CodeGenFunction r (Complex.T a) +start = + return (A.zero Complex.+: A.zero) + +causal :: + (A.PseudoRing a, A.IntegerConstant a, Memory.C a) => + Causal.T + (Parameter a, Stereo.T a) + (Stereo.T a) +causal = + Causal.mapAccum next start + + +stereoFromComplex :: Complex.T a -> Stereo.T a +stereoFromComplex c = Stereo.cons (Complex.real c) (Complex.imag c) + +nextPlain :: + (Ring.C a) => + (Parameter a, Stereo.T a) -> Complex.T a -> (Stereo.T a, Complex.T a) +nextPlain (Parameter amp k, x) state = + let xc = Stereo.left x Complex.+: Stereo.right x + y = Complex.scale amp xc + k * state + in (stereoFromComplex y, y) + +causalExp :: + (Ring.C ae, Expr.Aggregate ae a, Memory.C a) => + CausalExp.T (Parameter a, Stereo.T a) (Stereo.T a) +causalExp = + CausalExp.mapAccum nextPlain zero diff --git a/src/Synthesizer/LLVM/Filter/ComplexFirstOrderPacked.hs b/src/Synthesizer/LLVM/Filter/ComplexFirstOrderPacked.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Filter/ComplexFirstOrderPacked.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE Rank2Types #-} +module Synthesizer.LLVM.Filter.ComplexFirstOrderPacked ( + Parameter(Parameter), parameterPlain, parameter, causal, + ParameterMV, + ) where + +import qualified Synthesizer.LLVM.Filter.ComplexFirstOrder as ComplexFilter + +import qualified Synthesizer.LLVM.Causal.Private as Causal + +import qualified Synthesizer.LLVM.Frame.Stereo as Stereo + +import qualified LLVM.DSL.Expression as Expr +import LLVM.DSL.Expression (Exp(Exp)) + +import qualified LLVM.Extra.Multi.Value.Marshal as Marshal +import qualified LLVM.Extra.Multi.Value as MultiValue +import qualified LLVM.Extra.Multi.Vector as MultiVector +import qualified LLVM.Extra.Arithmetic as A +import qualified LLVM.Extra.Memory as Memory +import qualified LLVM.Extra.Tuple as Tuple + +import qualified LLVM.Core as LLVM + +import Type.Data.Num.Decimal (D3, d0, d1) + +import Control.Applicative (liftA2) + +import qualified Algebra.Transcendental as Trans + +import qualified Number.Complex as Complex + +import NumericPrelude.Numeric +import NumericPrelude.Base + + +data Parameter a = Parameter (LLVM.Vector D3 a) (LLVM.Vector D3 a) + +data ParameterMV a = ParameterMV (MultiVector.T D3 a) (MultiVector.T D3 a) + +instance (MultiVector.C a) => Tuple.Phi (ParameterMV a) where + phi bb (ParameterMV r i) = do + r' <- Tuple.phi bb r + i' <- Tuple.phi bb i + return (ParameterMV r' i') + addPhi bb + (ParameterMV r i) + (ParameterMV r' i') = do + Tuple.addPhi bb r r' + Tuple.addPhi bb i i' + +instance (MultiVector.C a) => Tuple.Undefined (ParameterMV a) where + undef = ParameterMV Tuple.undef Tuple.undef + + +type ParameterStruct a = Marshal.Struct (LLVM.Vector D3 a, LLVM.Vector D3 a) + +parameterMemory :: + (Marshal.Vector D3 a) => + Memory.Record r (ParameterStruct a) (ParameterMV a) +parameterMemory = + liftA2 ParameterMV + (Memory.element (\(ParameterMV kr _) -> kr) d0) + (Memory.element (\(ParameterMV _ ki) -> ki) d1) + +instance (Marshal.Vector D3 a) => Memory.C (ParameterMV a) where + type Struct (ParameterMV a) = ParameterStruct a + load = Memory.loadRecord parameterMemory + store = Memory.storeRecord parameterMemory + decompose = Memory.decomposeRecord parameterMemory + compose = Memory.composeRecord parameterMemory + + +data ParameterExp a = + ParameterExp (forall r. LLVM.CodeGenFunction r (ParameterMV a)) + +instance Expr.Aggregate (ParameterExp a) (ParameterMV a) where + type MultiValuesOf (ParameterExp a) = ParameterMV a + type ExpressionsOf (ParameterMV a) = ParameterExp a + dissect x = ParameterExp (return x) + bundle (ParameterExp code) = code + + +parameterPlain :: (Trans.C a) => a -> a -> Parameter a +parameterPlain reson freq = + let (ComplexFilter.Parameter amp k) = ComplexFilter.parameter reson freq + kr = Complex.real k + ki = Complex.imag k + in Parameter + (LLVM.consVector kr (-ki) amp) + (LLVM.consVector ki kr amp) + +parameter :: + (MultiVector.Transcendental a, MultiVector.RationalConstant a) => + Exp a -> Exp a -> ParameterExp a +parameter (Exp reson) (Exp freq) = + ParameterExp (do + r <- reson + f <- freq + ~(ComplexFilter.Parameter amp k) <- ComplexFilter.parameterCode r f + let kr = Complex.real k + let ki = Complex.imag k + kin <- A.neg ki + liftA2 ParameterMV + (MultiVector.assembleFromVector $ LLVM.consVector kr kin amp) + (MultiVector.assembleFromVector $ LLVM.consVector ki kr amp)) + + +type State a = MultiVector.T D3 a + +next :: + (MultiVector.PseudoRing a) => + (ParameterMV a, Stereo.T (MultiValue.T a)) -> + State a -> LLVM.CodeGenFunction r (Stereo.T (MultiValue.T a), State a) +next (ParameterMV kr ki, x) s = do + let two = LLVM.valueOf 2 + sr <- MultiVector.insert two (Stereo.left x) s + yr <- MultiVector.dotProduct kr sr + + si <- MultiVector.insert two (Stereo.right x) s + yi <- MultiVector.dotProduct ki si + + sv <- MultiVector.assembleFromVector $ LLVM.consVector yr yi Tuple.undef + return (Stereo.cons yr yi, sv) + +causal :: + (Marshal.Vector n a, n ~ D3, MultiVector.PseudoRing a) => + Causal.T + (ParameterMV a, Stereo.T (MultiValue.T a)) + (Stereo.T (MultiValue.T a)) +causal = Causal.mapAccum next (return A.zero) diff --git a/src/Synthesizer/LLVM/Filter/FirstOrder.hs b/src/Synthesizer/LLVM/Filter/FirstOrder.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Filter/FirstOrder.hs @@ -0,0 +1,233 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Synthesizer.LLVM.Filter.FirstOrder ( + Result(Result,lowpass_,highpass_), Parameter, FirstOrder.parameter, + causal, lowpassCausal, highpassCausal, + causalInit, lowpassCausalInit, highpassCausalInit, + causalPacked, lowpassCausalPacked, highpassCausalPacked, + causalInitPacked, lowpassCausalInitPacked, highpassCausalInitPacked, + causalRecursivePacked, -- for Allpass + ) where + +import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as FirstOrder +import qualified Synthesizer.Plain.Modifier as Modifier +import Synthesizer.Plain.Filter.Recursive.FirstOrder + (Parameter(Parameter), Result(Result,lowpass_,highpass_)) + +import qualified Synthesizer.LLVM.Causal.Private as CausalPriv +import qualified Synthesizer.LLVM.Causal.Process as Causal +import qualified Synthesizer.LLVM.Frame.SerialVector.Class as SerialCode + +import qualified LLVM.DSL.Expression as Expr + +import qualified LLVM.Extra.Tuple as Tuple +import qualified LLVM.Extra.Memory as Memory +import qualified LLVM.Extra.Arithmetic as A + +import qualified LLVM.Core as LLVM + +import Control.Arrow (arr, (&&&), (<<<)) +import Control.Monad (foldM) +import Control.Applicative (liftA2) + +import qualified Algebra.Module as Module + +import NumericPrelude.Numeric +import NumericPrelude.Base + + +instance (Tuple.Phi a) => Tuple.Phi (Parameter a) where + phi = Tuple.phiTraversable + addPhi = Tuple.addPhiFoldable + +instance Tuple.Undefined a => Tuple.Undefined (Parameter a) where + undef = Tuple.undefPointed + +instance (Memory.C a) => Memory.C (Parameter a) where + type Struct (Parameter a) = Memory.Struct a + load = Memory.loadNewtype Parameter + store = Memory.storeNewtype (\(Parameter k) -> k) + decompose = Memory.decomposeNewtype Parameter + compose = Memory.composeNewtype (\(Parameter k) -> k) + + +instance + (Expr.Aggregate e mv) => + Expr.Aggregate (Parameter e) (Parameter mv) where + type MultiValuesOf (Parameter e) = Parameter (Expr.MultiValuesOf e) + type ExpressionsOf (Parameter mv) = Parameter (Expr.ExpressionsOf mv) + bundle (Parameter p) = fmap Parameter $ Expr.bundle p + dissect (Parameter p) = Parameter $ Expr.dissect p + + +instance (Expr.Aggregate e mv) => Expr.Aggregate (Result e) (Result mv) where + type MultiValuesOf (Result e) = Result (Expr.MultiValuesOf e) + type ExpressionsOf (Result mv) = Result (Expr.ExpressionsOf mv) + bundle (Result f k) = liftA2 Result (Expr.bundle f) (Expr.bundle k) + dissect (Result f k) = Result (Expr.dissect f) (Expr.dissect k) + +causal :: + (Expr.Aggregate ae a, Module.C ae ve, + Expr.Aggregate ve v, Memory.C v) => + Causal.T (Parameter a, v) (Result v) +causal = Causal.fromModifier FirstOrder.modifier + +lowpassCausal, highpassCausal :: + (Expr.Aggregate ae a, Module.C ae ve, + Expr.Aggregate ve v, Memory.C v) => + Causal.T (Parameter a, v) v +lowpassCausal = Causal.fromModifier FirstOrder.lowpassModifier +highpassCausal = Causal.fromModifier FirstOrder.highpassModifier + + +causalInit :: + (Expr.Aggregate ae a, Memory.C a, Module.C ae ve, + Expr.Aggregate ve v, Memory.C v) => + ve -> Causal.T (Parameter a, v) (Result v) +causalInit = + Causal.fromModifier . Modifier.initialize FirstOrder.modifierInit + +lowpassCausalInit, highpassCausalInit :: + (Expr.Aggregate ae a, Memory.C a, Module.C ae ve, + Expr.Aggregate ve v, Memory.C v) => + ve -> Causal.T (Parameter a, v) v +lowpassCausalInit = + Causal.fromModifier . Modifier.initialize FirstOrder.lowpassModifierInit +highpassCausalInit = + Causal.fromModifier . Modifier.initialize FirstOrder.highpassModifierInit + + +lowpassCausalPacked, highpassCausalPacked, causalRecursivePacked, + preampPacked :: + (SerialCode.Write v, SerialCode.Element v ~ a, + A.PseudoRing v, A.IntegerConstant v, + A.PseudoRing a, A.IntegerConstant a, Memory.C a) => + Causal.T (Parameter a, v) v +highpassCausalPacked = + CausalPriv.zipWith A.sub <<< arr snd &&& lowpassCausalPacked +lowpassCausalPacked = + causalRecursivePacked <<< arr fst &&& preampPacked + +causalRecursivePacked = + CausalPriv.mapAccum causalRecursivePackedStep (return A.zero) + +preampPacked = + CausalPriv.map + (\(Parameter k, x) -> A.mul x =<< SerialCode.upsample =<< A.sub A.one k) + + + +{- +x = [x0, x1, x2, x3] + +filter k y1 x + = [x0 + k*y1, + x1 + k*x0 + k^2*y1, + x2 + k*x1 + k^2*x0 + k^3*y1, + x3 + k*x2 + k^2*x1 + k^3*x0 + k^4*y1, + ... ] + +f0x = insert 0 (k*y1) x +f1x = f0x + k * f0x->1 +f2x = f1x + k^2 * f1x->2 +-} +causalRecursivePackedStep :: + (SerialCode.Write v, SerialCode.Element v ~ a, + A.PseudoRing v, A.IntegerConstant v, A.PseudoRing a) => + (Parameter a, v) -> a -> LLVM.CodeGenFunction r (v,a) +causalRecursivePackedStep (Parameter k, xk0) y1 = do + y1k <- A.mul k y1 + xk1 <- SerialCode.modify A.zero (A.add y1k) xk0 + kv <- SerialCode.upsample k + xk2 <- + fmap fst $ + foldM + (\(y,k0) d -> + liftA2 (,) + (A.add y =<< SerialCode.shiftUpMultiZero d =<< A.mul y k0) + (A.mul k0 k0)) + (xk1,kv) + (takeWhile (< SerialCode.size xk0) $ iterate (2*) 1) + y0 <- SerialCode.last xk2 + return (xk2, y0) + +{- +We can also optimize filtering with time-varying filter parameter. + +k = [k0, k1, k2, k3] +x = [x0, x1, x2, x3] + +filter k y1 x + = [x0 + k0*y1, + x1 + k1*x0 + k1*k0*y1, + x2 + k2*x1 + k2*k1*x0 + k2*k1*k0*y1, + x3 + k3*x2 + k3*k2*x1 + k3*k2*k1*x0 + k3*k2*k1*k0*y1, + ... ] + +f0x = insert 0 (k0*y1) x +f1x = f0x + k * f0x->1 k' = k * k->1 +f2x = f1x + k' * f1x->2 + + +We can even interpret vectorised first order filtering +as first order filtering with matrix coefficients. + +[x0 + k0*y1, + x1 + k1*x0 + k1*k0*y1, + x2 + k2*x1 + k2*k1*x0 + k2*k1*k0*y1, + x3 + k3*x2 + k3*k2*x1 + k3*k2*k1*x0 + k3*k2*k1*k0*y1] + = + / 1 \ /x0\ / k0 0 0 0 \ /y1\ + | k1 1 | . |x1| + | k1*k0 0 0 0 | . |y2| + | k2*k1 k2 1 | |x2| | k2*k1*k0 0 0 0 | |y3| + \ k3*k2*k1 k3*k2 k3 1 / \x3/ \ k3*k2*k1*k0 0 0 0 / \y4/ + + + / 1 \ / 1 \ / 1 \ + | k1 1 | = | 1 | . | k1 1 | + | k2*k1 k2 1 | | k2*k1 1 | | k2 1 | + \ k3*k2*k1 k3*k2 k3 1 / \ k3*k2 1 / \ k3 1 / +-} + + +addHighpass :: + (A.Additive v) => + Causal.T (param,v) v -> Causal.T (param,v) (Result v) +addHighpass lowpass = + CausalPriv.map + (\(l,x) -> do + h <- A.sub x l + return (Result{lowpass_ = l, highpass_ = h})) + <<< + lowpass &&& arr snd + +causalPacked :: + (SerialCode.Write v, SerialCode.Element v ~ a, + A.PseudoRing v, A.IntegerConstant v, + A.PseudoRing a, A.IntegerConstant a, Memory.C a) => + Causal.T (Parameter a, v) (Result v) +causalPacked = addHighpass lowpassCausalPacked + + +lowpassCausalInitPacked, highpassCausalInitPacked, + causalRecursiveInitPacked :: + (A.PseudoRing v, A.IntegerConstant v, + SerialCode.Write v, SerialCode.Element v ~ a, + Expr.Aggregate ae a, A.PseudoRing a, A.IntegerConstant a, Memory.C a) => + ae -> Causal.T (Parameter a, v) v +causalRecursiveInitPacked a = + CausalPriv.mapAccum causalRecursivePackedStep (Expr.bundle a) + +highpassCausalInitPacked a = arr snd - lowpassCausalInitPacked a +lowpassCausalInitPacked a = + causalRecursiveInitPacked a <<< arr fst &&& preampPacked + +causalInitPacked :: + (A.PseudoRing v, A.IntegerConstant v, + SerialCode.Write v, SerialCode.Element v ~ a, + Expr.Aggregate ae a, A.PseudoRing a, A.IntegerConstant a, Memory.C a) => + ae -> Causal.T (Parameter a, v) (Result v) +causalInitPacked a = addHighpass (lowpassCausalInitPacked a) diff --git a/src/Synthesizer/LLVM/Filter/Moog.hs b/src/Synthesizer/LLVM/Filter/Moog.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Filter/Moog.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveTraversable #-} +module Synthesizer.LLVM.Filter.Moog ( + Parameter, parameter, + causal, causalInit, + ) where + +import qualified Synthesizer.LLVM.Filter.FirstOrder as Filt1 () + +import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as FirstOrder +import qualified Synthesizer.Plain.Filter.Recursive.Moog as Moog +import Synthesizer.Plain.Filter.Recursive (Pole(..)) + +import qualified Synthesizer.LLVM.Causal.Process as Causal + +import qualified LLVM.DSL.Expression as Expr + +import qualified LLVM.Extra.Vector as Vector +import qualified LLVM.Extra.Memory as Memory +import qualified LLVM.Extra.Tuple as Tuple + +import qualified LLVM.Core as LLVM + +import qualified Type.Data.Num.Decimal as TypeNum +import Type.Data.Num.Decimal (d0, d1) +import Type.Base.Proxy (Proxy(Proxy)) + +import qualified Control.Arrow as Arrow +import qualified Control.Applicative as App +import qualified Data.Foldable as Fold +import qualified Data.Traversable as Trav +import Control.Arrow (arr, (>>>), (&&&)) +import Control.Applicative (liftA2) + +import qualified Algebra.Transcendental as Trans +import qualified Algebra.Module as Module +import NumericPrelude.Numeric +import NumericPrelude.Base + + +newtype Parameter n a = Parameter {getParam :: Moog.Parameter a} + deriving (Functor, App.Applicative, Fold.Foldable, Trav.Traversable) + + +instance (Tuple.Phi a, TypeNum.Natural n) => + Tuple.Phi (Parameter n a) where + phi = Tuple.phiTraversable + addPhi = Tuple.addPhiFoldable + +instance (Tuple.Undefined a, TypeNum.Natural n) => + Tuple.Undefined (Parameter n a) where + undef = Tuple.undefPointed + +instance (Tuple.Zero a, TypeNum.Natural n) => + Tuple.Zero (Parameter n a) where + zero = Tuple.zeroPointed + + +type ParameterStruct a = + LLVM.Struct (Memory.Struct a, (Memory.Struct (FirstOrder.Parameter a), ())) + +parameterMemory :: + (Memory.C a, TypeNum.Natural n) => + Memory.Record r (ParameterStruct a) (Parameter n a) +parameterMemory = + liftA2 (\f k -> Parameter (Moog.Parameter f k)) + (Memory.element (Moog.feedback . getParam) d0) + (Memory.element (Moog.lowpassParam . getParam) d1) + +instance + (Memory.C a, TypeNum.Natural n) => + Memory.C (Parameter n a) where + type Struct (Parameter n a) = ParameterStruct a + load = Memory.loadRecord parameterMemory + store = Memory.storeRecord parameterMemory + decompose = Memory.decomposeRecord parameterMemory + compose = Memory.composeRecord parameterMemory + + +instance + (Vector.Simple v, TypeNum.Natural n) => + Vector.Simple (Parameter n v) where + type Element (Parameter n v) = Parameter n (Vector.Element v) + type Size (Parameter n v) = Vector.Size v + shuffleMatch = Vector.shuffleMatchTraversable + extract = Vector.extractTraversable + +instance (Vector.C v, TypeNum.Natural n) => Vector.C (Parameter n v) where + insert = Vector.insertTraversable + + +parameter :: + (TypeNum.Natural n, Trans.C a) => + Proxy n -> a -> a -> Parameter n a +parameter order reson freq = + Parameter $ + Moog.parameter (TypeNum.integralFromProxy order) (Pole reson freq) + +instance + (n ~ m, Expr.Aggregate e mv) => + Expr.Aggregate (Parameter n e) (Parameter m mv) where + type MultiValuesOf (Parameter n e) = Parameter n (Expr.MultiValuesOf e) + type ExpressionsOf (Parameter m mv) = Parameter m (Expr.ExpressionsOf mv) + bundle (Parameter (Moog.Parameter f k)) = + fmap Parameter $ liftA2 Moog.Parameter (Expr.bundle f) (Expr.bundle k) + dissect (Parameter (Moog.Parameter f k)) = + Parameter (Moog.Parameter (Expr.dissect f) (Expr.dissect k)) + + +merge :: + (Module.C a v) => (Parameter n a, v) -> v -> (FirstOrder.Parameter a, v) +merge (Parameter (Moog.Parameter f k), x) y0 = (k, x - f *> y0) + +amplify :: (Module.C a v) => Parameter n a -> v -> v +amplify p y1 = (1 + Moog.feedback (getParam p)) *> y1 + +causal :: + (TypeNum.Natural n, Memory.C v, + Module.C ae ve, Expr.Aggregate ae a, Expr.Aggregate ve v) => + Causal.T (Parameter n a, v) v +causal = + causalSize + (flip (Causal.feedbackControlled zero) (arr snd)) + Proxy + + +causalInit :: + (TypeNum.Natural n, Memory.C v, + Module.C ae ve, Expr.Aggregate ae a, Expr.Aggregate ve v) => + ve -> Causal.T (Parameter n a, v) v +causalInit initial = + causalSize + (flip + (Causal.feedbackControlled initial) + (arr snd)) + Proxy + + +causalSize :: + (TypeNum.Natural n, Memory.C v, + Module.C ae ve, Expr.Aggregate ae a, Expr.Aggregate ve v) => + (Causal.T ((Parameter n a, v), v) v -> + Causal.T (Parameter n a, v) v) -> + Proxy n -> + Causal.T (Parameter n a, v) v +causalSize feedback n = + let order = TypeNum.integralFromProxy n + in Arrow.arr fst &&& + feedback + (Causal.zipWith merge >>> + Causal.replicateControlled order + (Causal.fromModifier FirstOrder.lowpassModifier)) + >>> Causal.zipWith amplify diff --git a/src/Synthesizer/LLVM/Filter/NonRecursive.hs b/src/Synthesizer/LLVM/Filter/NonRecursive.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Filter/NonRecursive.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +module Synthesizer.LLVM.Filter.NonRecursive ( + convolve, + convolvePacked, + ) where + +import qualified Synthesizer.LLVM.Causal.Process as Causal +import qualified Synthesizer.LLVM.Causal.Private as CausalPriv +import qualified Synthesizer.LLVM.Generator.Source as Source +import qualified Synthesizer.LLVM.Generator.Signal as Sig +import qualified Synthesizer.LLVM.RingBuffer as RingBuffer +import qualified Synthesizer.LLVM.Frame.SerialVector.Code as Serial + +import qualified Synthesizer.Causal.Class as CausalClass +import Synthesizer.Causal.Class (($<)) + +import qualified LLVM.DSL.Expression as Expr +import LLVM.DSL.Expression (Exp) + +import qualified LLVM.Extra.Multi.Value.Storable as Storable +import qualified LLVM.Extra.Multi.Value.Marshal as Marshal +import qualified LLVM.Extra.Multi.Value as MultiValue +import qualified LLVM.Extra.Multi.Vector as MultiVector +import qualified LLVM.Extra.Control as C +import qualified LLVM.Extra.Arithmetic as A +import qualified LLVM.Extra.Tuple as Tuple + +import qualified LLVM.Core as LLVM + +import qualified Type.Data.Num.Decimal as TypeNum + +import Foreign.Ptr (Ptr) +import Data.Word (Word) + +import Control.Arrow ((<<<), (&&&)) +import Control.Monad (liftM2) + +import NumericPrelude.Numeric +import NumericPrelude.Base +import Prelude () + + +{- +This is a brute-force implementation. +No Karatsuba, No Toom-Cook, No Fourier. +-} +convolve :: + (Storable.C a, Marshal.C a, MultiValue.PseudoRing a, MultiValue.T a ~ am) => + Exp (Source.StorableVector a) -> Causal.T am am +convolve mask = + let len = Source.storableVectorLength mask + in (CausalPriv.zipWith (\(MultiValue.Cons l) -> scalarProduct l) + $< Sig.constant len) + <<< + Causal.track Expr.zero len &&& provideMask mask + +convolvePacked :: + (Marshal.Vector n a, MultiVector.PseudoRing a) => + (Storable.C a, MultiValue.PseudoRing a, Serial.Value n a ~ v) => + Exp (Source.StorableVector a) -> Causal.T v v +convolvePacked = convolvePackedAux TypeNum.singleton + +convolvePackedAux :: + (Marshal.Vector n a, MultiVector.PseudoRing a) => + (Storable.C a, MultiValue.PseudoRing a, Serial.Value n a ~ v) => + TypeNum.Singleton n -> Exp (Source.StorableVector a) -> Causal.T v v +convolvePackedAux vectorSize mask = + let len = Source.storableVectorLength mask + in (CausalPriv.zipWith (\(MultiValue.Cons l) -> scalarProductPacked l) + $< Sig.constant len) + <<< + Causal.track Expr.zero + (divUp (TypeNum.integralFromSingleton vectorSize) len) + &&& + provideMask mask + +divUp :: Exp Word -> Exp Word -> Exp Word +divUp k n = Expr.idiv (n+(k-1)) k + +provideMask :: + (Storable.C a) => + Exp (Source.StorableVector a) -> Causal.T x (LLVM.Value (Ptr a)) +provideMask mask = + CausalClass.fromSignal $ + fmap (\(MultiValue.Cons (ptr,_l)) -> ptr) $ + Sig.constant mask + + +scalarProduct :: + (Storable.C a, Marshal.C a, MultiValue.T a ~ am, MultiValue.PseudoRing a) => + LLVM.Value Word -> + (RingBuffer.T am, LLVM.Value (Ptr a)) -> + LLVM.CodeGenFunction r am +scalarProduct n (rb,mask) = + fmap snd $ + Storable.arrayLoop n mask (A.zero, A.zero) $ \ptr (k, s) -> do + a <- RingBuffer.index k rb + b <- Storable.load ptr + liftM2 (,) (A.inc k) (A.add s =<< A.mul a b) + + +scalarProductPacked :: + (Storable.C a, Marshal.Vector n a, MultiVector.PseudoRing a) => + LLVM.Value Word -> + (RingBuffer.T (Serial.Value n a), LLVM.Value (Ptr a)) -> + LLVM.CodeGenFunction r (Serial.Value n a) +scalarProductPacked n0 (rb,mask0) = do + (ax, rx) <- readSerialStart rb + bx <- Storable.load mask0 + sx <- Serial.scale bx ax + n1 <- A.dec n0 + mask1 <- Storable.incrementPtr mask0 + fmap snd $ Storable.arrayLoop n1 mask1 (rx, sx) $ \ptr (r1, s1) -> do + (a,r2) <- readSerialNext rb r1 + b <- Storable.load ptr + fmap ((,) r2) (A.add s1 =<< Serial.scale b a) + + +type + Iterator n a = + ((Serial.Value n a, + {- + I would like to use Serial.Iterator, + but we need to read in reversed order, + that is, from high to low indices. + -} + Serial.Value n a, + LLVM.Value Word), + LLVM.Value Word) + +readSerialStart :: + (TypeNum.Positive n, Marshal.Vector n a) => + RingBuffer.T (Serial.Value n a) -> + LLVM.CodeGenFunction r (Serial.Value n a, Iterator n a) +readSerialStart rb = do + a <- RingBuffer.index A.zero rb + return (a, ((a, Tuple.undef, A.zero), A.zero)) + +readSerialNext :: + (MultiValue.C a, Marshal.Vector n a) => + RingBuffer.T (Serial.Value n a) -> + Iterator n a -> + LLVM.CodeGenFunction r (Serial.Value n a, Iterator n a) +readSerialNext rb ((a0,r0,j0), k0) = do + vectorEnd <- A.cmp LLVM.CmpEQ j0 A.zero + ((r1,j1), k1) <- + C.ifThen vectorEnd ((r0,j0), k0) $ do + k <- A.inc k0 + r <- RingBuffer.index k rb + return ((r, LLVM.valueOf (Serial.size r :: Word)), k) + j2 <- A.dec j1 + (ai,r2) <- Serial.shiftUp Tuple.undef r1 + (_, a1) <- Serial.shiftUp ai a0 + return (a1, ((a1,r2,j2), k1)) diff --git a/src/Synthesizer/LLVM/Filter/SecondOrder.hs b/src/Synthesizer/LLVM/Filter/SecondOrder.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Filter/SecondOrder.hs @@ -0,0 +1,444 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Synthesizer.LLVM.Filter.SecondOrder ( + Parameter(Parameter), + Filt2.c0, Filt2.c1, Filt2.c2, Filt2.d1, Filt2.d2, + bandpassParameter, + bandpassParameterCode, + ParameterStruct, composeParameter, decomposeParameter, -- for cascade + composeParameterMV, decomposeParameterMV, + causalExp, + causal, causalPacked, + ) where + +import qualified Synthesizer.Plain.Filter.Recursive.SecondOrder as Filt2 +import Synthesizer.Plain.Filter.Recursive.SecondOrder (Parameter(Parameter)) + +import qualified Synthesizer.Plain.Modifier as Modifier + +import qualified Synthesizer.LLVM.Causal.Process as CausalExp +import qualified Synthesizer.LLVM.Causal.ProcessValue as Causal +import qualified Synthesizer.LLVM.Frame.SerialVector.Class as Serial +import qualified Synthesizer.LLVM.Value as Value + +import qualified LLVM.DSL.Expression as Expr + +import qualified LLVM.Extra.Multi.Value.Marshal as MarshalMV +import qualified LLVM.Extra.Multi.Value as MultiValue +import qualified LLVM.Extra.Storable as Storable +import qualified LLVM.Extra.Marshal as Marshal +import qualified LLVM.Extra.Memory as Memory +import qualified LLVM.Extra.Tuple as Tuple +import qualified LLVM.Extra.Arithmetic as A + +import qualified LLVM.Core as LLVM +import LLVM.Core (CodeGenFunction, valueOf) + +import qualified Type.Data.Num.Decimal as TypeNum +import Type.Data.Num.Decimal (d0, d1, d2, d3, d4) + +import qualified Control.Monad.HT as M +import qualified Control.Applicative.HT as App +import Control.Arrow (arr, (<<<), (&&&)) +import Control.Monad (liftM2, foldM) +import Control.Applicative (pure, liftA2, (<$>), (<*>)) + +import qualified Data.Foldable as Fold +import Data.Traversable (traverse) + +import qualified Algebra.Transcendental as Trans +import qualified Algebra.Module as Module + +import NumericPrelude.Numeric +import NumericPrelude.Base + + +instance (Tuple.Phi a) => Tuple.Phi (Parameter a) where + phi = Tuple.phiTraversable + addPhi = Tuple.addPhiFoldable + +instance Tuple.Undefined a => Tuple.Undefined (Parameter a) where + undef = Tuple.undefPointed + +instance (Tuple.Value a) => Tuple.Value (Parameter a) where + type ValueOf (Parameter a) = Parameter (Tuple.ValueOf a) + valueOf = Tuple.valueOfFunctor + + +type ParameterStruct a = LLVM.Struct (a, (a, (a, (a, (a, ()))))) + +parameterMemory :: + (Memory.C a) => + Memory.Record r (ParameterStruct (Memory.Struct a)) (Parameter a) +parameterMemory = + App.lift5 Parameter + (Memory.element Filt2.c0 d0) + (Memory.element Filt2.c1 d1) + (Memory.element Filt2.c2 d2) + (Memory.element Filt2.d1 d3) + (Memory.element Filt2.d2 d4) + +decomposeParameter :: + LLVM.Value (ParameterStruct a) -> + CodeGenFunction r (Filt2.Parameter (LLVM.Value a)) +decomposeParameter param = + pure Filt2.Parameter + <*> LLVM.extractvalue param TypeNum.d0 + <*> LLVM.extractvalue param TypeNum.d1 + <*> LLVM.extractvalue param TypeNum.d2 + <*> LLVM.extractvalue param TypeNum.d3 + <*> LLVM.extractvalue param TypeNum.d4 + +decomposeParameterMV :: + (MarshalMV.C a) => + LLVM.Value (MarshalMV.Struct (Parameter a)) -> + CodeGenFunction r (Filt2.Parameter (MultiValue.T a)) +decomposeParameterMV param = + pure Filt2.Parameter + <*> (Memory.decompose =<< LLVM.extractvalue param TypeNum.d0) + <*> (Memory.decompose =<< LLVM.extractvalue param TypeNum.d1) + <*> (Memory.decompose =<< LLVM.extractvalue param TypeNum.d2) + <*> (Memory.decompose =<< LLVM.extractvalue param TypeNum.d3) + <*> (Memory.decompose =<< LLVM.extractvalue param TypeNum.d4) + +composeParameter :: + (LLVM.IsSized a) => + Filt2.Parameter (LLVM.Value a) -> + CodeGenFunction r (LLVM.Value (ParameterStruct a)) +composeParameter (Filt2.Parameter c0_ c1_ c2_ d1_ d2_) = + (\param -> LLVM.insertvalue param c0_ TypeNum.d0) =<< + (\param -> LLVM.insertvalue param c1_ TypeNum.d1) =<< + (\param -> LLVM.insertvalue param c2_ TypeNum.d2) =<< + (\param -> LLVM.insertvalue param d1_ TypeNum.d3) =<< + (\param -> LLVM.insertvalue param d2_ TypeNum.d4) =<< + return (LLVM.value LLVM.undef) + +composeParameterMV :: + (MarshalMV.C a) => + Filt2.Parameter (MultiValue.T a) -> + CodeGenFunction r (LLVM.Value (MarshalMV.Struct (Parameter a))) +composeParameterMV (Filt2.Parameter c0_ c1_ c2_ d1_ d2_) = + let insert field ix param = + Memory.compose field >>= flip (LLVM.insertvalue param) ix in + insert c0_ TypeNum.d0 =<< + insert c1_ TypeNum.d1 =<< + insert c2_ TypeNum.d2 =<< + insert d1_ TypeNum.d3 =<< + insert d2_ TypeNum.d4 =<< + return (LLVM.value LLVM.undef) + +instance (Memory.C a) => Memory.C (Parameter a) where + type Struct (Parameter a) = ParameterStruct (Memory.Struct a) + load = Memory.loadRecord parameterMemory + store = Memory.storeRecord parameterMemory + decompose = Memory.decomposeRecord parameterMemory + compose = Memory.composeRecord parameterMemory + +instance (Marshal.C a) => Marshal.C (Parameter a) where + pack p = + case Marshal.pack <$> p of + Filt2.Parameter c0_ c1_ c2_ d1_ d2_ -> + LLVM.consStruct c0_ c1_ c2_ d1_ d2_ + unpack = fmap Marshal.unpack . LLVM.uncurryStruct Filt2.Parameter + +instance (Storable.C a) => Storable.C (Parameter a) where + load = Storable.loadApplicative + store = Storable.storeFoldable + + +instance (Value.Flatten a) => Value.Flatten (Parameter a) where + type Registers (Parameter a) = Parameter (Value.Registers a) + flattenCode = Value.flattenCodeTraversable + unfoldCode = Value.unfoldCodeTraversable + +instance (MultiValue.C a) => MultiValue.C (Parameter a) where + type Repr (Parameter a) = Parameter (MultiValue.Repr a) + cons = parameterMultiValue . fmap MultiValue.cons + undef = parameterMultiValue $ pure MultiValue.undef + zero = parameterMultiValue $ pure MultiValue.zero + phi bb = + fmap parameterMultiValue . + traverse (MultiValue.phi bb) . + parameterUnMultiValue + addPhi bb a b = + Fold.sequence_ $ + liftA2 (MultiValue.addPhi bb) + (parameterUnMultiValue a) (parameterUnMultiValue b) + +instance (MarshalMV.C a) => MarshalMV.C (Parameter a) where + pack p = + case MarshalMV.pack <$> p of + Filt2.Parameter c0_ c1_ c2_ d1_ d2_ -> + LLVM.consStruct c0_ c1_ c2_ d1_ d2_ + unpack = fmap MarshalMV.unpack . LLVM.uncurryStruct Filt2.Parameter + +parameterMultiValue :: + Parameter (MultiValue.T a) -> MultiValue.T (Parameter a) +parameterMultiValue = + MultiValue.Cons . fmap (\(MultiValue.Cons a) -> a) + +parameterUnMultiValue :: + MultiValue.T (Parameter a) -> Parameter (MultiValue.T a) +parameterUnMultiValue (MultiValue.Cons x) = + fmap MultiValue.Cons x + +instance + (Expr.Aggregate e mv) => + Expr.Aggregate (Parameter e) (Parameter mv) where + type MultiValuesOf (Parameter e) = Parameter (Expr.MultiValuesOf e) + type ExpressionsOf (Parameter mv) = Parameter (Expr.ExpressionsOf mv) + bundle = traverse Expr.bundle + dissect = fmap Expr.dissect + + + +instance (Tuple.Phi a) => Tuple.Phi (Filt2.State a) where + phi = Tuple.phiTraversable + addPhi = Tuple.addPhiFoldable + +instance Tuple.Undefined a => Tuple.Undefined (Filt2.State a) where + undef = Tuple.undefPointed + + +type StateStruct a = LLVM.Struct (a, (a, (a, (a, (a, ()))))) + +stateMemory :: + (Memory.C a) => + Memory.Record r (StateStruct (Memory.Struct a)) (Filt2.State a) +stateMemory = + App.lift4 Filt2.State + (Memory.element Filt2.u1 d0) + (Memory.element Filt2.u2 d1) + (Memory.element Filt2.y1 d2) + (Memory.element Filt2.y2 d3) + + +instance (Memory.C a) => Memory.C (Filt2.State a) where + type Struct (Filt2.State a) = StateStruct (Memory.Struct a) + load = Memory.loadRecord stateMemory + store = Memory.storeRecord stateMemory + decompose = Memory.decomposeRecord stateMemory + compose = Memory.composeRecord stateMemory + +instance (Value.Flatten a) => Value.Flatten (Filt2.State a) where + type Registers (Filt2.State a) = Filt2.State (Value.Registers a) + flattenCode = Value.flattenCodeTraversable + unfoldCode = Value.unfoldCodeTraversable + +instance + (Expr.Aggregate e mv) => + Expr.Aggregate (Filt2.State e) (Filt2.State mv) where + type MultiValuesOf (Filt2.State e) = Filt2.State (Expr.MultiValuesOf e) + type ExpressionsOf (Filt2.State mv) = Filt2.State (Expr.ExpressionsOf mv) + bundle = traverse Expr.bundle + dissect = fmap Expr.dissect + + +{-# DEPRECATED bandpassParameter "only for testing, use Universal or Moog filter for production code" #-} +bandpassParameterCode :: + (A.Transcendental a, A.RationalConstant a) => + a -> a -> + CodeGenFunction r (Parameter a) +bandpassParameterCode reson cutoff = do + rreson <- A.fdiv A.one reson + k <- A.sub A.one rreson + k2 <- A.neg =<< A.mul k k + kcos <- + A.mul (A.fromInteger' 2) =<< A.mul k =<< + A.cos =<< A.mul cutoff =<< + Value.decons Value.tau + return $ Filt2.Parameter rreson A.zero A.zero kcos k2 + +-- ToDo: move to synthesizer-core:Filter.SecondOrder (it is not the universal filter) +bandpassParameter :: (Trans.C a) => a -> a -> Parameter a +bandpassParameter reson cutoff = + let rreson = recip reson + k = one - rreson + in Filt2.Parameter rreson zero zero (2*k*cos(2*pi*cutoff)) (-k*k) + +modifier :: + (a ~ A.Scalar v, A.PseudoModule v, A.IntegerConstant a) => + Modifier.Simple + (Filt2.State (Value.T v)) + (Parameter (Value.T a)) + (Value.T v) (Value.T v) +modifier = + Filt2.modifier + +causal :: + (a ~ A.Scalar v, A.PseudoModule v, A.IntegerConstant a, Memory.C v) => + Causal.T (Parameter a, v) v +causal = + Causal.fromModifier modifier + +causalExp :: + (Expr.Aggregate ae a, Memory.C a, Module.C ae ve, + Expr.Aggregate ve v, Memory.C v) => + CausalExp.T (Parameter a, v) v +causalExp = + CausalExp.fromModifier Filt2.modifier + + +{- | +Vector size must be at least D2. +-} +causalPacked, + causalRecursivePacked :: + (Serial.Write v, Serial.Element v ~ a, + Memory.C v, Memory.C a, A.IntegerConstant v, A.IntegerConstant a, + A.PseudoRing v, A.PseudoRing a) => + Causal.T (Parameter a, v) v +causalPacked = + causalRecursivePacked <<< + (arr fst &&& causalNonRecursivePacked) + +_causalRecursivePackedAlt, + causalNonRecursivePacked :: + (Serial.Write v, Serial.Element v ~ a, + Memory.C a, A.IntegerConstant v, A.IntegerConstant a, + A.PseudoRing v, A.PseudoRing a) => + Causal.T (Parameter a, v) v +causalNonRecursivePacked = + Causal.mapAccum + (\(p, v0) (x1,x2) -> do + (u1n,v1) <- Serial.shiftUp x1 v0 + (u2n,v2) <- Serial.shiftUp x2 v1 + w0 <- A.mul v0 =<< Serial.upsample (Filt2.c0 p) + w1 <- A.mul v1 =<< Serial.upsample (Filt2.c1 p) + w2 <- A.mul v2 =<< Serial.upsample (Filt2.c2 p) + y <- A.add w0 =<< A.add w1 w2 + return (y, (u1n,u2n))) + (return (A.zero, A.zero)) + +{- +A filter of second order can be considered +as the convolution of two filters of first order. + +[1,r]*[1,0,r^2] = [1,r,r^2,r^3] +[1,r,r^2,r^3] * [1,s,s^2,s^3] + = [1,r]*[1,s]*[1,0,r^2]*[1,0,s^2] + with + a=r+s + b=r*s + = [1,a,b]*[1,0,r^2]*[1,0,s^2] + = [1,a,b]*[1,0,a^2-2*b,0,b^2] + +[1,0,0,0,r^4]*[1,0,0,0,s^4] + = [1,0,0,0,(a^2-2*b)^2-2*b^2,0,0,0,b^4] + = [1,0,0,0,a^4-4*a^2*b+2*b^2,0,0,0,b^4] +-} + +{- +x = [x0, x1, x2, x3] + +filter2 (a,-b) (y1,y2) x + = [x0 + a*y1 - b*y2, + x1 + a*x0 + (a^2-b)*y1 - a*b*y2, + x2 + a*x1 + (a^2-b)*x0 + (a^3-2*a*b)*y1 + (-a^2*b+b^2)*y2, + x3 + a*x2 + (a^2-b)*x1 + (a^3-2*a*b)*x0 + (a^4-3*a^2*b+b^2)*y1 + (-a^3*b+2*a*b^2)*y2] + +(f0x = insert 0 (k*y1) x) +f1x = f0x + a * f0x->1 + b * f0x->2 +f2x = f1x + (a^2-2*b) * f1x->2 + b^2 * f1x->4 +-} +causalRecursivePacked = + Causal.mapAccum + (\(p, x0) y1v -> do + let size = Serial.size x0 + + d1v <- Serial.upsample (Filt2.d1 p) + d2v <- Serial.upsample (Filt2.d2 p) + d2vn <- A.neg d2v + + y1 <- Serial.last y1v + xk1 <- + Serial.modify (valueOf 0) + (\u0 -> A.add u0 =<< A.mul (Filt2.d1 p) y1) =<< + A.add x0 =<< A.mul d2v =<< + Serial.shiftDownMultiZero (size - 2) y1v + + -- let xk2 = xk1 + xk2 <- + fmap fst $ + foldM + (\(y,(a,b)) d -> + liftM2 (,) + (A.add y =<< + M.liftJoin2 A.add + {- + Possibility for optimization: + In the last step the second operand is a zero vector + (LLVM already optimizes this away) + and the first operand could be merged + with the second operand of the previous step. + -} + (Serial.shiftUpMultiZero d =<< A.mul y a) + (Serial.shiftUpMultiZero (2*d) =<< A.mul y b)) $ + liftM2 (,) + (M.liftJoin2 A.sub + (A.mul a a) + (A.mul b (A.fromInteger' 2))) + (A.mul b b)) + (xk1,(d1v,d2vn)) + (takeWhile (< size) $ iterate (2*) 1) + + return (xk2, xk2)) + (return A.zero) + +_causalRecursivePackedAlt = + Causal.mapAccum + (\(p, x0) (x1,x2) -> do + let size = Serial.size x0 + -- let xk1 = x0 + xk1 <- + Serial.modify (valueOf 0) + (\u0 -> + A.add u0 =<< + M.liftJoin2 A.add (A.mul (Filt2.d2 p) x2) (A.mul (Filt2.d1 p) x1)) =<< + Serial.modify (valueOf 1) + (\u1 -> A.add u1 =<< A.mul (Filt2.d2 p) x1) + x0 + + -- let xk2 = xk1 + d1v <- Serial.upsample (Filt2.d1 p) + d2v <- Serial.upsample =<< A.neg (Filt2.d2 p) + xk2 <- + fmap fst $ + foldM + (\(y,(a,b)) d -> + liftM2 (,) + (A.add y =<< + M.liftJoin2 A.add + (Serial.shiftUpMultiZero d =<< A.mul y a) + (Serial.shiftUpMultiZero (2*d) =<< A.mul y b)) $ + liftM2 (,) + (M.liftJoin2 A.sub + (A.mul a a) + (A.mul b (A.fromInteger' 2))) + (A.mul b b)) + (xk1,(d1v,d2v)) + (takeWhile (< size) $ iterate (2*) 1) + + y0 <- Serial.extract (valueOf $ fromIntegral size - 1) xk2 + y1 <- Serial.extract (valueOf $ fromIntegral size - 2) xk2 + return (xk2, (y0,y1))) + (return (A.zero, A.zero)) + +{- +A filter of second order can also be represented +by a filter of first order with 2x2-matrix coefficients. + +filter1 ((d1,d2), (1,0)) (y1,y2) [(x0,0), (x1,0), (x2,0), (x3,0)] + +/d1i d2i\ . /d1j d2j\ = /d1i*d1j + d2i d1i*d2j\ +\ 1 0 / \ 1 0 / \ d1j d2j/ + + +With this representation we can also implement filters +with time-variant filter parameters +using time-variant first-order filter. +-} diff --git a/src/Synthesizer/LLVM/Filter/SecondOrderCascade.hs b/src/Synthesizer/LLVM/Filter/SecondOrderCascade.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Filter/SecondOrderCascade.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +module Synthesizer.LLVM.Filter.SecondOrderCascade ( + causal, causalPacked, + Parameter, + ParameterValue(..), + ParameterStruct, + fixSize, constArray, + ) where + +import qualified Synthesizer.LLVM.Filter.SecondOrder as Filt2 + +import qualified Synthesizer.LLVM.Causal.Functional as Func +import qualified Synthesizer.LLVM.Causal.Private as Causal +import qualified Synthesizer.LLVM.Generator.Private as Sig + +import qualified Synthesizer.LLVM.Frame.SerialVector.Class as Serial +import Synthesizer.Causal.Class (($<)) + +import qualified LLVM.Extra.Multi.Value.Marshal as Marshal +import qualified LLVM.Extra.Multi.Value as MultiValue +import qualified LLVM.Extra.Arithmetic as A +import qualified LLVM.Extra.Tuple as Tuple +import qualified LLVM.Extra.Memory as Memory + +import qualified LLVM.Core as LLVM + +import qualified Type.Data.Num.Decimal as TypeNum +import Type.Data.Num.Decimal.Number ((:*:)) +import Type.Base.Proxy (Proxy) + +import Data.Word (Word) + +import Control.Arrow ((<<<), (^<<), (&&&), arr) + +import NumericPrelude.Base + + +type Parameter n a = MultiValue.Array n (Filt2.Parameter a) +type ParameterStruct n a = Marshal.Struct (Parameter n a) + +newtype ParameterValue n a = + ParameterValue {parameterValue :: MultiValue.T (Parameter n a)} +{- +Automatic deriving is not allowed even with GeneralizedNewtypeDeriving +because of IsSized constraint +and it would also be wrong for Functor and friends. + deriving + (Tuple.Phi, Tuple.Undefined, Tuple.Zero, + Functor, App.Applicative, Fold.Foldable, Trav.Traversable) +-} + +instance (TypeNum.Natural n, Marshal.C a) => + Tuple.Phi (ParameterValue n a) where + phi bb (ParameterValue r) = fmap ParameterValue $ MultiValue.phi bb r + addPhi bb (ParameterValue r) (ParameterValue r') = MultiValue.addPhi bb r r' + +instance (TypeNum.Natural n, Marshal.C a) => + Tuple.Undefined (ParameterValue n a) where + undef = ParameterValue MultiValue.undef + +instance (TypeNum.Natural n, Marshal.C a) => + Tuple.Zero (ParameterValue n a) where + zero = ParameterValue MultiValue.zero + +instance (TypeNum.Natural n, Marshal.C a, + TypeNum.Positive (n :*: LLVM.UnknownSize)) => + Memory.C (ParameterValue n a) where + type Struct (ParameterValue n a) = ParameterStruct n a + load = Memory.loadNewtype ParameterValue + store = Memory.storeNewtype (\(ParameterValue k) -> k) + decompose = Memory.decomposeNewtype ParameterValue + compose = Memory.composeNewtype (\(ParameterValue k) -> k) + +type instance Func.Arguments f (ParameterValue n a) = f (ParameterValue n a) +instance Func.MakeArguments (ParameterValue n a) where + makeArgs = id + + +withSize :: + (TypeNum.Natural n) => + (TypeNum.Singleton n -> process (ParameterValue n a, x) y) -> + process (ParameterValue n a, x) y +withSize f = f TypeNum.singleton + +fixSize :: + Proxy n -> + process (ParameterValue n a, x) y -> + process (ParameterValue n a, x) y +fixSize _n = id + +constArray :: + (TypeNum.Natural n, Marshal.C a) => + Proxy n -> [a] -> MultiValue.T (MultiValue.Array n a) +constArray _n = MultiValue.cons . MultiValue.Array + + +causal :: + (A.PseudoModule v, Memory.C v, A.Scalar v ~ MultiValue.T a, + Marshal.C a, MultiValue.IntegerConstant a, + TypeNum.Natural n, TypeNum.Positive (n :*: LLVM.UnknownSize)) => + Causal.T (ParameterValue n a, v) v +causal = causalGen Filt2.causal + +causalPacked :: + (Marshal.C a, MultiValue.PseudoRing a, MultiValue.IntegerConstant a, + Serial.Write v, Serial.Element v ~ MultiValue.T a, + Memory.C v, A.PseudoRing v, A.IntegerConstant v, + TypeNum.Natural n, TypeNum.Positive (n :*: LLVM.UnknownSize)) => + Causal.T (ParameterValue n a, v) v +causalPacked = causalGen Filt2.causalPacked + +causalGen :: + (Marshal.C a, Tuple.Phi v, Tuple.Undefined v, + TypeNum.Natural n, TypeNum.Positive (n :*: LLVM.UnknownSize)) => + Causal.T (Filt2.Parameter (MultiValue.T a), v) v -> + Causal.T (ParameterValue n a, v) v +causalGen stage = + withSize $ \n -> + snd + ^<< + Causal.replicateControlled + (TypeNum.integralFromSingleton n) + (paramStage stage) + <<< + Causal.map + (\(ptr, (p,v)) -> do + Memory.store (parameterValue p) ptr + return (ptr, (A.zero, v))) + $< + Sig.alloca + +paramStage :: + (TypeNum.Natural n, Marshal.C a) => + Causal.T (Filt2.Parameter (MultiValue.T a), v) v -> + Causal.T + (LLVM.Value (LLVM.Ptr (ParameterStruct n a)), (LLVM.Value Word, v)) + (LLVM.Value Word, v) +paramStage stage = + let p = arr fst + i = arr (fst.snd) + v = arr (snd.snd) + in (Causal.map A.inc <<< i) + &&& + (stage <<< + (Causal.zipWith getStageParameterGEP <<< p &&& i) + &&& + v) + +getStageParameterGEP :: + (TypeNum.Natural n, Marshal.C a) => + LLVM.Value (LLVM.Ptr (ParameterStruct n a)) -> + LLVM.Value Word -> + LLVM.CodeGenFunction r (Filt2.Parameter (MultiValue.T a)) +getStageParameterGEP ptr k = + Filt2.decomposeParameterMV + =<< LLVM.load + =<< LLVM.getElementPtr0 ptr (k, ()) diff --git a/src/Synthesizer/LLVM/Filter/SecondOrderPacked.hs b/src/Synthesizer/LLVM/Filter/SecondOrderPacked.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Filter/SecondOrderPacked.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +module Synthesizer.LLVM.Filter.SecondOrderPacked ( + Parameter, ParameterExp, bandpassParameter, State, causal, + ) where + +import qualified Synthesizer.LLVM.Filter.SecondOrder as Filt2L +import qualified Synthesizer.Plain.Filter.Recursive.SecondOrder as Filt2 + +import qualified Synthesizer.LLVM.Causal.Private as Causal + +import qualified LLVM.DSL.Expression as Expr +import LLVM.DSL.Expression (Exp(Exp)) + +import qualified LLVM.Extra.Multi.Value.Marshal as Marshal +import qualified LLVM.Extra.Multi.Value as MultiValue +import qualified LLVM.Extra.Multi.Vector as MultiVector +import qualified LLVM.Extra.Tuple as Tuple +import qualified LLVM.Extra.Memory as Memory +import qualified LLVM.Extra.Arithmetic as A + +import qualified LLVM.Core as LLVM + +import Type.Data.Num.Decimal (D4, d0, d1) + +import Control.Applicative (liftA2) + +import NumericPrelude.Numeric +import NumericPrelude.Base + + +{- | +Layout: + +> c0 [c1 d1 c2 d2] +-} +data Parameter a = Parameter (MultiValue.T a) (MultiVector.T D4 a) + +instance (MultiVector.C a) => Tuple.Phi (Parameter a) where + phi bb (Parameter r i) = do + r' <- Tuple.phi bb r + i' <- Tuple.phi bb i + return (Parameter r' i') + addPhi bb (Parameter r i) (Parameter r' i') = do + Tuple.addPhi bb r r' + Tuple.addPhi bb i i' + +instance (MultiVector.C a) => Tuple.Undefined (Parameter a) where + undef = Parameter Tuple.undef Tuple.undef + + +type ParameterStruct a = Memory.Struct (MultiValue.T a, MultiVector.T D4 a) + +parameterMemory :: + (Marshal.C a, Marshal.Vector D4 a) => + Memory.Record r (ParameterStruct a) (Parameter a) +parameterMemory = + liftA2 Parameter + (Memory.element (\(Parameter c0 _) -> c0) d0) + (Memory.element (\(Parameter _ cd) -> cd) d1) + +instance (Marshal.C a, Marshal.Vector D4 a) => Memory.C (Parameter a) where + type Struct (Parameter a) = ParameterStruct a + load = Memory.loadRecord parameterMemory + store = Memory.storeRecord parameterMemory + decompose = Memory.decomposeRecord parameterMemory + compose = Memory.composeRecord parameterMemory + + +data ParameterExp a = + ParameterExp (forall r. LLVM.CodeGenFunction r (Parameter a)) + +instance Expr.Aggregate (ParameterExp a) (Parameter a) where + type MultiValuesOf (ParameterExp a) = Parameter a + type ExpressionsOf (Parameter a) = ParameterExp a + dissect x = ParameterExp (return x) + bundle (ParameterExp code) = code + + +type State = MultiVector.T D4 + + +{-# DEPRECATED bandpassParameter "only for testing, use Universal or Moog filter for production code" #-} +bandpassParameter :: + (MultiVector.C a, MultiValue.Transcendental a, + MultiValue.RationalConstant a) => + Exp a -> Exp a -> ParameterExp a +bandpassParameter (Exp reson) (Exp cutoff) = + ParameterExp (do + r <- reson + c <- cutoff + bandpassParameterCode r c) + +bandpassParameterCode :: + (MultiVector.C a, MultiValue.Transcendental a, + MultiValue.RationalConstant a) => + MultiValue.T a -> + MultiValue.T a -> + LLVM.CodeGenFunction r (Parameter a) +bandpassParameterCode reson cutoff = do + p <- Filt2L.bandpassParameterCode reson cutoff + v <- + MultiVector.assembleFromVector $ fmap ($ p) $ + LLVM.consVector Filt2.c1 Filt2.d1 Filt2.c2 Filt2.d2 + return $ Parameter (Filt2.c0 p) v + + +next :: + (MultiVector.PseudoRing a) => + (Parameter a, MultiValue.T a) -> + State a -> + LLVM.CodeGenFunction r (MultiValue.T a, State a) +next (Parameter c0 k1, x0) y1 = do + s0 <- A.mul c0 x0 + s1 <- MultiVector.dotProduct k1 y1 + y0 <- A.add s0 s1 + x1new <- MultiVector.extract (LLVM.valueOf 0) y1 + y1new <- MultiVector.extract (LLVM.valueOf 1) y1 + yv <- MultiVector.assembleFromVector $ LLVM.consVector x0 y0 x1new y1new + return (y0, yv) + +causal :: + (MultiVector.PseudoRing a) => + (Marshal.Vector D4 a) => + Causal.T (Parameter a, MultiValue.T a) (MultiValue.T a) +causal = Causal.mapAccum next (return A.zero) diff --git a/src/Synthesizer/LLVM/Filter/Universal.hs b/src/Synthesizer/LLVM/Filter/Universal.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Filter/Universal.hs @@ -0,0 +1,288 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Synthesizer.LLVM.Filter.Universal ( + Result(Result, lowpass, highpass, bandpass, bandlimit), + Parameter, parameter, causal, + parameterCode, causalExp, + multiValueResult, unMultiValueResult, + multiValueParameter, unMultiValueParameter, + ) where + +import qualified Synthesizer.Plain.Filter.Recursive.Universal as Universal +import Synthesizer.Plain.Filter.Recursive.Universal + (Parameter(Parameter), Result(..)) +import Synthesizer.Plain.Filter.Recursive (Pole(..)) + +import qualified Synthesizer.Plain.Modifier as Modifier + +import qualified Synthesizer.LLVM.Causal.Process as CausalExp +import qualified Synthesizer.LLVM.Causal.ProcessValue as Causal +import qualified Synthesizer.LLVM.Frame.SerialVector.Class as Serial +import qualified Synthesizer.LLVM.Value as Value + +import qualified LLVM.DSL.Expression as Expr + +import qualified LLVM.Extra.Multi.Value.Marshal as MarshalMV +import qualified LLVM.Extra.Multi.Value as MultiValue +import qualified LLVM.Extra.Storable as Storable +import qualified LLVM.Extra.Marshal as Marshal +import qualified LLVM.Extra.Memory as Memory +import qualified LLVM.Extra.Tuple as Tuple +import qualified LLVM.Extra.Vector as Vector +import qualified LLVM.Extra.Arithmetic as A + +import qualified LLVM.Core as LLVM +import LLVM.Core (CodeGenFunction) + +import Type.Data.Num.Decimal (d0, d1, d2, d3, d4, d5) + +import qualified Control.Applicative.HT as App +import Control.Applicative (liftA2, (<$>)) + +import qualified Data.Foldable as Fold +import Data.Traversable (traverse) + +import qualified Algebra.Transcendental as Trans +import qualified Algebra.Module as Module + + +instance (Tuple.Phi a) => Tuple.Phi (Parameter a) where + phi = Tuple.phiTraversable + addPhi = Tuple.addPhiFoldable + +instance Tuple.Undefined a => Tuple.Undefined (Parameter a) where + undef = Tuple.undefPointed + + +type ParameterStruct a = LLVM.Struct (a, (a, (a, (a, (a, (a, ())))))) + +parameterMemory :: + (Memory.C a) => + Memory.Record r (ParameterStruct (Memory.Struct a)) (Parameter a) +parameterMemory = + App.lift6 Parameter + (Memory.element Universal.k1 d0) + (Memory.element Universal.k2 d1) + (Memory.element Universal.ampIn d2) + (Memory.element Universal.ampI1 d3) + (Memory.element Universal.ampI2 d4) + (Memory.element Universal.ampLimit d5) + + +instance (Memory.C a) => Memory.C (Parameter a) where + type Struct (Parameter a) = ParameterStruct (Memory.Struct a) + load = Memory.loadRecord parameterMemory + store = Memory.storeRecord parameterMemory + decompose = Memory.decomposeRecord parameterMemory + compose = Memory.composeRecord parameterMemory + +instance (Marshal.C a) => Marshal.C (Parameter a) where + pack p = + case Marshal.pack <$> p of + Parameter k1 k2 ampIn ampI1 ampI2 ampLimit -> + LLVM.consStruct k1 k2 ampIn ampI1 ampI2 ampLimit + unpack = fmap Marshal.unpack . LLVM.uncurryStruct Parameter + +instance (Storable.C a) => Storable.C (Parameter a) where + load = Storable.loadApplicative + store = Storable.storeFoldable + + + +type ResultStruct a = LLVM.Struct (a, (a, (a, (a, ())))) + +resultMemory :: + (Memory.C a) => + Memory.Record r (ResultStruct (Memory.Struct a)) (Result a) +resultMemory = + App.lift4 Result + (Memory.element Universal.highpass d0) + (Memory.element Universal.bandpass d1) + (Memory.element Universal.lowpass d2) + (Memory.element Universal.bandlimit d3) + + +instance (Memory.C a) => Memory.C (Result a) where + type Struct (Result a) = ResultStruct (Memory.Struct a) + load = Memory.loadRecord resultMemory + store = Memory.storeRecord resultMemory + decompose = Memory.decomposeRecord resultMemory + compose = Memory.composeRecord resultMemory + +instance (Tuple.Value a) => Tuple.Value (Result a) where + type ValueOf (Result a) = Result (Tuple.ValueOf a) + valueOf = Tuple.valueOfFunctor + +instance (Value.Flatten a) => Value.Flatten (Result a) where + type Registers (Result a) = Result (Value.Registers a) + flattenCode = Value.flattenCodeTraversable + unfoldCode = Value.unfoldCodeTraversable + +instance (MultiValue.C a) => MultiValue.C (Result a) where + type Repr (Result a) = Result (MultiValue.Repr a) + cons = multiValueResult . fmap MultiValue.cons + undef = multiValueResult $ pure MultiValue.undef + zero = multiValueResult $ pure MultiValue.zero + phi bb = + fmap multiValueResult . + traverse (MultiValue.phi bb) . unMultiValueResult + addPhi bb a b = + Fold.sequence_ $ + liftA2 (MultiValue.addPhi bb) + (unMultiValueResult a) (unMultiValueResult b) + +multiValueResult :: + Result (MultiValue.T a) -> MultiValue.T (Result a) +multiValueResult = MultiValue.Cons . fmap (\(MultiValue.Cons a) -> a) + +unMultiValueResult :: + MultiValue.T (Result a) -> Result (MultiValue.T a) +unMultiValueResult (MultiValue.Cons x) = fmap MultiValue.Cons x + +instance (MarshalMV.C a) => MarshalMV.C (Result a) where + pack p = + case MarshalMV.pack <$> p of + Result hp bp lp bl -> LLVM.consStruct hp bp lp bl + unpack = fmap MarshalMV.unpack . LLVM.uncurryStruct Result + +instance (Expr.Aggregate e mv) => Expr.Aggregate (Result e) (Result mv) where + type MultiValuesOf (Result e) = Result (Expr.MultiValuesOf e) + type ExpressionsOf (Result mv) = Result (Expr.ExpressionsOf mv) + bundle = traverse Expr.bundle + dissect = fmap Expr.dissect + + +instance (Tuple.Value a) => Tuple.Value (Parameter a) where + type ValueOf (Parameter a) = Parameter (Tuple.ValueOf a) + valueOf = Tuple.valueOfFunctor + +instance (Value.Flatten a) => Value.Flatten (Parameter a) where + type Registers (Parameter a) = Parameter (Value.Registers a) + flattenCode = Value.flattenCodeTraversable + unfoldCode = Value.unfoldCodeTraversable + +instance (MultiValue.C a) => MultiValue.C (Parameter a) where + type Repr (Parameter a) = Parameter (MultiValue.Repr a) + cons = multiValueParameter . fmap MultiValue.cons + undef = multiValueParameter $ pure MultiValue.undef + zero = multiValueParameter $ pure MultiValue.zero + phi bb = + fmap multiValueParameter . + traverse (MultiValue.phi bb) . unMultiValueParameter + addPhi bb a b = + Fold.sequence_ $ + liftA2 (MultiValue.addPhi bb) + (unMultiValueParameter a) (unMultiValueParameter b) + +multiValueParameter :: + Parameter (MultiValue.T a) -> MultiValue.T (Parameter a) +multiValueParameter = MultiValue.Cons . fmap (\(MultiValue.Cons a) -> a) + +unMultiValueParameter :: + MultiValue.T (Parameter a) -> Parameter (MultiValue.T a) +unMultiValueParameter (MultiValue.Cons x) = fmap MultiValue.Cons x + +instance (MarshalMV.C a) => MarshalMV.C (Parameter a) where + pack p = + case MarshalMV.pack <$> p of + Parameter k1 k2 ampIn ampI1 ampI2 ampLimit -> + LLVM.consStruct k1 k2 ampIn ampI1 ampI2 ampLimit + unpack = fmap MarshalMV.unpack . LLVM.uncurryStruct Parameter + +instance + (Expr.Aggregate e mv) => + Expr.Aggregate (Parameter e) (Parameter mv) where + type MultiValuesOf (Parameter e) = Parameter (Expr.MultiValuesOf e) + type ExpressionsOf (Parameter mv) = Parameter (Expr.ExpressionsOf mv) + bundle = traverse Expr.bundle + dissect = fmap Expr.dissect + + +instance (Vector.Simple v) => Vector.Simple (Parameter v) where + type Element (Parameter v) = Parameter (Vector.Element v) + type Size (Parameter v) = Vector.Size v + shuffleMatch = Vector.shuffleMatchTraversable + extract = Vector.extractTraversable + +instance (Vector.C v) => Vector.C (Parameter v) where + insert = Vector.insertTraversable + + +instance (Tuple.Phi a) => Tuple.Phi (Result a) where + phi = Tuple.phiTraversable + addPhi = Tuple.addPhiFoldable + +instance Tuple.Undefined a => Tuple.Undefined (Result a) where + undef = Tuple.undefPointed + +instance (Vector.Simple v) => Vector.Simple (Result v) where + type Element (Result v) = Result (Vector.Element v) + type Size (Result v) = Vector.Size v + shuffleMatch = Vector.shuffleMatchTraversable + extract = Vector.extractTraversable + +instance (Vector.C v) => Vector.C (Result v) where + insert = Vector.insertTraversable + +instance (Serial.Sized v) => Serial.Sized (Result v) where + type Size (Result v) = Serial.Size v + +instance (Serial.Read v) => Serial.Read (Result v) where + type Element (Result v) = Result (Serial.Element v) + type ReadIt (Result v) = Result (Serial.ReadIt v) + extract = Serial.extractTraversable + readStart = Serial.readStartTraversable + readNext = Serial.readNextTraversable + +instance (Serial.Write v) => Serial.Write (Result v) where + type WriteIt (Result v) = Result (Serial.WriteIt v) + insert = Serial.insertTraversable + writeStart = Serial.writeStartTraversable + writeNext = Serial.writeNextTraversable + writeStop = Serial.writeStopTraversable + + +parameterCode :: + (A.Transcendental a, A.RationalConstant a) => + a -> a -> CodeGenFunction r (Parameter a) +parameterCode = + Value.unlift2 $ \reson freq -> + Universal.parameter (Pole reson freq) + +parameter :: (Trans.C a) => a -> a -> Parameter a +parameter reson freq = Universal.parameter (Pole reson freq) + + +modifier :: + (a ~ A.Scalar v, A.PseudoModule v, A.IntegerConstant a) => + Modifier.Simple + (Universal.State (Value.T v)) + (Parameter (Value.T a)) + (Value.T v) (Result (Value.T v)) +modifier = + Universal.modifier + +causal :: + (a ~ A.Scalar v, A.PseudoModule v, A.IntegerConstant a, Memory.C v) => + Causal.T (Parameter a, v) (Result v) +causal = Causal.fromModifier modifier + +causalExp :: + (Module.C ae ve, Expr.Aggregate ae a, Expr.Aggregate ve v, Memory.C v) => + CausalExp.T (Parameter a, v) (Result v) +causalExp = CausalExp.fromModifier Universal.modifier + +{- +The state variable filter could be vectorised +by writing the integrator network as matrix recursion +and applying the doubling trick to that recursion. +However the initially sparse matrix with several 1s in it +has dense power matrices with no nice structure. +This will only payoff for large vectors. + +We could write another version, +that expresses the state variable filter in terms of the general second order filter. +The general second order filter is already vectorized. +-} diff --git a/src/Synthesizer/LLVM/Fold.hs b/src/Synthesizer/LLVM/Fold.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Fold.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE Rank2Types #-} +module Synthesizer.LLVM.Fold where + +import qualified LLVM.Extra.Arithmetic as A +import LLVM.Core (CodeGenFunction) + +import Control.Applicative (liftA2, liftA3) + +import Prelude hiding (sum) + + +data T a b = Cons (forall r. b -> a -> CodeGenFunction r b) b + +premap :: (forall r. a -> CodeGenFunction r b) -> T b c -> T a c +premap f (Cons acc b0) = Cons (\b a -> acc b =<< f a) b0 + + +maxZero :: (A.Real a) => T a a +maxZero = Cons A.max A.zero + +maxAbs :: (A.Real a) => T a a +maxAbs = premap A.abs maxZero + +sum :: (A.Additive a) => T a a +sum = Cons A.add A.zero + +sumSquare :: (A.PseudoRing a) => T a a +sumSquare = premap A.square sum + + +pair :: T a0 b0 -> T a1 b1 -> T (a0,a1) (b0,b1) +pair (Cons acc0 b00) (Cons acc1 b10) = + Cons (\(a0,a1) (b0,b1) -> liftA2 (,) (acc0 a0 b0) (acc1 a1 b1)) (b00,b10) + +triple :: T a0 b0 -> T a1 b1 -> T a2 b2 -> T (a0,a1,a2) (b0,b1,b2) +triple (Cons acc0 b00) (Cons acc1 b10) (Cons acc2 b20) = + Cons + (\(a0,a1,a2) (b0,b1,b2) -> + liftA3 (,,) (acc0 a0 b0) (acc1 a1 b1) (acc2 a2 b2)) + (b00,b10,b20) diff --git a/src/Synthesizer/LLVM/ForeignPtr.hs b/src/Synthesizer/LLVM/ForeignPtr.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/ForeignPtr.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{- | +Adding the finalizer to a ForeignPtr seems to be the only way +that warrants execution of the finalizer (not too early and not never). +However, the normal ForeignPtr finalizers must be independent from Haskell runtime. +In contrast to ForeignPtr finalizers, +addFinalizer adds finalizers to boxes, that are optimized away. +Thus finalizers are run too early or not at all. +Concurrent.ForeignPtr and using threaded execution +is the only way to get finalizers in Haskell IO. +-} +module Synthesizer.LLVM.ForeignPtr where + +import qualified LLVM.DSL.Execution as Exec +import qualified LLVM.Extra.Multi.Value.Marshal as MarshalMV +import qualified LLVM.Extra.Marshal as Marshal +import qualified LLVM.ExecutionEngine as EE +import qualified LLVM.Core as LLVM + +import qualified Foreign.ForeignPtr as FPtr +import qualified Foreign.Concurrent as FC +import Foreign.ForeignPtr (ForeignPtr, withForeignPtr) +import Foreign.StablePtr (newStablePtr, freeStablePtr) +import Foreign.Ptr (nullPtr) + + +newAux :: IO () -> IO (ForeignPtr ()) +newAux = FC.newForeignPtr nullPtr + + +makeFinalizer :: (EE.ExecutionEngine, IO ()) -> IO (IO ()) +makeFinalizer (ee, finalizer) = do + stable <- newStablePtr ee + return $ finalizer >> freeStablePtr stable + +type MemoryPtr struct = ForeignPtr (EE.Stored struct) + +newInit :: Exec.Finalizer a -> IO (LLVM.Ptr a) -> IO (MemoryPtr a) +newInit (ee, stop) start = do + state <- start + FC.newForeignPtr (EE.castToStoredPtr state) + =<< makeFinalizer (ee, stop state) + +newParam :: + (Marshal.C b) => + Exec.Finalizer a -> + (LLVM.Ptr (Marshal.Struct b) -> IO (LLVM.Ptr a)) -> + b -> IO (MemoryPtr a) +newParam stop start b = + newInit stop (Marshal.with b start) + +newParamMV :: + (MarshalMV.C b) => + Exec.Finalizer a -> + (LLVM.Ptr (MarshalMV.Struct b) -> IO (LLVM.Ptr a)) -> + b -> IO (MemoryPtr a) +newParamMV stop start b = + newInit stop (MarshalMV.with b start) + +new :: + (Marshal.C a, Marshal.Struct a ~ struct) => + IO () -> a -> IO (MemoryPtr struct) +new finalizer a = do + ptr <- FPtr.mallocForeignPtr + FC.addForeignPtrFinalizer ptr finalizer + with ptr $ flip Marshal.poke a + return ptr + + +with :: MemoryPtr struct -> (LLVM.Ptr struct -> IO a) -> IO a +with fptr act = withForeignPtr fptr $ act . EE.castFromStoredPtr diff --git a/src/Synthesizer/LLVM/Frame.hs b/src/Synthesizer/LLVM/Frame.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Frame.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +module Synthesizer.LLVM.Frame where + +import qualified Synthesizer.LLVM.Frame.Stereo as Stereo + +import qualified LLVM.Extra.Vector as Vector +import qualified LLVM.Extra.Arithmetic as A + +import qualified LLVM.Core as LLVM +import LLVM.Core + (CodeGenFunction, Value, Vector, + IsPrimitive, IsArithmetic) + +import qualified Type.Data.Num.Decimal as TypeNum +import Type.Data.Num.Decimal (D2, D4) + +import qualified Data.Traversable as Trav +import qualified Data.Foldable as Fold + +import NumericPrelude.Numeric hiding (zero, one, div, signum) +import NumericPrelude.Base + + +{- | +Copy mono signal to both stereo channels. +-} +stereoFromMono :: + a -> CodeGenFunction r (Stereo.T a) +stereoFromMono x = + return $ Stereo.cons x x + +mixMonoFromStereo :: + (A.Additive a) => + Stereo.T a -> CodeGenFunction r a +mixMonoFromStereo s = + mix (Stereo.left s) (Stereo.right s) + + +stereoFromVector :: + (IsPrimitive a) => + Value (Vector D2 a) -> + CodeGenFunction r (Stereo.T (Value a)) +stereoFromVector x = + Trav.mapM (LLVM.extractelement x . LLVM.valueOf) $ Stereo.cons 0 1 + +vectorFromStereo :: + (IsPrimitive a) => + Stereo.T (Value a) -> + CodeGenFunction r (Value (Vector D2 a)) +vectorFromStereo = + Vector.assemble . Fold.toList + + +quadroFromVector :: + (IsPrimitive a) => + Value (Vector D4 a) -> + CodeGenFunction r (Stereo.T (Stereo.T (Value a))) +quadroFromVector x = + Trav.mapM (Trav.mapM (LLVM.extractelement x . LLVM.valueOf)) $ + Stereo.cons (Stereo.cons 0 1) (Stereo.cons 2 3) + +vectorFromQuadro :: + (IsPrimitive a) => + Stereo.T (Stereo.T (Value a)) -> + CodeGenFunction r (Value (Vector D4 a)) +vectorFromQuadro = + Vector.assemble . + concatMap Fold.toList . Fold.toList + + +mix :: + (A.Additive a) => + a -> a -> CodeGenFunction r a +mix = A.add + + +{- | +This may mean more shuffling and is not necessarily better than mixStereo. +-} +mixStereoV :: + (IsArithmetic a, IsPrimitive a) => + Stereo.T (Value a) -> Stereo.T (Value a) -> + CodeGenFunction r (Stereo.T (Value a)) +mixStereoV x y = + do xv <- vectorFromStereo x + yv <- vectorFromStereo y + stereoFromVector =<< A.add xv yv + +mixVector :: + (Vector.Arithmetic a, TypeNum.Positive n) => + Value (Vector n a) -> + CodeGenFunction r (Value a) +mixVector = Vector.sum + +mixVectorToStereo :: + (Vector.Arithmetic a, TypeNum.Positive n) => + Value (Vector n a) -> + CodeGenFunction r (Stereo.T (Value a)) +mixVectorToStereo = + fmap (uncurry Stereo.cons) . + Vector.sumInterleavedToPair + +{- | +Mix components with even index to the left channel +and components with odd index to the right channel. +-} +mixInterleavedVectorToStereo :: + (Vector.Arithmetic a, TypeNum.Positive n) => + Value (Vector n a) -> + CodeGenFunction r (Stereo.T (Value a)) +mixInterleavedVectorToStereo = + fmap (uncurry Stereo.cons) . + Vector.sumInterleavedToPair + + +amplifyMono :: + (A.PseudoRing a) => + a -> a -> CodeGenFunction r a +amplifyMono = A.mul + +amplifyStereo :: + (A.PseudoRing a) => + a -> Stereo.T a -> CodeGenFunction r (Stereo.T a) +amplifyStereo x = + Trav.mapM (A.mul x) diff --git a/src/Synthesizer/LLVM/Frame/Binary.hs b/src/Synthesizer/LLVM/Frame/Binary.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Frame/Binary.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +module Synthesizer.LLVM.Frame.Binary ( + toCanonical, + ) where + +import qualified LLVM.Extra.Arithmetic as A +import qualified LLVM.Extra.ScalarOrVector as SoV +import qualified LLVM.Core as LLVM + +import qualified Algebra.ToInteger as ToInteger +import NumericPrelude.Numeric +import NumericPrelude.Base + +import Prelude () + + + +toCanonical :: + (LLVM.ShapeOf real ~ LLVM.ShapeOf int, + LLVM.IsFloating real, SoV.IntegerConstant real, + LLVM.IsInteger int, Bounded int, ToInteger.C int) => + LLVM.Value int -> LLVM.CodeGenFunction r (LLVM.Value real) +toCanonical i = do + numer <- LLVM.inttofp i + A.fdiv numer (A.fromInteger' (toInteger (maxBoundOf i))) + +maxBoundOf :: (Bounded i) => LLVM.Value i -> i +maxBoundOf _ = maxBound diff --git a/src/Synthesizer/LLVM/Frame/SerialVector.hs b/src/Synthesizer/LLVM/Frame/SerialVector.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Frame/SerialVector.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{- | +A special vector type that represents a time-sequence of samples. +This way we can distinguish safely between LLVM vectors +used for parallel signals and pipelines and +those used for chunky processing of scalar signals. +For the chunky processing this data type allows us +to derive the factor from the type +that time constants have to be multiplied with. +-} +module Synthesizer.LLVM.Frame.SerialVector ( + T(Cons), + fromFixedList, + upsample, subsample, + shiftUp, + reverse, iterate, cumulate, + limit, + select, cmp, + ) where + +import qualified Synthesizer.LLVM.Frame.SerialVector.Code as Code +import Synthesizer.LLVM.Frame.SerialVector.Code + (T, fromMultiVector, toMultiVector) + +import qualified LLVM.DSL.Expression.Vector as ExprVec +import qualified LLVM.DSL.Expression as Expr +import LLVM.DSL.Expression (Exp) + +import qualified LLVM.Extra.Multi.Vector as MultiVector +import qualified LLVM.Extra.Multi.Value.Vector as MultiValueVec +import qualified LLVM.Extra.Multi.Value as MultiValue +import qualified LLVM.Extra.Arithmetic as A + +import qualified LLVM.Core as LLVM + +import qualified Type.Data.Num.Decimal as TypeNum + +import Data.Word (Word32) + +import Prelude hiding (replicate, reverse, iterate) + + +fromFixedList :: + (TypeNum.Positive n, MultiVector.C a) => + LLVM.FixedList (TypeNum.ToUnary n) a -> Exp (T n a) +fromFixedList = fromOrdinary . Expr.cons . LLVM.vector + + + +subsample :: (TypeNum.Positive n, MultiVector.C a) => Exp (T n a) -> Exp a +subsample = + Expr.liftM (MultiValueVec.extract (A.zero :: LLVM.Value Word32)) . toOrdinary + +upsample :: (TypeNum.Positive n, MultiVector.C a) => Exp a -> Exp (T n a) +upsample = fromOrdinary . ExprVec.replicate + + +shiftUp :: + (TypeNum.Positive n, MultiVector.C x, Exp x ~ a, Exp (T n x) ~ v) => + a -> v -> (a, v) +shiftUp a v = + (Expr.liftM2 ((fmap fst .) . Code.shiftUp) a v, + Expr.liftM2 ((fmap snd .) . Code.shiftUp) a v) + + +iterate :: + (TypeNum.Positive n, MultiVector.C a) => + (Exp a -> Exp a) -> Exp a -> Exp (T n a) +iterate f = fromOrdinary . ExprVec.iterate f + +reverse :: + (TypeNum.Positive n, MultiVector.C a) => + Exp (T n a) -> Exp (T n a) +reverse = + Expr.liftM (fmap fromMultiVector . MultiVector.reverse . toMultiVector) + + +cumulate :: + (TypeNum.Positive n, MultiVector.Additive a) => + Exp a -> Exp (T n a) -> (Exp a, Exp (T n a)) +cumulate a v = + (Expr.liftM2 ((fmap fst .) . Code.cumulate) a v, + Expr.liftM2 ((fmap snd .) . Code.cumulate) a v) + +limit :: + (TypeNum.Positive n, MultiVector.Real a) => + (Exp (T n a), Exp (T n a)) -> Exp (T n a) -> Exp (T n a) +limit (l,u) = + fromOrdinary . ExprVec.limit (toOrdinary l, toOrdinary u) . toOrdinary + + +cmp :: + (TypeNum.Positive n, MultiVector.Comparison a) => + LLVM.CmpPredicate -> Exp (T n a) -> Exp (T n a) -> Exp (T n Bool) +cmp ord a b = fromOrdinary $ ExprVec.cmp ord (toOrdinary a) (toOrdinary b) + +select :: + (TypeNum.Positive n, MultiVector.Select a) => + Exp (T n Bool) -> Exp (T n a) -> Exp (T n a) -> Exp (T n a) +select c a b = + fromOrdinary $ ExprVec.select (toOrdinary c) (toOrdinary a) (toOrdinary b) + + +fromOrdinary :: Exp (LLVM.Vector n a) -> Exp (T n a) +fromOrdinary = Expr.lift1 MultiValue.cast + +toOrdinary :: Exp (T n a) -> Exp (LLVM.Vector n a) +toOrdinary = Expr.lift1 MultiValue.cast diff --git a/src/Synthesizer/LLVM/Frame/SerialVector/Class.hs b/src/Synthesizer/LLVM/Frame/SerialVector/Class.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Frame/SerialVector/Class.hs @@ -0,0 +1,523 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} +{- | +A special vector type that represents a time-sequence of samples. +This way we can distinguish safely between LLVM vectors +used for parallel signals and pipelines and +those used for chunky processing of scalar signals. +For the chunky processing this data type allows us +to derive the factor from the type +that time constants have to be multiplied with. +-} +module Synthesizer.LLVM.Frame.SerialVector.Class ( + Constant(Constant), constant, + + Read, Element, ReadIt, extract, readStart, readNext, + Write, WriteIt, insert, writeStart, writeNext, writeStop, + Zero, writeZero, + Iterator(Iterator), ReadIterator, WriteIterator, ReadMode, WriteMode, + + Sized, Size, size, sizeOfIterator, withSize, + + insertTraversable, extractTraversable, + readStartTraversable, readNextTraversable, + writeStartTraversable, writeNextTraversable, writeStopTraversable, + writeZeroTraversable, + + dissect, assemble, modify, + upsample, subsample, last, + iterate, reverse, + shiftUp, shiftUpMultiZero, shiftDownMultiZero, + ) where + +import qualified Synthesizer.LLVM.Frame.SerialVector.Code as SerialCode +import qualified Synthesizer.LLVM.Frame.Stereo as Stereo + +import qualified LLVM.Extra.Multi.Vector as MultiVector +import qualified LLVM.Extra.Multi.Value as MultiValue +import qualified LLVM.Extra.Memory as Memory +import qualified LLVM.Extra.Arithmetic as A +import qualified LLVM.Extra.Tuple as Tuple + +import qualified LLVM.Core as LLVM + +import qualified Type.Data.Num.Decimal as TypeNum + +import Data.Word (Word32) + +import qualified Control.Monad.Trans.State as MS +import qualified Control.Applicative as App +import Control.Monad (foldM, replicateM, (<=<)) +import Control.Applicative (liftA2, liftA3, (<$>)) + +import qualified Data.Traversable as Trav +import qualified Data.List.HT as ListHT +import qualified Data.List as List +import Data.Tuple.HT (mapSnd, fst3, snd3, thd3) + +import Prelude hiding (Read, replicate, reverse, iterate, last) + + + +newtype Constant n a = Constant a + +constant :: (TypeNum.Positive n) => a -> Constant n a +constant = Constant + +instance Functor (Constant n) where + fmap f (Constant a) = Constant (f a) + +instance App.Applicative (Constant n) where + pure = Constant + Constant f <*> Constant a = Constant (f a) + +instance (Tuple.Phi a) => Tuple.Phi (Constant n a) where + phi bb (Constant a) = Constant <$> Tuple.phi bb a + addPhi bb (Constant a) (Constant b) = Tuple.addPhi bb a b + +instance (Tuple.Undefined a) => Tuple.Undefined (Constant n a) where + undef = Tuple.undefPointed + + + +instance (TypeNum.Positive n) => Sized (Constant n a) where + type Size (Constant n a) = n + +instance + (TypeNum.Positive n, Tuple.Phi a, Tuple.Undefined a) => + Read (Constant n a) where + + type Element (Constant n a) = a + type ReadIt (Constant n a) = a + + extract _k (Constant a) = return a + + readStart (Constant a) = return $ Iterator a + readNext it@(Iterator a) = return (a, it) + + + +newtype Iterator mode it v = Iterator {unIterator :: it} + deriving (Tuple.Undefined) + +instance Tuple.Phi it => Tuple.Phi (Iterator mode it v) where + phi bb (Iterator x) = fmap Iterator $ Tuple.phi bb x + addPhi bb (Iterator x) (Iterator y) = Tuple.addPhi bb x y + + +type ReadIterator = Iterator ReadMode +type WriteIterator = Iterator WriteMode + +data ReadMode +data WriteMode + + +instance (Memory.C it) => Memory.C (Iterator mode it v) where + type Struct (Iterator mode it v) = Memory.Struct it + load = Memory.loadNewtype Iterator + store = Memory.storeNewtype (\(Iterator v) -> v) + decompose = Memory.decomposeNewtype Iterator + compose = Memory.composeNewtype (\(Iterator v) -> v) + + +fmapIt :: + (ita -> itb) -> (va -> vb) -> + Iterator mode ita va -> Iterator mode itb vb +fmapIt f _ (Iterator a) = Iterator (f a) + + +combineIt2 :: + Iterator mode xa va -> Iterator mode xb vb -> + Iterator mode (xa,xb) (va,vb) +combineIt2 (Iterator va) (Iterator vb) = Iterator (va,vb) + +combineIt3 :: + Iterator mode xa va -> Iterator mode xb vb -> Iterator mode xc vc -> + Iterator mode (xa,xb,xc) (va,vb,vc) +combineIt3 (Iterator va) (Iterator vb) (Iterator vc) = Iterator (va,vb,vc) + +combineItFunctor :: + (Functor f) => f (Iterator mode x v) -> Iterator mode (f x) (f v) +combineItFunctor = Iterator . fmap unIterator + +sequenceItFunctor :: + (Functor f) => Iterator mode (f it) (f v) -> f (Iterator mode it v) +sequenceItFunctor = fmap Iterator . unIterator + + +withSize :: Sized v => (Int -> m v) -> m v +withSize = + let sz :: (Sized v) => TypeNum.Singleton (Size v) -> (Int -> m v) -> m v + sz n f = f (TypeNum.integralFromSingleton n) + in sz TypeNum.singleton + +size :: (Sized v, Integral i) => v -> i +size = + let sz :: (Sized v, Integral i) => TypeNum.Singleton (Size v) -> v -> i + sz n _ = TypeNum.integralFromSingleton n + in sz TypeNum.singleton + +sizeOfIterator :: (Sized v, Integral i) => Iterator mode it v -> i +sizeOfIterator = + let sz :: (Sized v, Integral i) => + TypeNum.Singleton (Size v) -> Iterator mode it v -> i + sz n _ = TypeNum.integralFromSingleton n + in sz TypeNum.singleton + + +{- | +The type parameter @v@ shall be a @MultiVector@ or @MultiValue Serial@ +or a wrapper around one or more such things sharing the same size. +-} +class (TypeNum.Positive (Size v)) => Sized v where + type Size v + +class + (Sized v, + Tuple.Phi (ReadIt v), Tuple.Undefined (ReadIt v), + Tuple.Phi v, Tuple.Undefined v) => + Read v where + + type Element v + type ReadIt v + + extract :: LLVM.Value Word32 -> v -> LLVM.CodeGenFunction r (Element v) + + dissect :: v -> LLVM.CodeGenFunction r [Element v] + dissect x = mapM (flip extract x . LLVM.valueOf) (take (size x) [0..]) + + readStart :: v -> LLVM.CodeGenFunction r (ReadIterator (ReadIt v) v) + readNext :: + ReadIterator (ReadIt v) v -> + LLVM.CodeGenFunction r (Element v, ReadIterator (ReadIt v) v) + +class + (Read v, Tuple.Phi (WriteIt v), Tuple.Undefined (WriteIt v)) => + Write v where + type WriteIt v + + insert :: LLVM.Value Word32 -> Element v -> v -> LLVM.CodeGenFunction r v + + assemble :: [Element v] -> LLVM.CodeGenFunction r v + assemble = + foldM (\v (k,x) -> insert (LLVM.valueOf k) x v) Tuple.undef . zip [0..] + + writeStart :: LLVM.CodeGenFunction r (WriteIterator (WriteIt v) v) + writeNext :: + Element v -> WriteIterator (WriteIt v) v -> + LLVM.CodeGenFunction r (WriteIterator (WriteIt v) v) + writeStop :: WriteIterator (WriteIt v) v -> LLVM.CodeGenFunction r v + +class (Write v, Tuple.Phi (WriteIt v), Tuple.Zero (WriteIt v)) => Zero v where + -- initializes the target with zeros + -- you may only call 'writeStop' on the result of 'writeZero' + writeZero :: LLVM.CodeGenFunction r (WriteIterator (WriteIt v) v) + + + +instance (TypeNum.Positive n) => Sized (MultiVector.T n a) where + type Size (MultiVector.T n a) = n + +instance (TypeNum.Positive n, MultiVector.C a) => Read (MultiVector.T n a) where + + type Element (MultiVector.T n a) = MultiValue.T a + type ReadIt (MultiVector.T n a) = MultiVector.T n a + + extract = MultiVector.extract + + readStart v = return $ Iterator v + readNext (Iterator v) = + mapSnd Iterator <$> MultiVector.shiftDown MultiValue.undef v + +instance + (TypeNum.Positive n, MultiVector.C a) => Write (MultiVector.T n a) where + + type WriteIt (MultiVector.T n a) = MultiVector.T n a + + insert = MultiVector.insert + + writeStart = return (Iterator MultiVector.undef) + writeNext x (Iterator v) = Iterator . snd <$> MultiVector.shiftDown x v + writeStop (Iterator v) = return v + +instance (TypeNum.Positive n, MultiVector.C a) => Zero (MultiVector.T n a) where + writeZero = return (Iterator Tuple.zero) + + + +type Serial n a = SerialCode.Value n a + +instance (TypeNum.Positive n) => Sized (Serial n a) where + type Size (Serial n a) = n + +instance (TypeNum.Positive n, MultiVector.C a) => Read (Serial n a) where + + type Element (Serial n a) = MultiValue.T a + type ReadIt (Serial n a) = Serial n a + + extract = SerialCode.extract + + readStart v = return $ Iterator v + readNext (Iterator v) = + mapSnd Iterator <$> SerialCode.shiftDown MultiValue.undef v + +instance (TypeNum.Positive n, MultiVector.C a) => Write (Serial n a) where + + type WriteIt (Serial n a) = Serial n a + + insert = SerialCode.insert + + writeStart = return (Iterator Tuple.undef) + writeNext x (Iterator v) = Iterator . snd <$> SerialCode.shiftDown x v + writeStop (Iterator v) = return v + +instance (TypeNum.Positive n, MultiVector.C a) => Zero (Serial n a) where + writeZero = return (Iterator Tuple.zero) + + + +instance (Sized va, Sized vb, Size va ~ Size vb) => Sized (va, vb) where + type Size (va, vb) = Size va + +instance (Read va, Read vb, Size va ~ Size vb) => Read (va, vb) where + + type Element (va, vb) = (Element va, Element vb) + type ReadIt (va, vb) = (ReadIt va, ReadIt vb) + + extract k (va,vb) = liftA2 (,) (extract k va) (extract k vb) + + readStart (va,vb) = liftA2 combineIt2 (readStart va) (readStart vb) + readNext it = do + (a, ita) <- readNext $ fmapIt fst fst it + (b, itb) <- readNext $ fmapIt snd snd it + return ((a,b), combineIt2 ita itb) + +instance (Write va, Write vb, Size va ~ Size vb) => Write (va, vb) where + + type WriteIt (va, vb) = (WriteIt va, WriteIt vb) + + insert k (a,b) (va,vb) = + liftA2 (,) + (insert k a va) + (insert k b vb) + + writeStart = liftA2 combineIt2 writeStart writeStart + writeNext (a,b) it = + liftA2 combineIt2 + (writeNext a $ fmapIt fst fst it) + (writeNext b $ fmapIt snd snd it) + writeStop it = + liftA2 (,) + (writeStop (fmapIt fst fst it)) + (writeStop (fmapIt snd snd it)) + +instance (Zero va, Zero vb, Size va ~ Size vb) => Zero (va, vb) where + writeZero = liftA2 combineIt2 writeZero writeZero + + +instance + (Sized va, Sized vb, Sized vc, Size va ~ Size vb, Size vb ~ Size vc) => + Sized (va, vb, vc) where + type Size (va, vb, vc) = Size va + +instance + (Read va, Read vb, Read vc, Size va ~ Size vb, Size vb ~ Size vc) => + Read (va, vb, vc) where + + type Element (va, vb, vc) = (Element va, Element vb, Element vc) + type ReadIt (va, vb, vc) = (ReadIt va, ReadIt vb, ReadIt vc) + + extract k (va,vb,vc) = + liftA3 (,,) + (extract k va) + (extract k vb) + (extract k vc) + + readStart (va,vb,vc) = + liftA3 combineIt3 (readStart va) (readStart vb) (readStart vc) + readNext it = do + (a, ita) <- readNext $ fmapIt fst3 fst3 it + (b, itb) <- readNext $ fmapIt snd3 snd3 it + (c, itc) <- readNext $ fmapIt thd3 thd3 it + return ((a,b,c), combineIt3 ita itb itc) + + +instance + (Write va, Write vb, Write vc, Size va ~ Size vb, Size vb ~ Size vc) => + Write (va, vb, vc) where + + type WriteIt (va, vb, vc) = (WriteIt va, WriteIt vb, WriteIt vc) + + insert k (a,b,c) (va,vb,vc) = + liftA3 (,,) + (insert k a va) + (insert k b vb) + (insert k c vc) + + writeStart = liftA3 combineIt3 writeStart writeStart writeStart + writeNext (a,b,c) it = + liftA3 combineIt3 + (writeNext a $ fmapIt fst3 fst3 it) + (writeNext b $ fmapIt snd3 snd3 it) + (writeNext c $ fmapIt thd3 thd3 it) + writeStop it = + liftA3 (,,) + (writeStop (fmapIt fst3 fst3 it)) + (writeStop (fmapIt snd3 snd3 it)) + (writeStop (fmapIt thd3 thd3 it)) + +instance + (Zero va, Zero vb, Zero vc, Size va ~ Size vb, Size vb ~ Size vc) => + Zero (va, vb, vc) where + + writeZero = liftA3 combineIt3 writeZero writeZero writeZero + + +instance (Sized value) => Sized (Stereo.T value) where + type Size (Stereo.T value) = Size value + +instance (Read v) => Read (Stereo.T v) where + + type Element (Stereo.T v) = Stereo.T (Element v) + type ReadIt (Stereo.T v) = Stereo.T (ReadIt v) + + extract = extractTraversable + + readStart = readStartTraversable + readNext = readNextTraversable + +instance (Write v) => Write (Stereo.T v) where + + type WriteIt (Stereo.T v) = Stereo.T (WriteIt v) + + insert = insertTraversable + + writeStart = writeStartTraversable + writeNext = writeNextTraversable + writeStop = writeStopTraversable + +instance (Zero v) => Zero (Stereo.T v) where + + writeZero = writeZeroTraversable + + +insertTraversable :: + (Write v, Trav.Traversable f, App.Applicative f) => + LLVM.Value Word32 -> f (Element v) -> f v -> LLVM.CodeGenFunction r (f v) +insertTraversable n a v = + Trav.sequence (liftA2 (insert n) a v) + +extractTraversable :: + (Read v, Trav.Traversable f) => + LLVM.Value Word32 -> f v -> LLVM.CodeGenFunction r (f (Element v)) +extractTraversable n v = + Trav.mapM (extract n) v + + +readStartTraversable :: + (Trav.Traversable f, App.Applicative f, Read v) => + f v -> LLVM.CodeGenFunction r (ReadIterator (f (ReadIt v)) (f v)) +readNextTraversable :: + (Trav.Traversable f, App.Applicative f, Read v) => + ReadIterator (f (ReadIt v)) (f v) -> + LLVM.CodeGenFunction r (f (Element v), ReadIterator (f (ReadIt v)) (f v)) + +readStartTraversable v = + fmap combineItFunctor $ Trav.mapM readStart v + +readNextTraversable it = do + st <- Trav.mapM readNext $ sequenceItFunctor it + return (fmap fst st, combineItFunctor $ fmap snd st) + + +writeStartTraversable :: + (Trav.Traversable f, App.Applicative f, Write v) => + LLVM.CodeGenFunction r (WriteIterator (f (WriteIt v)) (f v)) +writeNextTraversable :: + (Trav.Traversable f, App.Applicative f, Write v) => + f (Element v) -> WriteIterator (f (WriteIt v)) (f v) -> + LLVM.CodeGenFunction r (WriteIterator (f (WriteIt v)) (f v)) +writeStopTraversable :: + (Trav.Traversable f, App.Applicative f, Write v) => + WriteIterator (f (WriteIt v)) (f v) -> LLVM.CodeGenFunction r (f v) +writeZeroTraversable :: + (Trav.Traversable f, App.Applicative f, Zero v) => + LLVM.CodeGenFunction r (WriteIterator (f (WriteIt v)) (f v)) + +writeStartTraversable = + fmap combineItFunctor $ Trav.sequence $ App.pure writeStart + +writeNextTraversable x it = + fmap combineItFunctor $ Trav.sequence $ + liftA2 writeNext x $ sequenceItFunctor it + +writeStopTraversable = Trav.mapM writeStop . sequenceItFunctor + +writeZeroTraversable = + fmap combineItFunctor $ Trav.sequence $ App.pure writeZero + + +modify :: + (Write v, Element v ~ a) => + LLVM.Value Word32 -> + (a -> LLVM.CodeGenFunction r a) -> + v -> LLVM.CodeGenFunction r v +modify k f v = flip (insert k) v =<< f =<< extract k v + + +last :: (Read v) => v -> LLVM.CodeGenFunction r (Element v) +last v = extract (LLVM.valueOf (size v - 1 :: Word32)) v + +subsample :: (Read v) => v -> LLVM.CodeGenFunction r (Element v) +subsample v = extract (A.zero :: LLVM.Value Word32) v + +-- this will be translated to an efficient pshufd +upsample :: (Write v) => Element v -> LLVM.CodeGenFunction r v +upsample x = withSize $ \n -> assemble $ List.replicate n x + + +iterate :: + (Write v) => + (Element v -> LLVM.CodeGenFunction r (Element v)) -> + Element v -> LLVM.CodeGenFunction r v +iterate f x = + withSize $ \n -> + assemble =<< + (flip MS.evalStateT x $ + replicateM n $ + MS.StateT $ \x0 -> do x1 <- f x0; return (x0,x1)) + +reverse :: + (Write v) => + v -> LLVM.CodeGenFunction r v +reverse = + assemble . List.reverse <=< dissect + +shiftUp :: + (Write v) => + Element v -> v -> LLVM.CodeGenFunction r (Element v, v) +shiftUp x v = + ListHT.switchR + (return (x,v)) + (\ys0 y -> fmap ((,) y) $ assemble (x:ys0)) + =<< + dissect v + + +shiftUpMultiZero :: + (Write v, A.Additive (Element v)) => + Int -> v -> LLVM.CodeGenFunction r v +shiftUpMultiZero n v = + assemble . take (size v) . (List.replicate n A.zero ++) =<< dissect v + +shiftDownMultiZero :: + (Write v, A.Additive (Element v)) => + Int -> v -> LLVM.CodeGenFunction r v +shiftDownMultiZero n v = + assemble . take (size v) . (++ List.repeat A.zero) . List.drop n + =<< dissect v diff --git a/src/Synthesizer/LLVM/Frame/SerialVector/Code.hs b/src/Synthesizer/LLVM/Frame/SerialVector/Code.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Frame/SerialVector/Code.hs @@ -0,0 +1,279 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Synthesizer.LLVM.Frame.SerialVector.Code ( + T(Cons), Value, size, + fromOrdinary, toOrdinary, + fromMultiVector, toMultiVector, + extract, insert, modify, + assemble, dissect, + assemble1, dissect1, + upsample, subsample, last, + reverse, shiftUp, shiftUpMultiZero, shiftDown, + cumulate, iterate, + scale, + ) where + +import qualified LLVM.Extra.Multi.Vector.Instance as MultiVectorInst +import qualified LLVM.Extra.Multi.Vector as MultiVector +import qualified LLVM.Extra.Multi.Value.Storable as Storable +import qualified LLVM.Extra.Multi.Value.Marshal as Marshal +import qualified LLVM.Extra.Multi.Value.Vector as MultiValueVec +import qualified LLVM.Extra.Multi.Value as MultiValue +import qualified LLVM.Extra.Arithmetic as A + +import qualified LLVM.Core as LLVM + +import qualified Type.Data.Num.Decimal as TypeNum + +import qualified Foreign.Storable as Store +import Foreign.Storable (Storable) +import Foreign.Ptr (castPtr) + +import Control.Applicative ((<$>)) + +import qualified Data.NonEmpty as NonEmpty +import Data.Word (Word32) +import Data.Tuple.HT (mapSnd) + +import Prelude as P hiding (last, reverse, iterate) + + +newtype T n a = Cons (LLVM.Vector n a) + deriving (Eq, Num) + +type Value n a = MultiValue.T (T n a) + +instance (TypeNum.Positive n, MultiVector.C a) => MultiValue.C (T n a) where + type Repr (T n a) = MultiVector.Repr n a + cons (Cons v) = fromOrdinary $ MultiValue.cons v + undef = fromOrdinary MultiValue.undef + zero = fromOrdinary MultiValue.zero + phi bb = fmap fromOrdinary . MultiValue.phi bb . toOrdinary + addPhi bb a b = MultiValue.addPhi bb (toOrdinary a) (toOrdinary b) + +instance (Marshal.Vector n a) => Marshal.C (T n a) where + pack (Cons v) = Marshal.pack v + unpack = Cons . Marshal.unpack + +instance (TypeNum.Positive n, Storable a) => Storable (T n a) where + sizeOf (Cons v) = Store.sizeOf v + alignment (Cons v) = Store.alignment v + poke ptr (Cons v) = Store.poke (castPtr ptr) v + peek ptr = Cons <$> Store.peek (castPtr ptr) + +instance + (TypeNum.Positive n, Storable.Vector a, MultiVector.C a) => + Storable.C (T n a) where + load ptr = fmap fromOrdinary $ Storable.load =<< LLVM.bitcast ptr + store v ptr = Storable.store (toOrdinary v) =<< LLVM.bitcast ptr + +instance + (TypeNum.Positive n, MultiVector.IntegerConstant a) => + MultiValue.IntegerConstant (T n a) where + fromInteger' = fromMultiVector . MultiVector.fromInteger' + +instance + (TypeNum.Positive n, MultiVector.RationalConstant a) => + MultiValue.RationalConstant (T n a) where + fromRational' = fromMultiVector . MultiVector.fromRational' + +instance + (TypeNum.Positive n, MultiVector.Additive a) => + MultiValue.Additive (T n a) where + add = lift2 MultiVector.add + sub = lift2 MultiVector.sub + neg = lift1 MultiVector.neg + +instance + (TypeNum.Positive n, MultiVector.PseudoRing a) => + MultiValue.PseudoRing (T n a) where + mul = lift2 MultiVector.mul + +scale :: + (TypeNum.Positive n, MultiVector.PseudoRing a) => + MultiValue.T a -> Value n a -> LLVM.CodeGenFunction r (Value n a) +scale = lift1 . MultiVector.scale + +instance + (TypeNum.Positive n, MultiVector.Real a) => + MultiValue.Real (T n a) where + min = lift2 MultiVector.min + max = lift2 MultiVector.max + abs = lift1 MultiVector.abs + signum = lift1 MultiVector.signum + +instance + (TypeNum.Positive n, MultiVector.Fraction a) => + MultiValue.Fraction (T n a) where + truncate = lift1 MultiVector.truncate + fraction = lift1 MultiVector.fraction + +instance + (TypeNum.Positive n, MultiVector.Field a) => + MultiValue.Field (T n a) where + fdiv = lift2 MultiVector.fdiv + +instance + (TypeNum.Positive n, MultiVector.Algebraic a) => + MultiValue.Algebraic (T n a) where + sqrt = lift1 MultiVector.sqrt + +instance + (TypeNum.Positive n, MultiVector.Transcendental a) => + MultiValue.Transcendental (T n a) where + pi = fmap fromMultiVector MultiVector.pi + sin = lift1 MultiVector.sin + log = lift1 MultiVector.log + exp = lift1 MultiVector.exp + cos = lift1 MultiVector.cos + pow = lift2 MultiVector.pow + +instance + (TypeNum.Positive n, n ~ m, + MultiVector.NativeInteger n a ar, + MultiValue.NativeInteger a ar) => + MultiValueVec.NativeInteger (T n a) (LLVM.Vector m ar) where + +instance + (TypeNum.Positive n, n ~ m, + MultiVector.NativeFloating n a ar, + MultiValue.NativeFloating a ar) => + MultiValueVec.NativeFloating (T n a) (LLVM.Vector m ar) where + +lift1 :: + (Functor f) => + (MultiVector.T n a -> f (MultiVector.T m b)) -> + (Value n a -> f (Value m b)) +lift1 f a = fromMultiVector <$> f (toMultiVector a) + +lift2 :: + (Functor f) => + (MultiVector.T n a -> MultiVector.T m b -> f (MultiVector.T k c)) -> + (Value n a -> Value m b -> f (Value k c)) +lift2 f a b = fromMultiVector <$> f (toMultiVector a) (toMultiVector b) + + +extract :: + (TypeNum.Positive n, + MultiVector.C x, MultiValue.T x ~ a, Value n x ~ v) => + LLVM.Value Word32 -> v -> LLVM.CodeGenFunction r a +extract i v = MultiVector.extract i (toMultiVector v) + +insert :: + (TypeNum.Positive n, + MultiVector.C x, MultiValue.T x ~ a, Value n x ~ v) => + LLVM.Value Word32 -> a -> v -> LLVM.CodeGenFunction r v +insert i a v = + fromMultiVector <$> MultiVector.insert i a (toMultiVector v) + +modify :: + (TypeNum.Positive n, + MultiVector.C x, MultiValue.T x ~ a, Value n x ~ v) => + LLVM.Value Word32 -> + (a -> LLVM.CodeGenFunction r a) -> + v -> LLVM.CodeGenFunction r v +modify k f v = flip (insert k) v =<< f =<< extract k v + + +assemble :: + (TypeNum.Positive n, MultiVector.C a) => + [MultiValue.T a] -> + LLVM.CodeGenFunction r (Value n a) +assemble = fmap fromMultiVector . MultiVector.assemble + +dissect :: + (TypeNum.Positive n, MultiVector.C a) => + Value n a -> + LLVM.CodeGenFunction r [MultiValue.T a] +dissect = MultiVector.dissect . toMultiVector + +assemble1 :: + (TypeNum.Positive n, MultiVector.C a) => + NonEmpty.T [] (MultiValue.T a) -> + LLVM.CodeGenFunction r (Value n a) +assemble1 = fmap fromMultiVector . MultiVector.assemble1 + +dissect1 :: + (TypeNum.Positive n, MultiVector.C a) => + Value n a -> + LLVM.CodeGenFunction r (NonEmpty.T [] (MultiValue.T a)) +dissect1 = MultiVector.dissect1 . toMultiVector + + +sizeS :: TypeNum.Positive n => Value n a -> TypeNum.Singleton n +sizeS _ = TypeNum.singleton + +size :: (TypeNum.Positive n, P.Integral i) => Value n a -> i +size = TypeNum.integralFromSingleton . sizeS + + +last :: + (TypeNum.Positive n, MultiVector.C a) => + Value n a -> LLVM.CodeGenFunction r (MultiValue.T a) +last v = extract (LLVM.valueOf (size v - 1 :: Word32)) v + +subsample :: + (TypeNum.Positive n, MultiVector.C a) => + Value n a -> LLVM.CodeGenFunction r (MultiValue.T a) +subsample = extract (A.zero :: LLVM.Value Word32) + +upsample :: + (TypeNum.Positive n, MultiVector.C a) => + MultiValue.T a -> LLVM.CodeGenFunction r (Value n a) +upsample = fmap fromOrdinary . MultiValueVec.replicate + + +reverse :: + (TypeNum.Positive n, MultiVector.C a) => + Value n a -> LLVM.CodeGenFunction r (Value n a) +reverse = + fmap fromMultiVector . MultiVector.reverse . toMultiVector + +shiftUp :: + (TypeNum.Positive n, MultiVector.C x, + MultiValue.T x ~ a, Value n x ~ v) => + a -> v -> LLVM.CodeGenFunction r (a, v) +shiftUp a v = + mapSnd fromMultiVector <$> MultiVector.shiftUp a (toMultiVector v) + +shiftUpMultiZero :: + (TypeNum.Positive n, MultiVector.C x, Value n x ~ v) => + Int -> v -> LLVM.CodeGenFunction r v +shiftUpMultiZero k v = + fromMultiVector <$> MultiVector.shiftUpMultiZero k (toMultiVector v) + +shiftDown :: + (TypeNum.Positive n, MultiVector.C x, + MultiValue.T x ~ a, Value n x ~ v) => + a -> v -> LLVM.CodeGenFunction r (a, v) +shiftDown a v = + mapSnd fromMultiVector <$> MultiVector.shiftDown a (toMultiVector v) + + +iterate :: + (TypeNum.Positive n, MultiVector.C a) => + (MultiValue.T a -> LLVM.CodeGenFunction r (MultiValue.T a)) -> + MultiValue.T a -> LLVM.CodeGenFunction r (Value n a) +iterate f = fmap fromOrdinary . MultiValueVec.iterate f + +cumulate :: + (TypeNum.Positive n, MultiVector.Additive a) => + MultiValue.T a -> Value n a -> + LLVM.CodeGenFunction r (MultiValue.T a, Value n a) +cumulate a = + fmap (mapSnd fromMultiVector) . MultiVector.cumulate a . toMultiVector + + +fromOrdinary :: MultiValue.T (LLVM.Vector n a) -> Value n a +fromOrdinary = MultiValue.cast + +toOrdinary :: Value n a -> MultiValue.T (LLVM.Vector n a) +toOrdinary = MultiValue.cast + +fromMultiVector :: MultiVector.T n a -> Value n a +fromMultiVector = fromOrdinary . MultiVectorInst.toMultiValue + +toMultiVector :: Value n a -> MultiVector.T n a +toMultiVector = MultiVectorInst.fromMultiValue . toOrdinary diff --git a/src/Synthesizer/LLVM/Frame/SerialVector/Plain.hs b/src/Synthesizer/LLVM/Frame/SerialVector/Plain.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Frame/SerialVector/Plain.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE TypeFamilies #-} +{- | +A special vector type that represents a time-sequence of samples. +This way we can distinguish safely between LLVM vectors +used for parallel signals and pipelines and +those used for chunky processing of scalar signals. +For the chunky processing this data type allows us +to derive the factor from the type +that time constants have to be multiplied with. +-} +module Synthesizer.LLVM.Frame.SerialVector.Plain ( + T(Cons), + fromList, + replicate, + iterate, + ) where + +import qualified Synthesizer.LLVM.Frame.SerialVector.Code as Code +import Synthesizer.LLVM.Frame.SerialVector.Code (T) + +import qualified LLVM.Core as LLVM + +import qualified Type.Data.Num.Decimal as TypeNum + +import qualified Data.NonEmpty.Class as NonEmptyC +import qualified Data.NonEmpty as NonEmpty + +import Prelude as P hiding (zip, unzip, last, reverse, iterate, replicate) + + +fromList :: (TypeNum.Positive n) => NonEmpty.T [] a -> T n a +fromList = Code.Cons . LLVM.cyclicVector + +replicate :: (TypeNum.Positive n) => a -> T n a +replicate = Code.Cons . pure + +iterate :: (TypeNum.Positive n) => (a -> a) -> a -> T n a +iterate f x = fromList $ NonEmptyC.iterate f x diff --git a/src/Synthesizer/LLVM/Frame/Stereo.hs b/src/Synthesizer/LLVM/Frame/Stereo.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Frame/Stereo.hs @@ -0,0 +1,260 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{- | +Re-export functions from "Sound.Frame.Stereo" +and add (orphan) instances for various LLVM type classes. +If you want to use the Stereo datatype with synthesizer-llvm +we recommend to import this module instead of +"Sound.Frame.Stereo" or "Sound.Frame.NumericPrelude.Stereo". +-} +module Synthesizer.LLVM.Frame.Stereo ( + Stereo.T, Stereo.cons, Stereo.left, Stereo.right, + Stereo.Channel(Stereo.Left, Stereo.Right), Stereo.select, + Stereo.swap, + multiValue, unMultiValue, consMultiValue, unExpression, + multiVector, unMultiVector, + multiValueSerial, unMultiValueSerial, + Stereo.arrowFromMono, + Stereo.arrowFromMonoControlled, + Stereo.arrowFromChannels, + Stereo.interleave, + Stereo.sequence, + Stereo.liftApplicative, + ) where + +import qualified Synthesizer.LLVM.Frame.SerialVector as Serial +import qualified Synthesizer.Frame.Stereo as Stereo + +import qualified LLVM.DSL.Expression as Expr +import qualified LLVM.DSL.Value as Value + +import qualified LLVM.Extra.Multi.Vector as MultiVector +import qualified LLVM.Extra.Multi.Value.Storable as StorableMV +import qualified LLVM.Extra.Multi.Value.Marshal as MarshalMV +import qualified LLVM.Extra.Multi.Value as MultiValue +import qualified LLVM.Extra.Tuple as Tuple +import qualified LLVM.Extra.Storable as Storable +import qualified LLVM.Extra.Marshal as Marshal +import qualified LLVM.Extra.Memory as Memory +import qualified LLVM.Extra.Arithmetic as A +import qualified LLVM.Extra.Control as C +import qualified LLVM.Extra.Vector as Vector +import qualified LLVM.Core as LLVM + +import Type.Data.Num.Decimal (d0, d1) + +import Control.Applicative (liftA2, pure, (<$>)) + +import qualified Data.Traversable as Trav +import qualified Data.Foldable as Fold + +import Prelude hiding (Either(Left, Right), sequence) + + +instance (Tuple.Zero a) => Tuple.Zero (Stereo.T a) where + zero = Stereo.cons Tuple.zero Tuple.zero + +instance (Tuple.Undefined a) => Tuple.Undefined (Stereo.T a) where + undef = Stereo.cons Tuple.undef Tuple.undef + +instance (C.Select a) => C.Select (Stereo.T a) where + select = C.selectTraversable + +instance (Tuple.Value h) => Tuple.Value (Stereo.T h) where + type ValueOf (Stereo.T h) = Stereo.T (Tuple.ValueOf h) + valueOf = fmap Tuple.valueOf + +instance (Tuple.Phi a) => Tuple.Phi (Stereo.T a) where + phi bb v = + liftA2 Stereo.cons + (Tuple.phi bb (Stereo.left v)) + (Tuple.phi bb (Stereo.right v)) + addPhi bb x y = do + Tuple.addPhi bb (Stereo.left x) (Stereo.left y) + Tuple.addPhi bb (Stereo.right x) (Stereo.right y) + +instance (MultiValue.C a) => MultiValue.C (Stereo.T a) where + type Repr (Stereo.T a) = Stereo.T (MultiValue.Repr a) + cons = multiValue . fmap MultiValue.cons + undef = multiValue $ pure MultiValue.undef + zero = multiValue $ pure MultiValue.zero + phi bb = fmap multiValue . Trav.traverse (MultiValue.phi bb) . unMultiValue + addPhi bb a b = + Fold.sequence_ $ + liftA2 (MultiValue.addPhi bb) (unMultiValue a) (unMultiValue b) + +instance (MultiValue.Compose a) => MultiValue.Compose (Stereo.T a) where + type Composed (Stereo.T a) = Stereo.T (MultiValue.Composed a) + compose = multiValue . fmap MultiValue.compose + +instance (MultiValue.Decompose p) => MultiValue.Decompose (Stereo.T p) where + decompose p = liftA2 MultiValue.decompose p . unMultiValue + +type instance MultiValue.Decomposed f (Stereo.T pa) = + Stereo.T (MultiValue.Decomposed f pa) +type instance MultiValue.PatternTuple (Stereo.T pa) = + Stereo.T (MultiValue.PatternTuple pa) + +multiValue :: Stereo.T (MultiValue.T a) -> MultiValue.T (Stereo.T a) +multiValue = MultiValue.Cons . fmap (\(MultiValue.Cons a) -> a) + +unMultiValue :: MultiValue.T (Stereo.T a) -> Stereo.T (MultiValue.T a) +unMultiValue (MultiValue.Cons x) = fmap MultiValue.Cons x + +consMultiValue :: MultiValue.T a -> MultiValue.T a -> MultiValue.T (Stereo.T a) +consMultiValue l r = multiValue $ Stereo.cons l r + + +unExpression :: Expr.Exp (Stereo.T a) -> Stereo.T (Expr.Exp a) +unExpression x = + Stereo.cons + (Expr.lift1 (MultiValue.lift1 Stereo.left) x) + (Expr.lift1 (MultiValue.lift1 Stereo.right) x) + + +instance (MultiVector.C a) => MultiVector.C (Stereo.T a) where + type Repr n (Stereo.T a) = Stereo.T (MultiVector.Repr n a) + cons = multiVector . fmap MultiVector.cons . Stereo.sequence + undef = multiVector $ pure MultiVector.undef + zero = multiVector $ pure MultiVector.zero + phi bb = + fmap multiVector . Trav.traverse (MultiVector.phi bb) . unMultiVector + addPhi bb a b = + Fold.sequence_ $ + liftA2 (MultiVector.addPhi bb) (unMultiVector a) (unMultiVector b) + + shuffle is u v = + multiVector <$> + traverse2 (MultiVector.shuffle is) (unMultiVector u) (unMultiVector v) + extract k = + fmap multiValue . Trav.traverse (MultiVector.extract k) . unMultiVector + insert k a v = + multiVector <$> + traverse2 (MultiVector.insert k) (unMultiValue a) (unMultiVector v) + +multiVector :: Stereo.T (MultiVector.T n a) -> MultiVector.T n (Stereo.T a) +multiVector = MultiVector.Cons . fmap (\(MultiVector.Cons a) -> a) + +unMultiVector :: MultiVector.T n (Stereo.T a) -> Stereo.T (MultiVector.T n a) +unMultiVector (MultiVector.Cons x) = fmap MultiVector.Cons x + + +multiValueSerial :: + Stereo.T (MultiValue.T (Serial.T n a)) -> + MultiValue.T (Serial.T n (Stereo.T a)) +multiValueSerial = MultiValue.Cons . fmap (\(MultiValue.Cons a) -> a) + +unMultiValueSerial :: + MultiValue.T (Serial.T n (Stereo.T a)) -> + Stereo.T (MultiValue.T (Serial.T n a)) +unMultiValueSerial (MultiValue.Cons x) = fmap MultiValue.Cons x + + +instance + (Expr.Aggregate e mv) => Expr.Aggregate (Stereo.T e) (Stereo.T mv) where + type MultiValuesOf (Stereo.T e) = Stereo.T (Expr.MultiValuesOf e) + type ExpressionsOf (Stereo.T mv) = Stereo.T (Expr.ExpressionsOf mv) + bundle = Trav.traverse Expr.bundle + dissect = fmap Expr.dissect + + +instance (Vector.Simple v) => Vector.Simple (Stereo.T v) where + type Element (Stereo.T v) = Stereo.T (Vector.Element v) + type Size (Stereo.T v) = Vector.Size v + shuffleMatch = Vector.shuffleMatchTraversable + extract = Vector.extractTraversable + +instance (Vector.C v) => Vector.C (Stereo.T v) where + insert = Vector.insertTraversable + + +type Struct a = LLVM.Struct (a, (a, ())) + +memory :: + (Memory.C l) => + Memory.Record r (Struct (Memory.Struct l)) (Stereo.T l) +memory = + liftA2 Stereo.cons + (Memory.element Stereo.left d0) + (Memory.element Stereo.right d1) + +instance (Memory.C l) => Memory.C (Stereo.T l) where + type Struct (Stereo.T l) = Struct (Memory.Struct l) + load = Memory.loadRecord memory + store = Memory.storeRecord memory + decompose = Memory.decomposeRecord memory + compose = Memory.composeRecord memory + +instance (Marshal.C l) => Marshal.C (Stereo.T l) where + pack x = Marshal.pack (Stereo.left x, Stereo.right x) + unpack = uncurry Stereo.cons . Marshal.unpack + +instance (Storable.C l) => Storable.C (Stereo.T l) where + load = Storable.loadApplicative + store = Storable.storeFoldable + +instance (MarshalMV.C l) => MarshalMV.C (Stereo.T l) where + pack x = MarshalMV.pack (Stereo.left x, Stereo.right x) + unpack = uncurry Stereo.cons . MarshalMV.unpack + +instance (StorableMV.C l) => StorableMV.C (Stereo.T l) where + load = StorableMV.loadApplicative + store = StorableMV.storeFoldable + +instance + (StorableMV.Vector l, MultiVector.C l) => + StorableMV.Vector (Stereo.T l) where + assembleVector p = + Trav.traverse (StorableMV.assembleVector (Stereo.left<$>p)) . + Stereo.sequence + disassembleVector p = + fmap (\x -> liftA2 Stereo.cons (Stereo.left x) (Stereo.right x)) . + Trav.traverse (StorableMV.disassembleVector (Stereo.left<$>p)) + + +{- +instance + (Memory l s) => + Memory (Stereo.T l) (LLVM.Struct (s, (s, ()))) where + load ptr = + liftA2 Stereo.cons + (load =<< getElementPtr0 ptr (d0, ())) + (load =<< getElementPtr0 ptr (d1, ())) + store y ptr = do + store (Stereo.left y) =<< getElementPtr0 ptr (d0, ()) + store (Stereo.right y) =<< getElementPtr0 ptr (d1, ()) +-} + +instance (A.Additive a) => A.Additive (Stereo.T a) where + zero = Stereo.cons A.zero A.zero + add x y = traverse2 A.add x y + sub x y = traverse2 A.sub x y + neg x = Trav.traverse A.neg x + +type instance A.Scalar (Stereo.T a) = A.Scalar a + +instance (A.PseudoModule a) => A.PseudoModule (Stereo.T a) where + scale a = Trav.traverse (A.scale a) + + + +instance (MultiValue.Additive a) => MultiValue.Additive (Stereo.T a) where + add x y = + multiValue <$> traverse2 MultiValue.add (unMultiValue x) (unMultiValue y) + sub x y = + multiValue <$> traverse2 MultiValue.sub (unMultiValue x) (unMultiValue y) + neg x = multiValue <$> Trav.traverse MultiValue.neg (unMultiValue x) + + +traverse2 :: + (Monad m, Applicative t, Traversable t) => + (a -> b -> m c) -> t a -> t b -> m (t c) +traverse2 f x y = Trav.sequence $ liftA2 f x y + + + +instance Value.Flatten a => Value.Flatten (Stereo.T a) where + type Registers (Stereo.T a) = Stereo.T (Value.Registers a) + flattenCode = Value.flattenCodeTraversable + unfoldCode = Value.unfoldCodeTraversable diff --git a/src/Synthesizer/LLVM/Frame/StereoInterleaved.hs b/src/Synthesizer/LLVM/Frame/StereoInterleaved.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Frame/StereoInterleaved.hs @@ -0,0 +1,45 @@ +module Synthesizer.LLVM.Frame.StereoInterleaved ( + T, + Value, + interleave, + deinterleave, + amplify, + envelope, + ) where + +import qualified Synthesizer.LLVM.Frame.StereoInterleavedCode as StereoInt +import Synthesizer.LLVM.Frame.StereoInterleavedCode (T, Value) + +import qualified Synthesizer.LLVM.Frame.Stereo as Stereo +import qualified Synthesizer.LLVM.Frame.SerialVector.Code as Serial + +import qualified LLVM.DSL.Expression as Expr +import LLVM.DSL.Expression (Exp) + +import qualified LLVM.Extra.Multi.Vector as MultiVector + +import qualified Type.Data.Num.Decimal as TypeNum + + +interleave :: + (TypeNum.Positive n, MultiVector.C a) => + Stereo.T (Exp (Serial.T n a)) -> Exp (T n a) +interleave = Expr.liftM StereoInt.interleave + +deinterleave :: + (TypeNum.Positive n, MultiVector.C a) => + Exp (T n a) -> Stereo.T (Exp (Serial.T n a)) +deinterleave x = + Stereo.cons + (Expr.liftM (fmap Stereo.left . StereoInt.deinterleave) x) + (Expr.liftM (fmap Stereo.right . StereoInt.deinterleave) x) + +amplify :: + (TypeNum.Positive n, MultiVector.PseudoRing a) => + Exp a -> Exp (T n a) -> Exp (T n a) +amplify = Expr.liftM2 StereoInt.scale + +envelope :: + (TypeNum.Positive n, MultiVector.PseudoRing a) => + Exp (Serial.T n a) -> Exp (T n a) -> Exp (T n a) +envelope = Expr.liftM2 StereoInt.envelope diff --git a/src/Synthesizer/LLVM/Frame/StereoInterleavedCode.hs b/src/Synthesizer/LLVM/Frame/StereoInterleavedCode.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Frame/StereoInterleavedCode.hs @@ -0,0 +1,241 @@ +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{- | +Represent a vector of Stereo values in two vectors +that store the values in an interleaved way. +That is: + +> vector0[0] = left[0] +> vector0[1] = right[0] +> vector0[2] = left[1] +> vector0[3] = right[1] +> vector1[0] = left[2] +> vector1[1] = right[2] +> vector1[2] = left[3] +> vector1[3] = right[3] + +This representation is not very useful for computation, +but necessary as intermediate representation for interfacing with memory. +SSE/SSE2 have the instructions UNPACK(L|H)P(S|D) that interleave efficiently. +-} +module Synthesizer.LLVM.Frame.StereoInterleavedCode ( + T, + Value, + interleave, + deinterleave, + fromMono, + assemble, dissect, + zero, + scale, + amplify, + envelope, + ) where + +import qualified Synthesizer.LLVM.Frame.Stereo as Stereo +import qualified Synthesizer.LLVM.Frame.SerialVector.Code as Serial + +import qualified LLVM.Extra.Multi.Vector as MultiVector +import qualified LLVM.Extra.Multi.Value.Storable as Storable +import qualified LLVM.Extra.Multi.Value.Marshal as Marshal +import qualified LLVM.Extra.Multi.Value as MultiValue +import qualified LLVM.Extra.Arithmetic as A +import qualified LLVM.Core as LLVM +import LLVM.Core (Vector) + +import qualified Type.Data.Num.Decimal as TypeNum + +import qualified Foreign.Storable as St +import Foreign.Ptr (Ptr, castPtr) + +import qualified Control.Applicative.HT as AppHT +import Control.Applicative (liftA2, pure) + +import qualified Data.Foldable as Fold +import Data.Tuple.HT (mapPair) + +import qualified Algebra.Additive as Additive + + +data T n a = Cons (Vector n a) (Vector n a) + +type Value n a = MultiValue.T (T n a) + + +withSize :: (TypeNum.Natural n) => (Int -> m (Value n a)) -> m (Value n a) +withSize = + let sz :: + (TypeNum.Natural n) => + TypeNum.Singleton n -> (Int -> m (Value n a)) -> m (Value n a) + sz n f = f (TypeNum.integralFromSingleton n) + in sz TypeNum.singleton + + +interleave :: + (TypeNum.Positive n, MultiVector.C a) => + Stereo.T (Serial.Value n a) -> + LLVM.CodeGenFunction r (Value n a) +interleave x = + assemble . map Stereo.unMultiValue + =<< Serial.dissect (Stereo.multiValueSerial x) + +deinterleave :: + (TypeNum.Positive n, MultiVector.C a) => + Value n a -> + LLVM.CodeGenFunction r (Stereo.T (Serial.Value n a)) +deinterleave v = + Stereo.unMultiValueSerial <$> + (Serial.assemble . map Stereo.multiValue =<< dissect v) + +fromMono :: + (TypeNum.Positive n, MultiVector.C a) => + Serial.Value n a -> + LLVM.CodeGenFunction r (Value n a) +fromMono x = + assemble . map pure =<< Serial.dissect x + +assemble :: + (TypeNum.Positive n, MultiVector.C a) => + [Stereo.T (MultiValue.T a)] -> LLVM.CodeGenFunction r (Value n a) +assemble x = + withSize $ \n -> + uncurry (liftA2 merge) . + mapPair (MultiVector.assemble, MultiVector.assemble) . + splitAt n . + concatMap Fold.toList $ x + +dissect :: + (TypeNum.Positive n, MultiVector.C a) => + Value n a -> LLVM.CodeGenFunction r [Stereo.T (MultiValue.T a)] +dissect v = + let (v0,v1) = split v in + fmap + (let aux (l:r:xs) = Stereo.cons l r : aux xs + aux [] = [] + aux _ = error "odd number of stereo elements" + in aux) $ + liftA2 (++) + (MultiVector.dissect v0) + (MultiVector.dissect v1) + + +merge :: MultiVector.T n a -> MultiVector.T n a -> MultiValue.T (T n a) +merge (MultiVector.Cons a) (MultiVector.Cons b) = MultiValue.Cons (a,b) + +split :: MultiValue.T (T n a) -> (MultiVector.T n a, MultiVector.T n a) +split (MultiValue.Cons (a,b)) = (MultiVector.Cons a, MultiVector.Cons b) + +merge_ :: + MultiValue.T (Vector n a) -> MultiValue.T (Vector n a) -> + MultiValue.T (T n a) +merge_ (MultiValue.Cons a) (MultiValue.Cons b) = MultiValue.Cons (a,b) + +split_ :: + MultiValue.T (T n a) -> + (MultiValue.T (Vector n a), MultiValue.T (Vector n a)) +split_ (MultiValue.Cons (a,b)) = (MultiValue.Cons a, MultiValue.Cons b) + +instance (TypeNum.Positive n, MultiVector.C a) => MultiValue.C (T n a) where + type Repr (T n a) = (MultiVector.Repr n a, MultiVector.Repr n a) + cons (Cons v0 v1) = merge (MultiVector.cons v0) (MultiVector.cons v1) + undef = merge MultiVector.undef MultiVector.undef + zero = merge MultiVector.zero MultiVector.zero + phi bb = + fmap (uncurry merge) . + AppHT.mapPair (MultiVector.phi bb, MultiVector.phi bb) . split + addPhi bb a b = + case (split a, split b) of + ((a0,a1), (b0,b1)) -> do + MultiVector.addPhi bb a0 b0 + MultiVector.addPhi bb a1 b1 + +instance (Marshal.Vector n a) => Marshal.C (T n a) where + pack (Cons v0 v1) = Marshal.pack (v0,v1) + unpack = uncurry Cons . Marshal.unpack + +instance + (TypeNum.Positive n, MultiVector.C a, St.Storable a) => + St.Storable (T n a) where + sizeOf ~(Cons v0 v1) = St.sizeOf v0 + St.sizeOf v1 + alignment ~(Cons v _) = St.alignment v + peek ptr = + let p = castPtr ptr + in liftA2 Cons + (St.peekElemOff p 0) + (St.peekElemOff p 1) + poke ptr (Cons v0 v1) = + let p = castPtr ptr + in St.pokeElemOff p 0 v0 >> + St.pokeElemOff p 1 v1 + +instance (TypeNum.Positive n, Storable.Vector a) => Storable.C (T n a) where + load ptrV = do + ptr <- castHalfPtr ptrV + liftA2 merge_ + (Storable.load ptr) + (Storable.load =<< Storable.incrementPtr ptr) + store v ptrV = do + let (v0,v1) = split_ v + ptr <- castHalfPtr ptrV + Storable.storeNext v0 ptr >>= Storable.store v1 + +castHalfPtr :: + LLVM.Value (Ptr (T n a)) -> + LLVM.CodeGenFunction r (LLVM.Value (Ptr (Vector n a))) +castHalfPtr = LLVM.bitcast + + +{- | +This instance allows to run @arrange@ on interleaved stereo vectors. +-} +instance + (TypeNum.Positive n, MultiVector.Additive a) => + MultiValue.Additive (T n a) where + add = zipV merge A.add + sub = zipV merge A.sub + neg = mapV A.neg + + +zero :: (TypeNum.Positive n, Additive.C a) => T n a +zero = Cons (pure Additive.zero) (pure Additive.zero) + + +scale :: + (TypeNum.Positive n, MultiVector.PseudoRing a) => + MultiValue.T a -> Value n a -> LLVM.CodeGenFunction r (Value n a) +scale a v = do + av <- MultiVector.replicate a + mapV (A.mul av) v + +amplify :: + (TypeNum.Positive n, MultiVector.PseudoRing a) => + a -> Value n a -> LLVM.CodeGenFunction r (Value n a) +amplify a = scale (MultiValue.cons a) + +envelope :: + (TypeNum.Positive n, MultiVector.PseudoRing a) => + Serial.Value n a -> Value n a -> LLVM.CodeGenFunction r (Value n a) +envelope e a = + zipV merge (flip A.mul) a =<< fromMono e + + +mapV :: (Applicative m) => + (MultiVector.T n a -> m (MultiVector.T n a)) -> + Value n a -> m (Value n a) +mapV f x = + case split x of + (x0,x1) -> uncurry merge <$> liftA2 (,) (f x0) (f x1) + +zipV :: (Applicative m) => + (c -> c -> d) -> + (MultiVector.T n a -> + MultiVector.T n b -> + m c) -> + Value n a -> + Value n b -> + m d +zipV g f x y = + case (split x, split y) of + ((x0,x1), (y0,y1)) -> liftA2 g (f x0 y0) (f x1 y1) diff --git a/src/Synthesizer/LLVM/Generator/Core.hs b/src/Synthesizer/LLVM/Generator/Core.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Generator/Core.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +module Synthesizer.LLVM.Generator.Core where + +import qualified Synthesizer.LLVM.Causal.Private as Causal +import qualified Synthesizer.LLVM.Generator.Private as Sig +import qualified Synthesizer.LLVM.Random as Rnd + +import Synthesizer.Causal.Class (($*)) + +import qualified LLVM.DSL.Expression as Expr +import LLVM.DSL.Expression (Exp) + +import qualified LLVM.Extra.Multi.Value.Marshal as Marshal +import qualified LLVM.Extra.Multi.Value as MultiValue +import qualified LLVM.Extra.Arithmetic as A + +import Control.Applicative ((<$>)) + +import Data.Word (Word32) + +import NumericPrelude.Numeric +import NumericPrelude.Base hiding (map, iterate, takeWhile, tail) + + + +type MV a = Sig.T (MultiValue.T a) + +iterate :: (Marshal.C a) => (Exp a -> Exp a) -> Exp a -> MV a +iterate f a = Sig.iterate (Expr.unliftM1 f) (Expr.unExp a) + +-- ToDo: replace by constantSharing and scanl +iterateParam :: + (Marshal.C a, Marshal.C b) => + (Exp b -> Exp a -> Exp a) -> Exp b -> Exp a -> MV a +iterateParam f b a = + MultiValue.snd <$> + iterate (Expr.uncurry $ \bi ai -> Expr.zip bi $ f bi ai) (Expr.zip b a) + + +ramp :: + (Marshal.C a, MultiValue.Additive a) => + Exp a -> Exp a -> MV a +ramp = iterateParam Expr.add + +parabola :: + (Marshal.C a, MultiValue.Additive a) => + Exp a -> Exp a -> Exp a -> MV a +parabola d2 d1 start = integrate start $* ramp d2 d1 + +integrate :: + (Marshal.C a, MultiValue.Additive a, MultiValue.T a ~ al) => + Exp a -> Causal.T al al +integrate start = + Causal.mapAccum (\a s -> (,) s <$> A.add s a) (Expr.unExp start) + + +osci :: + (MultiValue.Fraction t, Marshal.C t) => + Exp t -> Exp t -> MV t +osci phase freq = iterate (Expr.liftM2 A.incPhase freq) phase + +exponential :: + (Marshal.C a, MultiValue.PseudoRing a) => + Exp a -> Exp a -> MV a +exponential = iterateParam Expr.mul + +exponentialBounded :: + (Marshal.C a, MultiValue.PseudoRing a, + MultiValue.Real a, MultiValue.IntegerConstant a) => + Exp a -> Exp a -> Exp a -> MV a +exponentialBounded bound decay = + iterateParam + (\bk y -> case Expr.unzip bk of (b,k) -> Expr.max b $ k*y) + (Expr.zip bound decay) + + +noise, noiseAlt :: Exp Word32 -> MV Word32 +noise seed = + iterate (Expr.liftReprM Rnd.nextCG) + (Expr.irem seed (Expr.cons Rnd.modulus-1) + 1) + +noiseAlt seed = + iterate (Expr.liftReprM Rnd.nextCG32) + (Expr.irem seed (Expr.cons Rnd.modulus-1) + 1) diff --git a/src/Synthesizer/LLVM/Generator/Extra.hs b/src/Synthesizer/LLVM/Generator/Extra.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Generator/Extra.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE Rank2Types #-} +module Synthesizer.LLVM.Generator.Extra where + +import qualified Synthesizer.LLVM.Causal.Process as Causal +import qualified Synthesizer.LLVM.Generator.Signal as Sig +import Synthesizer.Causal.Class (($*)) + +import qualified LLVM.DSL.Expression as Expr +import LLVM.DSL.Expression (Exp) + +import qualified LLVM.Extra.Multi.Value.Marshal as Marshal +import qualified LLVM.Extra.Multi.Value as MultiValue + +import Data.Word (Word) + +import NumericPrelude.Numeric + + + +ramp, + parabolaFadeIn, parabolaFadeOut, + parabolaFadeInMap, parabolaFadeOutMap :: + (Marshal.C a, MultiValue.Field a, MultiValue.IntegerConstant a, + MultiValue.NativeFloating a ar) => + Exp Word -> Sig.MV a + +ramp dur = + Causal.take dur $* Sig.rampInf (Expr.fromIntegral dur) + +parabolaFadeIn dur = + Causal.take dur $* Sig.parabolaFadeInInf (Expr.fromIntegral dur) + +parabolaFadeOut dur = + Causal.take dur $* Sig.parabolaFadeOutInf (Expr.fromIntegral dur) + +parabolaFadeInMap dur = Causal.map (\t -> t*(2-t)) $* ramp dur +parabolaFadeOutMap dur = Causal.map (\t -> 1-t*t) $* ramp dur diff --git a/src/Synthesizer/LLVM/Generator/Private.hs b/src/Synthesizer/LLVM/Generator/Private.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Generator/Private.hs @@ -0,0 +1,201 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE Rank2Types #-} +module Synthesizer.LLVM.Generator.Private where + +import Synthesizer.LLVM.Private (getPairPtrs, noLocalPtr) + +import qualified LLVM.Extra.Memory as Memory +import qualified LLVM.Extra.MaybeContinuation as MaybeCont +import qualified LLVM.Extra.Arithmetic as A +import qualified LLVM.Extra.Tuple as Tuple + +import qualified LLVM.Core as LLVM +import LLVM.Core (CodeGenFunction) + +import Type.Base.Proxy (Proxy(Proxy)) + +import Control.Applicative (Applicative, liftA2, pure, (<*>), (<$>)) + +import Data.Semigroup (Semigroup, (<>)) +import Data.Tuple.Strict (mapFst, zipPair) + +import qualified Number.Ratio as Ratio +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import qualified Prelude as P +import Prelude hiding (iterate, takeWhile, map, zipWith) + + +data T a = + forall global local state. + (Memory.C global, LLVM.IsSized local, Memory.C state) => + Cons (forall r c. + (Tuple.Phi c) => + global -> + -- pointer to loop local storage + LLVM.Value (LLVM.Ptr local) -> + state -> MaybeCont.T r c (a, state)) + -- compute next value + (forall r. CodeGenFunction r (global, state)) + -- initial state + (forall r. global -> CodeGenFunction r ()) + -- cleanup + + +noGlobal :: + (LLVM.IsSized local, Memory.C state) => + (forall r c. + (Tuple.Phi c) => + LLVM.Value (LLVM.Ptr local) -> state -> MaybeCont.T r c (a, state)) -> + (forall r. CodeGenFunction r state) -> + T a +noGlobal next start = Cons (const next) (fmap ((,) ()) start) return + +alloca :: (LLVM.IsSized a) => T (LLVM.Value (LLVM.Ptr a)) +alloca = + noGlobal + (\ptr () -> return (ptr, ())) + (return ()) + + +iterate :: + (Memory.C a) => + (forall r. a -> CodeGenFunction r a) -> + (forall r. CodeGenFunction r a) -> T a +iterate f a = + noGlobal + (noLocalPtr $ \s -> fmap ((,) s) $ MaybeCont.lift $ f s) + a + +iterateParam :: + (Memory.C b, Memory.C a) => + (forall r. b -> a -> CodeGenFunction r a) -> + (forall r. CodeGenFunction r b) -> + (forall r. CodeGenFunction r a) -> T a +iterateParam f b a = + fmap snd $ iterate (\(bi,ai) -> (,) bi <$> f bi ai) (liftA2 (,) b a) + +takeWhile :: + (forall r. a -> CodeGenFunction r (LLVM.Value Bool)) -> T a -> T a +takeWhile p (Cons next start stop) = Cons + (\global local s0 -> do + (a,s1) <- next global local s0 + MaybeCont.guard =<< MaybeCont.lift (p a) + return (a,s1)) + start + stop + + +empty :: T a +empty = noGlobal (noLocalPtr $ \ _state -> MaybeCont.nothing) (return ()) + +{- | +Appending many signals is inefficient, +since in cascadingly appended signals the parts are counted in an unary way. +Concatenating infinitely many signals is impossible. +If you want to concatenate a lot of signals, +please render them to lazy storable vectors first. +-} +{- +We might save a little space by using a union +for the states of the first and the second signal generator. +If the concatenated generators allocate memory, +we could also save some memory by calling @startB@ +only after the first generator finished. +However, for correct deallocation +we would need to track which of the @start@ blocks +have been executed so far. +This in turn might be difficult in connection with the garbage collector. +-} +append :: (Tuple.Phi a, Tuple.Undefined a) => T a -> T a -> T a +append (Cons nextA startA stopA) (Cons nextB startB stopB) = Cons + (\(globalA, globalB) local (sa0,sb0,phaseB) -> do + (localA,localB) <- getPairPtrs local + MaybeCont.alternative + (do + MaybeCont.guard =<< MaybeCont.lift (LLVM.inv phaseB) + (a,sa1) <- nextA globalA localA sa0 + return (a, (sa1, sb0, LLVM.valueOf False))) + (do + (b,sb1) <- nextB globalB localB sb0 + return (b, (sa0, sb1, LLVM.valueOf True)))) + (do + (globalA,stateA) <- startA + (globalB,stateB) <- startB + return ((globalA,globalB), (stateA, stateB, LLVM.valueOf False))) + (\(globalA,globalB) -> stopB globalB >> stopA globalA) + +instance (Tuple.Phi a, Tuple.Undefined a) => Semigroup (T a) where + (<>) = append + +instance (Tuple.Phi a, Tuple.Undefined a) => Monoid (T a) where + mempty = empty + mappend = (<>) + + + +instance Functor T where + fmap f (Cons next start stop) = Cons + (\global local s -> mapFst f <$> next global local s) + start stop + +instance Applicative T where + pure a = noGlobal (noLocalPtr $ \() -> return (a, ())) (return ()) + Cons nextF startF stopF <*> Cons nextA startA stopA = Cons + (\(globalF, globalA) local (sf0,sa0) -> do + (localF,localA) <- getPairPtrs local + (f,sf1) <- nextF globalF localF sf0 + (a,sa1) <- nextA globalA localA sa0 + return (f a, (sf1,sa1))) + (liftA2 zipPair startF startA) + (\(globalF, globalA) -> stopA globalA >> stopF globalF) + + +map :: (forall r. a -> CodeGenFunction r b) -> T a -> T b +map f (Cons next start stop) = + Cons + (\global local sa0 -> do + (a,sa1) <- next global local sa0 + b <- MaybeCont.lift $ f a + return (b, sa1)) + start stop + +zipWith :: (forall r. a -> b -> CodeGenFunction r c) -> T a -> T b -> T c +zipWith f as bs = map (uncurry f) $ liftA2 (,) as bs + +instance (A.Additive a) => Additive.C (T a) where + zero = pure A.zero + negate = map A.neg + (+) = zipWith A.add + (-) = zipWith A.sub + +instance (A.PseudoRing a, A.IntegerConstant a) => Ring.C (T a) where + one = pure A.one + fromInteger n = pure (A.fromInteger' n) + (*) = zipWith A.mul + +instance (A.Field a, A.RationalConstant a) => Field.C (T a) where + fromRational' x = pure (A.fromRational' $ Ratio.toRational98 x) + (/) = zipWith A.fdiv + + +instance (A.PseudoRing a, A.Real a, A.IntegerConstant a) => P.Num (T a) where + fromInteger n = pure (A.fromInteger' n) + negate = map A.neg + (+) = zipWith A.add + (-) = zipWith A.sub + (*) = zipWith A.mul + abs = map A.abs + signum = map A.signum + +instance (A.Field a, A.Real a, A.RationalConstant a) => P.Fractional (T a) where + fromRational x = pure (A.fromRational' x) + (/) = zipWith A.fdiv + + + +arraySize :: value (array n a) -> Proxy n +arraySize _ = Proxy diff --git a/src/Synthesizer/LLVM/Generator/Render.hs b/src/Synthesizer/LLVM/Generator/Render.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Generator/Render.hs @@ -0,0 +1,298 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ForeignFunctionInterface #-} +module Synthesizer.LLVM.Generator.Render ( + -- * type driven + RunArg, DSLArg, + run, + runChunky, + runChunkyOnVector, + Render.Buffer, Render.buffer, + + -- * explicit argument converters + runExplicit, + build, -- ToDo: better name + WithShape, + + -- * utilities + Render.TimeInteger(Render.subdivideLong), -- ToDo: Is Render the right module to define this? + ) where + +import qualified Synthesizer.LLVM.Private.Render as Render +import qualified Synthesizer.LLVM.Causal.Parametric as Parametric +import qualified Synthesizer.LLVM.Generator.Source as Source +import Synthesizer.LLVM.Private.Render + (RunArg (DSLArg, buildArg), + Triple, tripleStruct, derefStartPtr, derefStopPtr) +import Synthesizer.LLVM.Generator.Private (T(Cons)) + +import qualified Synthesizer.LLVM.Storable.Vector as SVU +import qualified Synthesizer.LLVM.ForeignPtr as ForeignPtr + +import qualified Synthesizer.Causal.Class as CausalClass + +import qualified LLVM.DSL.Render.Run as Run +import qualified LLVM.DSL.Render.Argument as Arg +import qualified LLVM.DSL.Execution as Exec +import LLVM.DSL.Render.Run ((*->)) +import LLVM.DSL.Expression (Exp(Exp)) + +import qualified LLVM.Extra.Multi.Value.Storable as Storable +import qualified LLVM.Extra.Multi.Value.Marshal as Marshal +import qualified LLVM.Extra.Multi.Value as MultiValue +import qualified LLVM.Extra.Memory as Memory +import qualified LLVM.Extra.MaybeContinuation as MaybeCont +import qualified LLVM.Extra.Maybe as Maybe +import qualified LLVM.Extra.Tuple as Tuple + +import qualified LLVM.Core as LLVM + +import qualified Type.Data.Num.Decimal as TypeNum + +import qualified Data.StorableVector.Lazy as SVL +import qualified Data.StorableVector.Base as SVB +import qualified Data.StorableVector as SV + +import Control.Monad (join) +import Control.Applicative (liftA3) + +import Foreign.ForeignPtr (touchForeignPtr) +import Foreign.Ptr (Ptr) + +import Data.Functor.Compose (Compose (Compose, getCompose)) +import Data.Int (Int) +import Data.Word (Word) + +import qualified System.Unsafe as Unsafe + + +foreign import ccall safe "dynamic" derefFillPtr :: + Exec.Importer (LLVM.Ptr param -> Word -> Ptr struct -> IO Word) + + +compile :: + (Storable.C a, MultiValue.T a ~ value, + Marshal.C param, Marshal.Struct param ~ paramStruct) => + (Exp param -> T value) -> + IO (LLVM.Ptr paramStruct -> Word -> Ptr a -> IO Word) +compile sig = + Exec.compile "signal" $ + Exec.createFunction derefFillPtr "fill" $ \paramPtr size bPtr -> + case sig (Exp (Memory.load paramPtr)) of + Cons next start stop -> do + (global,s) <- start + local <- LLVM.alloca + (pos,_) <- Storable.arrayLoopMaybeCont size bPtr s $ \ ptri s0 -> do + (y,s1) <- next global local s0 + MaybeCont.lift $ Storable.store y ptri + return s1 + stop global + return pos + +runAux :: + (Marshal.C p, Storable.C a, MultiValue.T a ~ value) => + (Exp p -> T value) -> IO (IO () -> Int -> p -> IO (SV.Vector a)) +runAux sig = do + fill <- compile sig + return $ \final len param -> + Marshal.with param $ \paramPtr -> + SVB.createAndTrim len $ \ptr -> do + n <- fill paramPtr (fromIntegral len) ptr + final + return $ fromIntegral n + +_run :: + (Marshal.C p, Storable.C a, MultiValue.T a ~ value) => + (Exp p -> T value) -> IO (Int -> p -> IO (SV.Vector a)) +_run = fmap ($ return ()) . runAux + +foreign import ccall safe "dynamic" derefChunkPtr :: + Exec.Importer (LLVM.Ptr globalState -> Word -> Ptr a -> IO Word) + + +compileChunky :: + (LLVM.IsSized paramStruct, LLVM.Value (LLVM.Ptr paramStruct) ~ pPtr, + Memory.C state, Memory.Struct state ~ stateStruct, + Memory.C global, Memory.Struct global ~ globalStruct, + Triple paramStruct globalStruct stateStruct ~ triple, + LLVM.IsSized local, + Storable.C a, MultiValue.T a ~ value) => + (forall r z. (Tuple.Phi z) => + pPtr -> global -> LLVM.Value (LLVM.Ptr local) -> + () -> state -> MaybeCont.T r z (value, state)) -> + (forall r. pPtr -> LLVM.CodeGenFunction r (global, state)) -> + (forall r. pPtr -> global -> LLVM.CodeGenFunction r ()) -> + IO (LLVM.Ptr paramStruct -> IO (LLVM.Ptr triple), + Exec.Finalizer triple, + LLVM.Ptr triple -> Word -> Ptr a -> IO Word) +compileChunky next start stop = + Exec.compile "signal-chunky" $ + liftA3 (,,) + (Exec.createFunction derefStartPtr "startsignal" $ + \paramPtr -> do + paramGlobalStatePtr <- LLVM.malloc + (global,state) <- start paramPtr + flip LLVM.store paramGlobalStatePtr =<< + join + (liftA3 tripleStruct + (LLVM.load paramPtr) + (Memory.compose global) + (Memory.compose state)) + return paramGlobalStatePtr) + (Exec.createFinalizer derefStopPtr "stopsignal" $ + \paramGlobalStatePtr -> do + paramPtr <- + LLVM.getElementPtr0 paramGlobalStatePtr (TypeNum.d0, ()) + stop paramPtr =<< + Memory.load =<< + LLVM.getElementPtr0 paramGlobalStatePtr (TypeNum.d1, ()) + LLVM.free paramGlobalStatePtr) + (Exec.createFunction derefChunkPtr "fillsignal" $ + \paramGlobalStatePtr loopLen ptr -> do + paramPtr <- + LLVM.getElementPtr0 paramGlobalStatePtr (TypeNum.d0, ()) + global <- + Memory.load =<< + LLVM.getElementPtr0 paramGlobalStatePtr (TypeNum.d1, ()) + statePtr <- + LLVM.getElementPtr0 paramGlobalStatePtr (TypeNum.d2, ()) + sInit <- Memory.load statePtr + local <- LLVM.alloca + (pos,sExit) <- + Storable.arrayLoopMaybeCont loopLen ptr sInit $ + \ ptri s0 -> do + (y,s1) <- next paramPtr global local () s0 + MaybeCont.lift $ Storable.store y ptri + return s1 + Memory.store (Maybe.fromJust sExit) statePtr + return pos) + + +runChunkyAux :: + (Storable.C a, MultiValue.T a ~ value, Marshal.C p) => + (Exp p -> T value) -> IO (IO () -> SVL.ChunkSize -> p -> IO (SVL.Vector a)) +runChunkyAux sig = do + paramd <- + Parametric.fromProcessPtr "Signal.run" (CausalClass.fromSignal . sig) + case paramd of + Parametric.Cons next start stop -> do + (startFunc,stopFunc,fill) <- compileChunky next start stop + return $ \final (SVL.ChunkSize size) p -> do + statePtr <- ForeignPtr.newParamMV stopFunc startFunc p + + let go = + Unsafe.interleaveIO $ do + v <- + ForeignPtr.with statePtr $ \sptr -> + SVB.createAndTrim size $ + fmap (fromIntegral :: Word -> Int) . + fill sptr (fromIntegral size) + (if SV.length v > 0 + then fmap (v:) + else id) $ + (if SV.length v < size + then final >> return [] + else go) + fmap SVL.fromChunks go + +runChunky :: + (Storable.C a, MultiValue.T a ~ value, Marshal.C p) => + (Exp p -> T value) -> IO (SVL.ChunkSize -> p -> IO (SVL.Vector a)) +runChunky = fmap ($ return ()) . runChunkyAux + + +runChunkyOnVector :: + (Storable.C a, MultiValue.T a ~ al) => + (Storable.C b, MultiValue.T b ~ bl) => + (T al -> T bl) -> + IO (SVL.ChunkSize -> SV.Vector a -> IO (SVL.Vector b)) +runChunkyOnVector sig = do + f <- runChunkyAux (sig . Source.storableVector) + return $ \chunkSize av -> do + let (fp,ptr,l) = SVU.unsafeToPointers av + f (touchForeignPtr fp) chunkSize (Source.consStorableVector ptr l) + + + +type WithShape shape = Compose IO ((->) shape) + +class Run f where + type DSL f + type Shape f + build :: (Marshal.C p) => Run.T (WithShape (Shape f)) p (DSL f) f + +instance (Storable.C a) => Run (SVL.Vector a) where + type DSL (SVL.Vector a) = T (MultiValue.T a) + type Shape (SVL.Vector a) = SVL.ChunkSize + build = + Run.Cons $ + Compose . + fmap (\f shape create -> Unsafe.performIO $ buildIOGen f shape create) . + runChunkyAux + +instance (Storable.C a) => Run (SV.Vector a) where + type DSL (SV.Vector a) = T (MultiValue.T a) + type Shape (SV.Vector a) = Int + build = + Run.Cons $ + Compose . + fmap (\f shape create -> Unsafe.performIO $ buildIOGen f shape create) . + runAux + +instance (RunIO a) => Run (IO a) where + type DSL (IO a) = T (DSL_IO a) + type Shape (IO a) = ShapeIO a + build = buildIO + +instance (RunArg a, Run f) => Run (a -> f) where + type DSL (a -> f) = DSLArg a -> DSL f + type Shape (a -> f) = Shape f + build = buildArg *-> build + + +class RunIO a where + type DSL_IO a + type ShapeIO a + buildIO :: + (Marshal.C p) => Run.T (WithShape (ShapeIO a)) p (T (DSL_IO a)) (IO a) + +instance (Storable.C a) => RunIO (SVL.Vector a) where + type DSL_IO (SVL.Vector a) = MultiValue.T a + type ShapeIO (SVL.Vector a) = SVL.ChunkSize + buildIO = Run.Cons $ Compose . fmap buildIOGen . runChunkyAux + +instance (Storable.C a) => RunIO (SV.Vector a) where + type DSL_IO (SV.Vector a) = MultiValue.T a + type ShapeIO (SV.Vector a) = Int + buildIO = Run.Cons $ Compose . fmap buildIOGen . runAux + +buildIOGen :: + (Monad m) => (final -> shape -> p -> m a) -> shape -> m (p, final) -> m a +buildIOGen f shape create = do (p,final) <- create; f final shape p + + + +{- +do f <- run (\n -> takeWhile (<*n) (iterate (1+) 0) <> takeWhile (<*n) (iterate (2+) 0)); f SVL.defaultChunkSize (12::Float) :: IO (SVL.Vector Float) +do f <- Sig.run (\n -> Sig.takeWhile (Expr.<*n) (Sig.iterate (1+) 0) <> Sig.takeWhile (Expr.<*n) (Sig.iterate (2+) 0)); f SVL.defaultChunkSize (12::Float) :: IO (SVL.Vector Float) +-} +run :: (Run f) => DSL f -> IO (Shape f -> f) +run = runExplicit build + +{- +ToDo: +Export it, but we also need to export 'build' then. +To this end we should define a nice data type for 'build'. +-} +runExplicit :: + Run.T (WithShape (Shape f)) () fdsl f -> + fdsl -> IO (Shape f -> f) +runExplicit builder sig = + getCompose $ Run.run builder sig + +_exampleExplicit :: + (Exp Float -> Exp Word -> T (MultiValue.T Float)) -> + IO (Int -> Float -> Word -> SV.Vector Float) +_exampleExplicit = runExplicit (Arg.primitive *-> Arg.primitive *-> build) diff --git a/src/Synthesizer/LLVM/Generator/Signal.hs b/src/Synthesizer/LLVM/Generator/Signal.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Generator/Signal.hs @@ -0,0 +1,345 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE Rank2Types #-} +module Synthesizer.LLVM.Generator.Signal ( + Sig.T, + MV, + + constant, + fromArray, + Core.iterate, + takeWhile, + take, + tail, + drop, + Sig.append, + cycle, + + amplify, + + osci, + exponential2, + exponentialBounded2, + noise, + + adjacentNodes02, + adjacentNodes13, + interpolateConstant, + + rampSlope, + rampInf, + ramp, + parabolaFadeInInf, + parabolaFadeOutInf, + parabolaFadeIn, + parabolaFadeOut, + parabolaFadeInMap, + parabolaFadeOutMap, + ) where + +import qualified Synthesizer.LLVM.Causal.Private as Causal +import qualified Synthesizer.LLVM.Generator.Core as Core +import qualified Synthesizer.LLVM.Generator.Private as Sig +import qualified Synthesizer.LLVM.Interpolation as Interpolation +import qualified Synthesizer.LLVM.Frame as Frame +import qualified Synthesizer.LLVM.Random as Rnd +import Synthesizer.LLVM.Generator.Private (arraySize) +import Synthesizer.LLVM.Private (noLocalPtr) + +import qualified Synthesizer.Causal.Class as CausalC +import Synthesizer.Causal.Class (apply, ($*), ($<)) + +import qualified LLVM.DSL.Expression as Expr +import LLVM.DSL.Expression (Exp) + +import qualified LLVM.Extra.Multi.Value.Marshal as Marshal +import qualified LLVM.Extra.Multi.Value as MultiValue +import qualified LLVM.Extra.Iterator as Iter +import qualified LLVM.Extra.MaybeContinuation as MaybeCont +import qualified LLVM.Extra.Memory as Memory +import qualified LLVM.Extra.Arithmetic as A +import qualified LLVM.Extra.Tuple as Tuple + +import qualified LLVM.Core as LLVM +import LLVM.Core (CodeGenFunction) + +import qualified Type.Data.Num.Decimal.Number as TypeNum +import Type.Data.Num.Decimal.Number ((:*:)) + +import Control.Monad.HT ((<=<)) +import Control.Applicative (liftA2) + +import Data.Word (Word32, Word) +import Data.Int (Int32) + +import NumericPrelude.Numeric +import NumericPrelude.Base hiding + (map, iterate, takeWhile, take, tail, drop, cycle) + + + +type MV a = Sig.T (MultiValue.T a) + +constant :: (Expr.Aggregate ae al, Memory.C al) => ae -> Sig.T al +constant a = Sig.iterate return (Expr.bundle a) + + +fromArray :: + (TypeNum.Natural n, Marshal.C a) => + ((n :*: LLVM.SizeOf (Marshal.Struct a)) ~ arrSize, + TypeNum.Natural arrSize) => + Exp (MultiValue.Array n a) -> MV a +fromArray arrExp = Sig.Cons + (\arrPtr -> noLocalPtr $ \i -> do + inRange <- MaybeCont.lift $ + LLVM.cmp LLVM.CmpLT i $ LLVM.valueOf $ + TypeNum.integralFromProxy $ arraySize arrExp + MaybeCont.guard inRange + MaybeCont.lift $ do + ptr <- LLVM.getElementPtr0 arrPtr (i, ()) + liftA2 (,) (Memory.load ptr) (A.inc i)) + (do + arrPtr <- LLVM.malloc + flip Memory.store arrPtr =<< Expr.unExp arrExp + return (arrPtr, A.zero :: LLVM.Value Word)) + LLVM.free + + +takeWhile :: (Expr.Aggregate ae a) => (ae -> Exp Bool) -> Sig.T a -> Sig.T a +takeWhile p = + Sig.takeWhile (fmap (\(MultiValue.Cons cont) -> cont) . Expr.unliftM1 p) + +take :: Exp Word -> Sig.T a -> Sig.T a +take len = + liftA2 (flip const) $ takeWhile (0 Expr.<*) (Core.iterate (subtract 1) len) + +{- | +@tail empty@ generates the empty signal. +-} +tail :: Sig.T a -> Sig.T a +tail (Sig.Cons next start stop) = Sig.Cons + next + (do + local <- LLVM.alloca + (global,s0) <- start + MaybeCont.resolve (next global local s0) + (return (global,s0)) + (\(_a,s1) -> return (global,s1))) + stop + +drop :: Exp Word -> Sig.T a -> Sig.T a +drop n (Sig.Cons next start stop) = Sig.Cons + next + (do + local <- LLVM.alloca + (global,state0) <- start + ~(MultiValue.Cons nv) <- Expr.unExp n + state1 <- + Iter.mapWhileState_ + (\_ s0 -> + MaybeCont.resolve (next global local s0) + (return (LLVM.valueOf False, s0)) + (\(_a,s1) -> return (LLVM.valueOf True, s1))) + (Iter.countDown nv) state0 + return (global,state1)) + stop + + +{- | +> cycle empty == empty +-} +cycle :: (Tuple.Phi a, Tuple.Undefined a) => Sig.T a -> Sig.T a +cycle (Sig.Cons next start stop) = + Sig.Cons + (\globalPtr local s0 -> + MaybeCont.alternative + (do + c0 <- MaybeCont.lift $ Memory.load globalPtr + next c0 local s0) + (do + (c1,s1) <- MaybeCont.lift $ do + stop =<< Memory.load globalPtr + cs1 <- start + Memory.store (fst cs1) globalPtr + return cs1 + next c1 local s1)) + (do + globalPtr <- LLVM.malloc + (global,state) <- start + Memory.store global globalPtr + return (globalPtr, state)) + (\globalPtr -> do + stop =<< Memory.load globalPtr + LLVM.free globalPtr) + + +amplify :: + (Expr.Aggregate ea a, Memory.C a, A.PseudoRing a) => + ea -> Sig.T a -> Sig.T a +amplify x = apply (Causal.zipWith Frame.amplifyMono $< constant x) + + +rampInf, rampSlope, + parabolaFadeInInf, parabolaFadeOutInf :: + (Marshal.C a, MultiValue.Field a, MultiValue.IntegerConstant a) => + Exp a -> MV a +rampSlope slope = Core.ramp slope Expr.zero +rampInf dur = rampSlope (Expr.recip dur) + +{- +t*(2-t) = 1 - (t-1)^2 + +(t+d)*(2-t-d) - t*(2-t) + = d*(2-t) - d*t - d^2 + = 2*d*(1-t) - d^2 + = d*(2*(1-t) - d) + +2*d*(1-t-d) + d^2 - (2*d*(1-t) + d^2) + = -2*d^2 +-} +parabolaFadeInInf dur = + Core.parabola + ((\d -> -2*d*d) $ Expr.recip dur) + ((\d -> d*(2-d)) $ Expr.recip dur) + Expr.zero + +{- +1-t^2 +-} +parabolaFadeOutInf dur = + Core.parabola + ((\d -> -2*d*d) $ Expr.recip dur) + ((\d -> -d*d) $ Expr.recip dur) + Expr.one + +ramp, + parabolaFadeIn, parabolaFadeOut, + parabolaFadeInMap, parabolaFadeOutMap :: + (Marshal.C a, MultiValue.Field a, MultiValue.IntegerConstant a, + MultiValue.NativeFloating a ar) => + Exp Word -> MV a + +ramp dur = + take dur $ rampInf (Expr.fromIntegral dur) + +parabolaFadeIn dur = + take dur $ parabolaFadeInInf (Expr.fromIntegral dur) + +parabolaFadeOut dur = + take dur $ parabolaFadeOutInf (Expr.fromIntegral dur) + +parabolaFadeInMap dur = + Causal.map (Expr.unliftM1 (\t -> t*(2-t))) $* ramp dur + +parabolaFadeOutMap dur = + Causal.map (Expr.unliftM1 (\t -> 1-t*t)) $* ramp dur + + +osci :: + (MultiValue.Fraction t, Marshal.C t) => + (forall r. MultiValue.T t -> CodeGenFunction r y) -> + Exp t -> Exp t -> Sig.T y +osci wave phase freq = Causal.map wave $* Core.osci phase freq + + +exponential2 :: + (Marshal.C a) => + (MultiValue.Real a) => + (MultiValue.RationalConstant a) => + (MultiValue.Transcendental a) => + Exp a -> Exp a -> MV a +exponential2 halfLife = Core.exponential (1 / 2 ** recip halfLife) + +exponentialBounded2 :: + (Marshal.C a) => + (MultiValue.Real a) => + (MultiValue.RationalConstant a) => + (MultiValue.Transcendental a) => + Exp a -> Exp a -> Exp a -> MV a +exponentialBounded2 bound halfLife = + Core.exponentialBounded bound (1 / 2 ** recip halfLife) + + +{- | +@noise seed rate@ + +The @rate@ parameter is for adjusting the amplitude +such that it is uniform across different sample rates +and after frequency filters. +The @rate@ is the ratio of the current sample rate to the default sample rate, +where the variance of the samples would be one. +If you want that at sample rate 22050 the variance is 1, +then in order to get a consistent volume at sample rate 44100 +you have to set @rate = 2@. + +I use the variance as quantity and not the amplitude, +because the amplitude makes only sense for uniformly distributed samples. +However, frequency filters transform the probabilistic density of the samples +towards the normal distribution according to the central limit theorem. +-} +noise :: + (Marshal.C a, MultiValue.Transcendental a, MultiValue.RationalConstant a, + MultiValue.NativeFloating a ar) => + Exp Word32 -> Exp a -> MV a +noise seed rate = + let m2 = Expr.fromInteger' $ div Rnd.modulus 2 + r = sqrt (3 * rate) / m2 + in Causal.map (Expr.unliftM1 (\y -> r * (int31tofp y - (m2+1)))) $* + Core.noise seed + +{- +sitofp is a single instruction on x86 +and thus we use it, since the arguments are below 2^31. +-} +int31tofp :: + (MultiValue.NativeFloating a ar) => + Exp Word32 -> Exp a +int31tofp = + Expr.liftM + (MultiValue.fromIntegral <=< + (MultiValue.liftM LLVM.bitcast :: + MultiValue.T Word32 -> CodeGenFunction r (MultiValue.T Int32))) + + +adjacentNodes02 :: + (Memory.C a) => + Sig.T a -> Sig.T (Interpolation.Nodes02 a) +adjacentNodes02 = + tail + . + apply + (Causal.mapAccum + (\new old -> return (Interpolation.Nodes02 old new, new)) + (return Tuple.undef)) + +adjacentNodes13 :: + (Marshal.C a, MultiValue.T a ~ al) => + Exp a -> Sig.T al -> Sig.T (Interpolation.Nodes13 al) +adjacentNodes13 yp0 = + tail . + tail . + apply + (Causal.mapAccum + (\new (x0, x1, x2) -> + return (Interpolation.Nodes13 x0 x1 x2 new, (x1, x2, new))) + (do + y0 <- Expr.unExp yp0 + return (MultiValue.undef, MultiValue.undef, y0))) + + +{- | +Stretch signal in time by a certain factor. + +This can be used for doing expensive computations +of filter parameters at a lower rate. +Alternatively, we could provide an adaptive @map@ +that recomputes output values only if the input value changes, +or if the input value differs from the last processed one by a certain amount. +-} +interpolateConstant :: + (Memory.C a, Marshal.C b, MultiValue.IntegerConstant b, + MultiValue.Additive b, MultiValue.Comparison b) => + Exp b -> Sig.T a -> Sig.T a +interpolateConstant k sig = + CausalC.toSignal (Causal.quantizeLift (CausalC.fromSignal sig) $< constant k) diff --git a/src/Synthesizer/LLVM/Generator/SignalPacked.hs b/src/Synthesizer/LLVM/Generator/SignalPacked.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Generator/SignalPacked.hs @@ -0,0 +1,351 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE FlexibleContexts #-} +{- | +Signal generators that generate the signal in chunks +that can be processed natively by the processor. +Some of the functions for plain signals can be re-used without modification. +E.g. rendering a signal and reading from and to signals work +because the vector type as element type warrents correct alignment. +We can convert between atomic and chunked signals. + +The article + +explains the difference between Vector and SIMD computing. +According to that the SSE extensions in Intel processors +must be called Vector computing. +But since we use the term Vector already in the mathematical sense, +I like to use the term "packed" that is used in Intel mnemonics like mulps. +-} +module Synthesizer.LLVM.Generator.SignalPacked ( + pack, packRotate, + packSmall, + unpack, unpackRotate, + constant, + exponential2, + exponentialBounded2, + osciCore, + osci, + parabolaFadeInInf, parabolaFadeOutInf, + rampInf, rampSlope, + noise, + noiseCore, noiseCoreAlt, + ) where + +import qualified Synthesizer.LLVM.Causal.Process as Causal +import qualified Synthesizer.LLVM.Generator.Private as Priv +import qualified Synthesizer.LLVM.Generator.Core as Core +import qualified Synthesizer.LLVM.Generator.Signal as Sig +import qualified Synthesizer.LLVM.Frame.SerialVector.Class as SerialClass +import qualified Synthesizer.LLVM.Frame.SerialVector.Code as SerialCode +import qualified Synthesizer.LLVM.Frame.SerialVector as Serial +import qualified Synthesizer.LLVM.Random as Rnd + +import Synthesizer.Causal.Class (($*)) + +import qualified LLVM.DSL.Expression as Expr +import LLVM.DSL.Expression (Exp) + +import qualified LLVM.Extra.Multi.Vector as MultiVector +import qualified LLVM.Extra.Multi.Value.Marshal as Marshal +import qualified LLVM.Extra.Multi.Value.Vector as MultiValueVec +import qualified LLVM.Extra.Multi.Value as MultiValue +import qualified LLVM.Extra.Memory as Memory +import qualified LLVM.Extra.MaybeContinuation as Maybe +import qualified LLVM.Extra.Control as U +import qualified LLVM.Extra.Arithmetic as A +import qualified LLVM.Extra.Tuple as Tuple + +import qualified Type.Data.Num.Decimal as TypeNum +import Type.Data.Num.Decimal ((:*:)) + +import qualified LLVM.Core as LLVM + +import qualified Control.Monad.Trans.Class as MT +import qualified Control.Monad.Trans.State as MS +import Control.Monad.HT ((<=<)) +import Control.Monad (replicateM) +import Control.Applicative ((<$>)) + +import qualified Algebra.Ring as Ring + +import Data.Tuple.HT (mapSnd) +import Data.Word (Word32, Word) +import Data.Int (Int32) + +import NumericPrelude.Numeric +import NumericPrelude.Base + + + +{- | +Convert a signal of scalar values into one using processor vectors. +If the signal length is not divisible by the chunk size, +then the last chunk is dropped. +-} +pack, packRotate :: + (SerialClass.Write v, a ~ SerialClass.Element v) => + Sig.T a -> Sig.T v +pack = packRotate + +packRotate (Priv.Cons next start stop) = Priv.Cons + (\global local s -> do + wInit <- Maybe.lift $ SerialClass.writeStart + (w2,_,s2) <- + Maybe.fromBool $ + U.whileLoop + (LLVM.valueOf True, + (wInit, + LLVM.valueOf $ (SerialClass.sizeOfIterator wInit :: Word), + s)) + (\(cont,(_w0,i0,_s0)) -> + A.and cont =<< + A.cmp LLVM.CmpGT i0 A.zero) + (\(_,(w0,i0,s0)) -> Maybe.toBool $ do + (a,s1) <- next global local s0 + Maybe.lift $ do + w1 <- SerialClass.writeNext a w0 + i1 <- A.dec i0 + return (w1,i1,s1)) + v <- Maybe.lift $ SerialClass.writeStop w2 + return (v, s2)) + start + stop + +{- +We could reformulate it in terms of WriteIterator +that accesses elements using LLVM.extract. +We might move the loop counter into the Iterator, +but we have to assert that the counter is not duplicated. + +packIndex :: + (SerialClass.Write v, a ~ SerialClass.Element v) => + Sig.T a -> Sig.T v +packIndex = alter (\(Core next start stop) -> Core + (\param s -> do + (v2,_,s2) <- + Maybe.fromBool $ + U.whileLoop + (LLVM.valueOf True, (Tuple.undef, A.zero, s)) + (\(cont,(v0,i0,_s0)) -> + A.and cont =<< + A.cmp LLVM.CmpLT i0 (LLVM.valueOf $ SerialClass.size v0)) + (\(_,(v0,i0,s0)) -> Maybe.toBool $ do + (a,s1) <- next param s0 + Maybe.lift $ do + v1 <- Vector.insert i0 a v0 + i1 <- A.inc i0 + return (v1,i1,s1)) + return (v2, s2)) + start + stop) +-} + + +{- | +Like 'pack' but duplicates the code for creating elements. +That is, for vectors of size n, the code of the input signal +will be emitted n times. +This is efficient only for simple input generators. +-} +packSmall :: + (SerialClass.Write v, a ~ SerialClass.Element v) => + Sig.T a -> Sig.T v +packSmall (Priv.Cons next start stop) = Priv.Cons + (\global local -> + MS.runStateT $ + SerialClass.withSize $ \n -> + MT.lift . Maybe.lift . SerialClass.assemble + =<< + replicateM n (MS.StateT $ next global local)) + start + stop + + +unpack, unpackRotate :: + (SerialClass.Read v, a ~ SerialClass.Element v, + SerialClass.ReadIt v ~ itv, Memory.C itv) => + Sig.T v -> Sig.T a +unpack = unpackRotate + +unpackRotate (Priv.Cons next start stop) = Priv.Cons + (\global local (i0,r0,s0) -> do + endOfVector <- + Maybe.lift $ A.cmp LLVM.CmpEQ i0 (LLVM.valueOf (0::Word)) + (i2,r2,s2) <- + Maybe.fromBool $ + U.ifThen endOfVector (LLVM.valueOf True, (i0,r0,s0)) $ do + (cont1, (v1,s1)) <- Maybe.toBool $ next global local s0 + r1 <- SerialClass.readStart v1 + return (cont1, (LLVM.valueOf $ SerialClass.size v1, r1, s1)) + Maybe.lift $ do + (a,r3) <- SerialClass.readNext r2 + i3 <- A.dec i2 + return (a, (i3,r3,s2))) + (mapSnd (\s -> (A.zero, Tuple.undef, s)) <$> start) + stop + + +{- +We could reformulate it in terms of ReadIterator +that accesses elements using LLVM.extract. +We might move the loop counter into the Iterator, +but we have to assert that the counter is not duplicated. + +unpackIndex :: + (SerialClass.Write v, a ~ SerialClass.Element v, Memory.C v) => + Sig.T v -> Sig.T a +unpackIndex = alter (\(Core next start stop) -> Core + (\param (i0,v0,s0) -> do + endOfVector <- + Maybe.lift $ A.cmp LLVM.CmpGE i0 (LLVM.valueOf $ SerialClass.size v0) + (i2,v2,s2) <- + Maybe.fromBool $ + U.ifThen endOfVector (LLVM.valueOf True, (i0,v0,s0)) $ do + (cont1, (v1,s1)) <- Maybe.toBool $ next param s0 + return (cont1, (A.zero, v1, s1)) + Maybe.lift $ do + a <- Vector.extract i2 v2 + i3 <- A.inc i2 + return (a, (i3,v2,s2))) + (\p -> do + s <- start p + let v = Tuple.undef + return (LLVM.valueOf $ SerialClass.size v, v, s)) + stop) +-} + + + +type Serial n a = SerialCode.Value n a + +withSize :: + (TypeNum.Positive n) => + (TypeNum.Singleton n -> Sig.T (Serial n a)) -> + Sig.T (Serial n a) +withSize f = f TypeNum.singleton + +withSizeRing :: + (Ring.C b, TypeNum.Positive n) => + (b -> Sig.T (Serial n a)) -> + Sig.T (Serial n a) +withSizeRing f = + withSize $ f . fromInteger . TypeNum.integerFromSingleton + + +constant :: + (Marshal.Vector n a) => + Exp a -> Sig.T (Serial n a) +constant = Sig.constant . Serial.upsample + + +exponential2 :: + (Marshal.Vector n a, MultiVector.Transcendental a, + MultiValue.RationalConstant a) => + Exp a -> Exp a -> Sig.T (Serial n a) +exponential2 halfLife start = withSizeRing $ \n -> + Core.exponential + (Serial.upsample (0.5 ** (n / halfLife))) + (Serial.iterate (0.5 ** recip halfLife *) start) + +exponentialBounded2 :: + (Marshal.Vector n a, MultiVector.Transcendental a, + MultiValue.RationalConstant a, + MultiVector.IntegerConstant a, MultiVector.Real a) => + Exp a -> Exp a -> Exp a -> Sig.T (Serial n a) +exponentialBounded2 bound halfLife start = withSizeRing $ \n -> + Core.exponentialBounded + (Serial.upsample bound) + (Serial.upsample (0.5 ** (n / halfLife))) + (Serial.iterate (0.5 ** recip halfLife *) start) + +osciCore :: + (Marshal.Vector n t, MultiVector.PseudoRing t, MultiVector.Fraction t, + MultiValue.IntegerConstant t) => + Exp t -> Exp t -> Sig.T (Serial n t) +osciCore phase freq = withSizeRing $ \n -> + Core.osci + (Serial.iterate (Expr.fraction . (freq +)) phase) + (Serial.upsample (Expr.fraction (n * freq))) + +osci :: + (Marshal.Vector n t, MultiVector.PseudoRing t, MultiVector.Fraction t, + MultiValue.IntegerConstant t) => + (forall r. Serial n t -> LLVM.CodeGenFunction r y) -> + Exp t -> Exp t -> Sig.T y +osci wave phase freq = Priv.map wave $ osciCore phase freq + + +rampInf, rampSlope, parabolaFadeInInf, parabolaFadeOutInf :: + (Marshal.Vector n a, MultiVector.Field a, MultiVector.IntegerConstant a, + MultiValue.RationalConstant a) => + Exp a -> Sig.T (Serial n a) +rampSlope slope = withSizeRing $ \n -> + Core.ramp + (Serial.upsample (n * slope)) + (Serial.iterate (slope +) 0) +rampInf dur = rampSlope (Expr.recip dur) + +parabolaFadeInInf dur = withSizeRing $ \n -> + let d = n/dur + in Core.parabola + (Serial.upsample (-2*d*d)) + (Serial.iterate (subtract $ 2 / dur ^ 2) (d*(2-d))) + ((\t -> t*(2-t)) $ Serial.iterate (recip dur +) 0) + +parabolaFadeOutInf dur = withSizeRing $ \n -> + let d = n/dur + in Core.parabola + (Serial.upsample (-2*d*d)) + (Serial.iterate (subtract $ 2 / dur ^ 2) (-d*d)) + ((\t -> 1-t*t) $ Serial.iterate (recip dur +) 0) + + +{- | +For the mysterious rate parameter see 'Sig.noise'. +-} +noise :: + (MultiVector.NativeFloating n a ar) => + (MultiVector.PseudoRing a, MultiVector.IntegerConstant a) => + (MultiValue.Algebraic a, MultiValue.RationalConstant a) => + (TypeNum.Positive n, TypeNum.Positive (n :*: TypeNum.D32)) => + Exp Word32 -> Exp a -> Sig.T (Serial n a) +noise seed rate = + let m2 = div Rnd.modulus 2 + r = Serial.upsample $ Expr.sqrt (3*rate) / Expr.fromInteger' m2 + in Causal.map + (\y -> r * (Expr.liftM int31tofp y - Expr.fromInteger' (m2+1))) $* + noiseCoreAlt seed + +{- +sitofp is a single instruction on x86 +and thus we use it, since the arguments are below 2^31. + +It would be better to use LLVM's range annotation, instead. +-} +int31tofp :: + (MultiVector.NativeFloating n a ar, + TypeNum.Positive n, TypeNum.Positive (n :*: TypeNum.D32)) => + Serial n Word32 -> LLVM.CodeGenFunction r (Serial n a) +int31tofp = + fmap SerialCode.fromOrdinary . MultiValueVec.fromIntegral . + SerialCode.toOrdinary . forceInt32 + <=< MultiValue.liftM LLVM.bitcast + +type Id a = a -> a + +forceInt32 :: Id (Serial n Int32) +forceInt32 = id + +noiseCore, noiseCoreAlt :: + (TypeNum.Positive n, TypeNum.Positive (n :*: TypeNum.D32)) => + Exp Word32 -> Sig.T (Serial n Word32) +noiseCore = Sig.iterate (Expr.liftReprM Rnd.nextVector) . vectorSeed +noiseCoreAlt = Sig.iterate (Expr.liftReprM Rnd.nextVector64) . vectorSeed + +vectorSeed :: (TypeNum.Positive n) => Exp Word32 -> Exp (Serial.T n Word32) +vectorSeed seed = + Serial.iterate (Expr.liftReprM Rnd.nextCG) $ + Expr.irem seed (fromInteger Rnd.modulus - 1) + 1 diff --git a/src/Synthesizer/LLVM/Generator/Source.hs b/src/Synthesizer/LLVM/Generator/Source.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Generator/Source.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE TypeFamilies #-} +module Synthesizer.LLVM.Generator.Source where + +import qualified Synthesizer.LLVM.Storable.ChunkIterator as ChunkIt +import qualified Synthesizer.LLVM.Storable.LazySizeIterator as SizeIt +import qualified Synthesizer.LLVM.Generator.Private as Sig +import qualified Synthesizer.LLVM.ConstantPiece as Const +import qualified Synthesizer.LLVM.EventIterator as EventIt +import Synthesizer.LLVM.Private (noLocalPtr) + +import qualified LLVM.DSL.Expression as Expr +import LLVM.DSL.Expression (Exp) + +import qualified LLVM.Extra.Multi.Value.Storable as Storable +import qualified LLVM.Extra.Multi.Value.Marshal as Marshal +import qualified LLVM.Extra.Multi.Value as MultiValue +import qualified LLVM.Extra.MaybeContinuation as MaybeCont +import qualified LLVM.Extra.Memory as Memory +import qualified LLVM.Extra.Arithmetic as A +import qualified LLVM.Extra.Control as C + +import qualified LLVM.Core as LLVM + +import Foreign.Storable (Storable) +import Foreign.StablePtr (StablePtr) +import Foreign.Ptr (Ptr, nullPtr) + +import Control.Applicative (liftA2, (<$>)) + +import Data.Tuple.HT (mapSnd) +import Data.Word (Word) + + +type T a = Sig.T (MultiValue.T a) + + +data StorableVector a = StorableVector (Ptr a) Word + +storableVectorLength :: Exp (StorableVector a) -> Exp Word +storableVectorLength = Expr.lift1 (MultiValue.lift1 (\(_ptr,l) -> l)) + +consStorableVector :: Ptr a -> Int -> StorableVector a +consStorableVector p = StorableVector p . fromIntegral + +instance (Storable a) => MultiValue.C (StorableVector a) where + type Repr (StorableVector a) = (LLVM.Value (Ptr a), LLVM.Value Word) + cons (StorableVector p l) = MultiValue.Cons (LLVM.valueOf p, LLVM.valueOf l) + undef = MultiValue.undefTuple + zero = MultiValue.zeroTuple + phi = MultiValue.phiTuple + addPhi = MultiValue.addPhiTuple + +instance (Storable a) => Marshal.C (StorableVector a) where + pack (StorableVector p l) = LLVM.consStruct p l + unpack = LLVM.uncurryStruct StorableVector + +storableVector :: (Storable.C a) => Exp (StorableVector a) -> T a +storableVector vec = + Sig.noGlobal + (noLocalPtr $ \(p0,l0) -> do + cont <- MaybeCont.lift $ A.cmp LLVM.CmpGT l0 A.zero + MaybeCont.withBool cont $ do + y1 <- Storable.load p0 + p1 <- Storable.incrementPtr p0 + l1 <- A.dec l0 + return (y1,(p1,l1))) + (fmap (\(MultiValue.Cons (p,l)) -> (p,l)) (Expr.unExp vec)) + + +{- +This function calls back into the Haskell function 'ChunkIt.next' +that returns a pointer to the data of the next chunk +and advances to the next chunk in the sequence. +-} +storableVectorLazy :: + (Storable.C a) => Exp (StablePtr (ChunkIt.T a)) -> T a +storableVectorLazy = flattenChunks . storableVectorChunks + +type Chunk a = (LLVM.Value (Ptr a), LLVM.Value Word) + +storableVectorChunks :: + (Storable.C a) => Exp (StablePtr (ChunkIt.T a)) -> Sig.T (Chunk a) +storableVectorChunks sig = + Sig.Cons + (\stable lenPtr () -> MaybeCont.fromBool $ do + nextChunkFn <- + LLVM.staticNamedFunction + "SignalExp.fromStorableVectorLazy.nextChunk" + ChunkIt.nextCallBack + (buffer,len) <- + liftA2 (,) + (LLVM.call nextChunkFn stable lenPtr) + (LLVM.load lenPtr) + valid <- A.cmp LLVM.CmpNE buffer (LLVM.valueOf nullPtr) + return (valid, ((buffer,len), ()))) + (fmap (\(MultiValue.Cons it) -> (it, ())) $ Expr.unExp sig) + (\ _it -> return ()) + +flattenChunks :: (Storable.C a) => Sig.T (Chunk a) -> T a +flattenChunks (Sig.Cons next start stop) = + Sig.Cons + (\global local ((buffer0,length0), state0) -> do + ((buffer1,length1), state1) <- MaybeCont.fromBool $ do + needNext <- A.cmp LLVM.CmpEQ length0 A.zero + C.ifThen needNext + (LLVM.valueOf True, ((buffer0,length0), state0)) + (MaybeCont.toBool $ next global local state0) + MaybeCont.lift $ do + x <- Storable.load buffer1 + buffer2 <- Storable.incrementPtr buffer1 + length2 <- A.dec length1 + return (x, ((buffer2,length2), state1))) + (mapSnd ((,) (LLVM.valueOf nullPtr, A.zero)) <$> start) + stop + + +eventList :: + (Marshal.C a) => + Exp (StablePtr (EventIt.T a)) -> Sig.T (Const.T (MultiValue.T a)) +eventList sig = + Sig.Cons + -- FixMe: duplicate of ConstantPiece.piecewiseConstant + (\stable yPtr () -> do + len <- MaybeCont.lift $ do + nextFn <- + LLVM.staticNamedFunction + "ConstantPiece.piecewiseConstant.nextChunk" + EventIt.nextCallBack + LLVM.call nextFn stable yPtr + MaybeCont.guard =<< MaybeCont.lift (A.cmp LLVM.CmpNE len A.zero) + y <- MaybeCont.lift $ Memory.load yPtr + return (Const.Cons len y, ())) + (fmap (\(MultiValue.Cons it) -> (it, ())) $ Expr.unExp sig) + (\ _it -> return ()) + +lazySize :: Exp (StablePtr SizeIt.T) -> Sig.T (Const.T ()) +lazySize size = Sig.Cons + (\stable -> noLocalPtr $ \() -> do + len <- MaybeCont.lift $ do + nextFn <- + LLVM.staticNamedFunction + "ConstantPiece.lazySize.next" + SizeIt.nextCallBack + LLVM.call nextFn stable + MaybeCont.guard =<< MaybeCont.lift (A.cmp LLVM.CmpNE len A.zero) + return (Const.Cons len (), ())) + (fmap (\(MultiValue.Cons it) -> (it, ())) $ Expr.unExp size) + (\ _it -> return ()) diff --git a/src/Synthesizer/LLVM/Interpolation.hs b/src/Synthesizer/LLVM/Interpolation.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Interpolation.hs @@ -0,0 +1,329 @@ +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +module Synthesizer.LLVM.Interpolation ( + C(margin), + loadNodes, + indexNodes, + loadNodesExp, + indexNodesExp, + + Margin(..), + zipMargin, + unzipMargin, + toMargin, + marginNumberExp, + marginOffsetExp, + + T, + + Nodes02(..), + linear, + linearVector, + + Nodes13(..), + cubic, + cubicVector, + ) where + +import qualified Synthesizer.LLVM.Value as Value + +import qualified Synthesizer.LLVM.Frame.SerialVector.Class as Serial +import qualified Synthesizer.Interpolation.Core as Interpolation + +import qualified LLVM.DSL.Expression as Expr + +import qualified LLVM.Extra.Multi.Value as MultiValue +import qualified LLVM.Extra.Scalar as Scalar +import qualified LLVM.Extra.Arithmetic as A +import qualified LLVM.Extra.Tuple as Tuple +import qualified LLVM.Extra.Storable as Storable +import qualified LLVM.Extra.Memory as Memory +import qualified LLVM.Core as LLVM + +import LLVM.Core (CodeGenFunction, Value) + +import Foreign.Storable (Storable) +import Foreign.Ptr (Ptr) +import Data.Word (Word) + +import qualified Type.Data.Num.Decimal as TypeNum + +import qualified Control.Monad.Trans.State as MS +import Control.Applicative (Applicative, liftA2, pure, (<*>)) +import Data.Traversable (Traversable, traverse, sequenceA, foldMapDefault) +import Data.Foldable (Foldable, foldMap) + + +data Margin nodes = Margin { marginNumber, marginOffset :: Int } + deriving (Show, Eq) + +singletonMargin :: MultiValue.T Int -> MultiValue.T (Margin nodes) +singletonMargin n = zipMargin n n + +unzipMargin :: + MultiValue.T (Margin nodes) -> (MultiValue.T Int, MultiValue.T Int) +unzipMargin (MultiValue.Cons (from, to)) = + (MultiValue.Cons from, MultiValue.Cons to) + +zipMargin :: MultiValue.T Int -> MultiValue.T Int -> MultiValue.T (Margin nodes) +zipMargin (MultiValue.Cons from) (MultiValue.Cons to) = + MultiValue.Cons (from, to) + +marginNumberExp :: (Expr.Value val) => val (Margin nodes) -> val Int +marginNumberExp = Expr.lift1 (fst . unzipMargin) + +marginOffsetExp :: (Expr.Value val) => val (Margin nodes) -> val Int +marginOffsetExp = Expr.lift1 (snd . unzipMargin) + +instance MultiValue.C (Margin nodes) where + type Repr (Margin nodes) = (LLVM.Value Int, LLVM.Value Int) + cons (Margin start len) = + zipMargin (MultiValue.cons start) (MultiValue.cons len) + undef = singletonMargin MultiValue.undef + zero = singletonMargin MultiValue.zero + phi bb a = + case unzipMargin a of + (a0,a1) -> + liftA2 zipMargin (MultiValue.phi bb a0) (MultiValue.phi bb a1) + addPhi bb a b = + case (unzipMargin a, unzipMargin b) of + ((a0,a1), (b0,b1)) -> do + MultiValue.addPhi bb a0 b0 + MultiValue.addPhi bb a1 b1 + + +class (Applicative nodes, Traversable nodes) => C nodes where + margin :: Margin (nodes a) + +type T r nodes a v = a -> nodes v -> CodeGenFunction r v + + +toMargin :: + (C nodes) => + (forall r. T r nodes a v) -> + Margin (nodes v) +toMargin _ = margin + + +{- | +Zero nodes before index 0 and two nodes starting from index 0. +-} +data Nodes02 a = Nodes02 {nodes02_0, nodes02_1 :: a} + +instance C Nodes02 where + margin = Margin { marginNumber = 2, marginOffset = 0 } + + +instance Functor Nodes02 where + fmap f (Nodes02 x0 x1) = Nodes02 (f x0) (f x1) + +instance Applicative Nodes02 where + pure x = Nodes02 x x + (Nodes02 f0 f1) <*> (Nodes02 x0 x1) = Nodes02 (f0 x0) (f1 x1) + +instance Foldable Nodes02 where + foldMap = foldMapDefault + +instance Traversable Nodes02 where + traverse f (Nodes02 x0 x1) = liftA2 Nodes02 (f x0) (f x1) + + +instance (Serial.Sized value) => Serial.Sized (Nodes02 value) where + type Size (Nodes02 value) = Serial.Size value + +instance (Serial.Read v) => Serial.Read (Nodes02 v) where + type Element (Nodes02 v) = Nodes02 (Serial.Element v) + type ReadIt (Nodes02 v) = Nodes02 (Serial.ReadIt v) + + extract = Serial.extractTraversable + + readStart = Serial.readStartTraversable + readNext = Serial.readNextTraversable + +instance (Serial.Write v) => Serial.Write (Nodes02 v) where + type WriteIt (Nodes02 v) = Nodes02 (Serial.WriteIt v) + + insert = Serial.insertTraversable + + writeStart = Serial.writeStartTraversable + writeNext = Serial.writeNextTraversable + writeStop = Serial.writeStopTraversable + + +instance (Tuple.Undefined a) => Tuple.Undefined (Nodes02 a) where + undef = Tuple.undefPointed + +instance (Tuple.Phi a) => Tuple.Phi (Nodes02 a) where + phi = Tuple.phiTraversable + addPhi = Tuple.addPhiFoldable + + +type Struct02 a = LLVM.Struct (a, (a, ())) + +memory02 :: + (Memory.C l) => + Memory.Record r (Struct02 (Memory.Struct l)) (Nodes02 l) +memory02 = + liftA2 Nodes02 + (Memory.element nodes02_0 TypeNum.d0) + (Memory.element nodes02_1 TypeNum.d1) + +instance (Memory.C l) => Memory.C (Nodes02 l) where + type Struct (Nodes02 l) = Struct02 (Memory.Struct l) + load = Memory.loadRecord memory02 + store = Memory.storeRecord memory02 + decompose = Memory.decomposeRecord memory02 + compose = Memory.composeRecord memory02 + + +linear :: + (A.PseudoRing a, A.IntegerConstant a) => + T r Nodes02 a a +linear r (Nodes02 a b) = + Scalar.unliftM3 (Value.unlift3 Interpolation.linear) a b r + +linearVector :: + (A.PseudoModule v, A.Scalar v ~ a, A.IntegerConstant a) => + T r Nodes02 a v +linearVector r (Nodes02 a b) = + Value.unlift3 Interpolation.linear a b r + + + + +{- | +One node before index 0 and three nodes starting from index 0. +-} +data Nodes13 a = Nodes13 {nodes13_0, nodes13_1, nodes13_2, nodes13_3 :: a} + +instance C Nodes13 where + margin = Margin { marginNumber = 4, marginOffset = 1 } + +instance Functor Nodes13 where + fmap f (Nodes13 x0 x1 x2 x3) = Nodes13 (f x0) (f x1) (f x2) (f x3) + +instance Applicative Nodes13 where + pure x = Nodes13 x x x x + (Nodes13 f0 f1 f2 f3) <*> (Nodes13 x0 x1 x2 x3) = + Nodes13 (f0 x0) (f1 x1) (f2 x2) (f3 x3) + +instance Foldable Nodes13 where + foldMap = foldMapDefault + +instance Traversable Nodes13 where + traverse f (Nodes13 x0 x1 x2 x3) = + pure Nodes13 <*> f x0 <*> f x1 <*> f x2 <*> f x3 + + +instance (Serial.Sized value) => Serial.Sized (Nodes13 value) where + type Size (Nodes13 value) = Serial.Size value + +instance (Serial.Read v) => Serial.Read (Nodes13 v) where + type Element (Nodes13 v) = Nodes13 (Serial.Element v) + type ReadIt (Nodes13 v) = Nodes13 (Serial.ReadIt v) + + extract = Serial.extractTraversable + + readStart = Serial.readStartTraversable + readNext = Serial.readNextTraversable + +instance (Serial.Write v) => Serial.Write (Nodes13 v) where + type WriteIt (Nodes13 v) = Nodes13 (Serial.WriteIt v) + + insert = Serial.insertTraversable + + writeStart = Serial.writeStartTraversable + writeNext = Serial.writeNextTraversable + writeStop = Serial.writeStopTraversable + + +instance (Tuple.Undefined a) => Tuple.Undefined (Nodes13 a) where + undef = Tuple.undefPointed + +instance (Tuple.Phi a) => Tuple.Phi (Nodes13 a) where + phi = Tuple.phiTraversable + addPhi = Tuple.addPhiFoldable + + +type Struct13 a = LLVM.Struct (a, (a, (a, (a, ())))) + +memory13 :: + (Memory.C l) => + Memory.Record r (Struct13 (Memory.Struct l)) (Nodes13 l) +memory13 = + pure Nodes13 + <*> Memory.element nodes13_0 TypeNum.d0 + <*> Memory.element nodes13_1 TypeNum.d1 + <*> Memory.element nodes13_2 TypeNum.d2 + <*> Memory.element nodes13_3 TypeNum.d3 + +instance (Memory.C l) => Memory.C (Nodes13 l) where + type Struct (Nodes13 l) = Struct13 (Memory.Struct l) + load = Memory.loadRecord memory13 + store = Memory.storeRecord memory13 + decompose = Memory.decomposeRecord memory13 + compose = Memory.composeRecord memory13 + + +cubic :: + (A.Field a, A.RationalConstant a) => + T r Nodes13 a a +cubic r (Nodes13 a b c d) = + Scalar.unliftM5 (Value.unlift5 Interpolation.cubic) a b c d r + +cubicVector :: + (A.PseudoModule v, A.Scalar v ~ a, A.Field a, A.RationalConstant a) => + T r Nodes13 a v +cubicVector r (Nodes13 a b c d) = + Value.unlift5 Interpolation.cubic a b c d r + + +loadNodesExp :: + (C nodes, Storable am) => + (Value (Ptr am) -> CodeGenFunction r a) -> + MultiValue.T Int -> + Value (Ptr am) -> CodeGenFunction r (nodes a) +loadNodesExp loadNode (MultiValue.Cons step) = + MS.evalStateT $ sequenceA $ pure $ loadNext loadNode step + +loadNodes :: + (C nodes, Storable am) => + (Value (Ptr am) -> CodeGenFunction r a) -> + Value Int -> + Value (Ptr am) -> CodeGenFunction r (nodes a) +loadNodes loadNode step = + MS.evalStateT $ sequenceA $ pure $ loadNext loadNode step + +loadNext :: + (Storable am) => + (Value (Ptr am) -> CodeGenFunction r a) -> + Value Int -> + MS.StateT (Value (Ptr am)) (CodeGenFunction r) a +loadNext loadNode step = + MS.StateT $ \ptr -> liftA2 (,) (loadNode ptr) (Storable.advancePtr step ptr) + + + +indexNodesExp :: + (C nodes) => + (MultiValue.T Word -> CodeGenFunction r v) -> + MultiValue.T Word -> + MultiValue.T Word -> CodeGenFunction r (nodes v) +indexNodesExp indexNode (MultiValue.Cons step) (MultiValue.Cons offset) = + indexNodes (indexNode . MultiValue.Cons) step offset + +indexNodes :: + (C nodes) => + (Value Word -> CodeGenFunction r v) -> + Value Word -> + Value Word -> CodeGenFunction r (nodes v) +indexNodes indexNode step = + MS.evalStateT $ sequenceA $ pure $ indexNext indexNode step + +indexNext :: + (Value Word -> CodeGenFunction r v) -> + Value Word -> + MS.StateT (Value Word) (CodeGenFunction r) v +indexNext indexNode step = + MS.StateT $ \i -> liftA2 (,) (indexNode i) (A.add i step) diff --git a/src/Synthesizer/LLVM/MIDI.hs b/src/Synthesizer/LLVM/MIDI.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/MIDI.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE Rank2Types #-} +{- | +Convert MIDI events of a MIDI controller to a control signal. +-} +module Synthesizer.LLVM.MIDI ( + frequencyFromBendModulation, + frequencyFromBendModulationPacked, + Gen.applyModulation, + ) where + +import qualified Synthesizer.MIDI.Generic as Gen +import qualified Synthesizer.LLVM.MIDI.BendModulation as BM +import qualified Synthesizer.LLVM.Frame.SerialVector as SerialExp +import qualified Synthesizer.LLVM.Frame.SerialVector.Code as Serial + +import qualified Synthesizer.LLVM.Causal.Functional as Func +import qualified Synthesizer.LLVM.Causal.Process as Causal +import qualified Synthesizer.LLVM.Generator.SignalPacked as SigPS +import qualified Synthesizer.LLVM.Generator.Signal as Sig +import qualified Synthesizer.LLVM.Wave as Wave +import Synthesizer.LLVM.Causal.Process (($>)) + +import LLVM.DSL.Expression (Exp) + +import qualified LLVM.Extra.Multi.Value.Marshal as Marshal +import qualified LLVM.Extra.Multi.Value as MultiValue +import qualified LLVM.Extra.Multi.Vector as MultiVector +import qualified LLVM.Extra.Arithmetic as A +import qualified LLVM.Core as LLVM + +import Control.Arrow (second, (<<<), (<<^)) + +import NumericPrelude.Numeric +import Prelude (($)) + + +frequencyFromBendModulation :: + (Marshal.C y, MultiValue.T y ~ ym, + MultiValue.PseudoRing y, MultiValue.IntegerConstant y, + MultiValue.Fraction y) => + Exp y -> Causal.T (BM.T ym) ym +frequencyFromBendModulation speed = + frequencyFromPair Sig.osci speed + <<^ + (\(BM.Cons b m) -> (b,m)) + + +frequencyFromBendModulationPacked :: + (Marshal.Vector n a) => + (MultiVector.PseudoRing a, MultiVector.IntegerConstant a) => + (MultiVector.Fraction a) => + Exp a -> Causal.T (BM.T (MultiValue.T a)) (Serial.Value n a) +frequencyFromBendModulationPacked speed = + frequencyFromPair SigPS.osci speed + <<< + Causal.map (\(BM.Cons b m) -> (SerialExp.upsample b, SerialExp.upsample m)) + +frequencyFromPair, _frequencyFromPair :: + (MultiValue.Additive y, + A.PseudoRing ym, A.IntegerConstant ym, A.Fraction ym) => + ((forall r. ym -> LLVM.CodeGenFunction r ym) -> + Exp y -> Exp y -> Sig.T ym) -> + Exp y -> Causal.T (ym,ym) ym +frequencyFromPair osci speed = + Func.withGuidedArgs (Func.atom, Func.atom) $ \(b, m) -> + b * (1 + m * Func.fromSignal (osci Wave.approxSine2 zero speed)) + +_frequencyFromPair osci speed = + Causal.envelope + <<< + second (1 + (Causal.envelope $> osci Wave.approxSine2 zero speed)) diff --git a/src/Synthesizer/LLVM/MIDI/BendModulation.hs b/src/Synthesizer/LLVM/MIDI/BendModulation.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/MIDI/BendModulation.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{- | +Various LLVM related instances of the BM.T type. +I have setup a separate module since these instances are orphan +and need several language extensions. +-} +module Synthesizer.LLVM.MIDI.BendModulation ( + BM.T(..), + BM.deflt, + BM.shift, + multiValue, + unMultiValue, + ) where + +import qualified Synthesizer.MIDI.Value.BendModulation as BM +import qualified Synthesizer.LLVM.Causal.Functional as F + +import qualified LLVM.DSL.Expression as Expr + +import qualified LLVM.Extra.Multi.Value.Storable as StorableMV +import qualified LLVM.Extra.Multi.Value.Marshal as MarshalMV +import qualified LLVM.Extra.Multi.Value as MultiValue +import qualified LLVM.Extra.Vector as Vector +import qualified LLVM.Extra.Tuple as Tuple +import qualified LLVM.Extra.Storable as Storable +import qualified LLVM.Extra.Marshal as Marshal +import qualified LLVM.Extra.Memory as Memory +import qualified LLVM.Extra.Control as C +import qualified LLVM.Core as LLVM + +import qualified Type.Data.Num.Decimal as TypeNum + +import qualified Data.Traversable as Trav +import qualified Data.Foldable as Fold + +import Control.Applicative (liftA2) + + +instance (Tuple.Zero a) => Tuple.Zero (BM.T a) where + zero = Tuple.zeroPointed + +instance (Tuple.Undefined a) => Tuple.Undefined (BM.T a) where + undef = Tuple.undefPointed + +instance (C.Select a) => C.Select (BM.T a) where + select = C.selectTraversable + +instance Tuple.Value h => Tuple.Value (BM.T h) where + type ValueOf (BM.T h) = BM.T (Tuple.ValueOf h) + valueOf = Tuple.valueOfFunctor + + +instance (Expr.Aggregate e mv) => Expr.Aggregate (BM.T e) (BM.T mv) where + type MultiValuesOf (BM.T e) = BM.T (Expr.MultiValuesOf e) + type ExpressionsOf (BM.T mv) = BM.T (Expr.ExpressionsOf mv) + bundle = Trav.traverse Expr.bundle + dissect = fmap Expr.dissect + +instance (MultiValue.C a) => MultiValue.C (BM.T a) where + type Repr (BM.T a) = BM.T (MultiValue.Repr a) + cons = multiValue . fmap MultiValue.cons + undef = multiValue $ pure MultiValue.undef + zero = multiValue $ pure MultiValue.zero + phi bb = fmap multiValue . Trav.traverse (MultiValue.phi bb) . unMultiValue + addPhi bb a b = + Fold.sequence_ $ + liftA2 (MultiValue.addPhi bb) (unMultiValue a) (unMultiValue b) + +instance (MarshalMV.C l) => MarshalMV.C (BM.T l) where + pack (BM.Cons bend depth) = MarshalMV.pack (bend, depth) + unpack = uncurry BM.Cons . MarshalMV.unpack + +instance (StorableMV.C l) => StorableMV.C (BM.T l) where + load = StorableMV.loadApplicative + store = StorableMV.storeFoldable + +multiValue :: BM.T (MultiValue.T a) -> MultiValue.T (BM.T a) +multiValue = MultiValue.Cons . fmap (\(MultiValue.Cons a) -> a) + +unMultiValue :: MultiValue.T (BM.T a) -> BM.T (MultiValue.T a) +unMultiValue (MultiValue.Cons x) = fmap MultiValue.Cons x + + +type Struct a = LLVM.Struct (a, (a, ())) + +memory :: (Memory.C l) => Memory.Record r (Struct (Memory.Struct l)) (BM.T l) +memory = + liftA2 BM.Cons + (Memory.element BM.bend TypeNum.d0) + (Memory.element BM.depth TypeNum.d1) + +instance (Memory.C l) => Memory.C (BM.T l) where + type Struct (BM.T l) = Struct (Memory.Struct l) + load = Memory.loadRecord memory + store = Memory.storeRecord memory + decompose = Memory.decomposeRecord memory + compose = Memory.composeRecord memory + +instance (Marshal.C l) => Marshal.C (BM.T l) where + pack (BM.Cons bend depth) = Marshal.pack (bend, depth) + unpack = uncurry BM.Cons . Marshal.unpack + +instance (Storable.C l) => Storable.C (BM.T l) where + load = Storable.loadApplicative + store = Storable.storeFoldable + +instance (Tuple.Phi a) => Tuple.Phi (BM.T a) where + phi = Tuple.phiTraversable + addPhi = Tuple.addPhiFoldable + + +instance (Vector.Simple v) => Vector.Simple (BM.T v) where + type Element (BM.T v) = BM.T (Vector.Element v) + type Size (BM.T v) = Vector.Size v + shuffleMatch = Vector.shuffleMatchTraversable + extract = Vector.extractTraversable + +instance (Vector.C v) => Vector.C (BM.T v) where + insert = Vector.insertTraversable + + +type instance F.Arguments f (BM.T a) = f (BM.T a) +instance F.MakeArguments (BM.T a) where + makeArgs = id diff --git a/src/Synthesizer/LLVM/Plug/Input.hs b/src/Synthesizer/LLVM/Plug/Input.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Plug/Input.hs @@ -0,0 +1,309 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE Rank2Types #-} +module Synthesizer.LLVM.Plug.Input ( + T(..), + Default(..), + rmap, + split, + fanout, + lazySize, + ignore, + storableVector, + piecewiseConstant, + controllerSet, + ) where + +import qualified Synthesizer.Zip as Zip + +import qualified Synthesizer.LLVM.ConstantPiece as Const + +import qualified LLVM.Extra.Multi.Value.Storable as Storable +import qualified LLVM.Extra.Multi.Value.Marshal as Marshal +import qualified LLVM.Extra.Multi.Value as MultiValue +import qualified LLVM.Extra.Memory as Memory +import qualified LLVM.Extra.Arithmetic as A +import qualified LLVM.Extra.Tuple as Tuple +import qualified LLVM.Extra.Control as C + +import qualified LLVM.ExecutionEngine as EE +import qualified LLVM.Core as LLVM + +import qualified Type.Data.Num.Decimal as TypeNum +import Type.Data.Num.Decimal ((:*:)) +import Type.Base.Proxy (Proxy) + +import qualified Synthesizer.MIDI.PiecewiseConstant.ControllerSet as PCS +import qualified Synthesizer.Generic.Signal as SigG +import qualified Data.EventList.Relative.BodyTime as EventListBT +import qualified Data.EventList.Relative.MixedTime as EventListMT +import qualified Data.EventList.Relative.TimeTime as EventListTT + +import qualified Numeric.NonNegative.Wrapper as NonNegW + +import qualified Synthesizer.LLVM.Storable.Vector as SVU +import qualified Data.StorableVector as SV + +import qualified Foreign.Marshal.Array as Array +import qualified Foreign.Marshal.Alloc as Alloc +import qualified Foreign.ForeignPtr as FPtr +import Foreign.Storable (pokeElemOff) + +import qualified Control.Functor.HT as FuncHT +import Control.Applicative (liftA2, (<$>)) + +import qualified Data.Map as Map +import qualified Data.List as List +import Data.Tuple.Strict (mapFst, zipPair) +import Data.Word (Word) + +import Prelude hiding (map) + + +{- +This datatype does not provide an early exit option, e.g. by Maybe.T, +since we warrant that the driver function will always +read only as much data as is available. +To this end you must provide a @length@ function +via an instance of 'Synthesizer.Generic.Cut.Read'. +-} +data T a b = + forall state ioContext parameters. + (Marshal.C parameters, Memory.C state) => + Cons + (forall r. + MultiValue.T parameters -> + state -> LLVM.CodeGenFunction r (b, state)) + -- compute next value + (forall r. + MultiValue.T parameters -> + LLVM.CodeGenFunction r state) + -- initial state + (a -> IO (ioContext, parameters)) + {- initialization from IO monad + This is called once input chunk. + This will be run within Unsafe.performIO, + so no observable In/Out actions please! + -} + (ioContext -> IO ()) + {- + finalization from IO monad, also run within Unsafe.performIO + -} + + +instance Functor (T a) where + fmap f (Cons next start create delete) = + Cons (\p s -> fmap (mapFst f) $ next p s) start create delete + +map :: (forall r. a -> LLVM.CodeGenFunction r b) -> T inp a -> T inp b +map f (Cons next start create delete) = + Cons (\p s -> FuncHT.mapFst f =<< next p s) start create delete + + + +class Default a where + type Element a + deflt :: T a (Element a) + + +rmap :: (a -> b) -> T b c -> T a c +rmap f (Cons next start create delete) = + Cons next start (create . f) delete + +fanout :: T a b -> T a c -> T a (b,c) +fanout f g = rmap (\a -> Zip.Cons a a) $ split f g + + +instance (Default a, Default b) => Default (Zip.T a b) where + type Element (Zip.T a b) = (Element a, Element b) + deflt = split deflt deflt + +split :: T a c -> T b d -> T (Zip.T a b) (c,d) +split (Cons nextA startA createA deleteA) + (Cons nextB startB createB deleteB) = Cons + (MultiValue.uncurry $ \parameterA parameterB (sa,sb) -> + liftA2 zipPair (nextA parameterA sa) (nextB parameterB sb)) + (MultiValue.uncurry $ \parameterA parameterB -> + liftA2 (,) (startA parameterA) (startB parameterB)) + (\(Zip.Cons a b) -> + liftA2 zipPair (createA a) (createB b)) + (\(ca,cb) -> deleteA ca >> deleteB cb) + + +instance Default SigG.LazySize where + type Element SigG.LazySize = () + deflt = lazySize + +lazySize :: T SigG.LazySize () +lazySize = ignore + +ignore :: T a () +ignore = + Cons + (\ _ unit -> return ((), unit)) + return + (\ _a -> return ((), ())) + (const $ return ()) + +instance (Storable.C a) => Default (SV.Vector a) where + type Element (SV.Vector a) = MultiValue.T a + deflt = storableVector + +storableVector :: (Storable.C a) => T (SV.Vector a) (MultiValue.T a) +storableVector = + Cons + (\ _ (MultiValue.Cons p) -> + liftA2 (,) + (Storable.load p) + (MultiValue.Cons <$> Storable.incrementPtr p)) + return + (\vec -> + let (fp,ptr,_l) = SVU.unsafeToPointers vec + in return (fp,ptr)) + -- keep the foreign ptr alive + FPtr.touchForeignPtr + + +{- +This is intentionally restricted to NonNegW.Int aka StrictTimeShort, +since chunks must fit into memory. +If you have good reasons to allow other types, +see the versioning history for an according hack. +-} +instance + (Marshal.C a, time ~ NonNegW.Int) => + Default (EventListBT.T time a) where + type Element (EventListBT.T time a) = MultiValue.T a + deflt = piecewiseConstant + +{- +I would like to re-use code from ConstantPiece here. +Unfortunately, it is based on the LLVM-Maybe-Monad, +but here we do not accept early exit. +-} +piecewiseConstant :: + (Marshal.C a) => T (EventListBT.T NonNegW.Int a) (MultiValue.T a) +piecewiseConstant = + expandConstantPieces $ + rmap + (SV.pack . + List.map + (\(a,t) -> EE.Stored $ LLVM.Struct + (fromIntegral $ NonNegW.toNumber t :: Word, (Marshal.pack a, ()))) . + EventListBT.toPairList) $ + map + (\(MultiValue.Cons s) -> do + t <- LLVM.extractvalue s TypeNum.d0 + a <- LLVM.extractvalue s TypeNum.d1 + Const.Cons t . MultiValue.Cons <$> Memory.decompose a) $ + storableVector + +expandConstantPieces :: + (Memory.C value) => T events (Const.T value) -> T events value +expandConstantPieces (Cons next start create delete) = Cons + (\param state0 -> do + (Const.Cons length1 y1, s1) <- + C.whileLoopShared state0 + (\(Const.Cons len _y, s) -> + (A.cmp LLVM.CmpEQ len Tuple.zero, + next param s)) + length2 <- A.dec length1 + return (y1, (Const.Cons length2 y1, s1))) + (\param -> (,) (Const.Cons Tuple.zero Tuple.undef) <$> start param) + create delete + + +{- | +Return an Array and not a pointer to an array, +in order to forbid writing to the array. +-} +controllerSet :: + (Marshal.C a, Marshal.Struct a ~ aStruct, LLVM.IsSized aStruct, + TypeNum.Natural n, + (n:*:LLVM.SizeOf aStruct) ~ arrSize, TypeNum.Natural arrSize) => + Proxy n -> T (PCS.T Int a) (MultiValue.T (MultiValue.Array n a)) +controllerSet pn = + controllerSetFromSV pn $ + map + (\(MultiValue.Cons s) -> do + len <- LLVM.extractvalue s TypeNum.d0 + i <- LLVM.extractvalue s TypeNum.d1 + a <- Memory.decompose =<< LLVM.extractvalue s TypeNum.d2 + return (len,(i,a))) $ + storableVector + +controllerSetFromSV :: + (Marshal.C a, Marshal.Struct a ~ aStruct, LLVM.IsSized aStruct, + TypeNum.Natural n, + (n:*:LLVM.SizeOf aStruct) ~ arrSize, TypeNum.Natural arrSize) => + Proxy n -> + T (SV.Vector (EE.Stored (Marshal.Struct (Word,Word,a)))) + (LLVM.Value Word, (LLVM.Value Word, MultiValue.T a)) -> + T (PCS.T Int a) (MultiValue.T (MultiValue.Array n a)) +controllerSetFromSV pn (Cons next start create delete) = Cons + (MultiValue.uncurry $ \(MultiValue.Cons (arrPtr, _)) param state0 -> do + (length2, s2) <- + C.whileLoopShared state0 + (\(len0, s0) -> + (A.cmp LLVM.CmpEQ len0 Tuple.zero, + do ((len1, (i,a)), s1) <- next param s0 + Memory.store a =<< LLVM.getElementPtr arrPtr (i, ()) + return (len1, s1))) + length3 <- A.dec length2 + arr <- Memory.load =<< LLVM.bitcast arrPtr + return (arr, (length3, s2))) + (MultiValue.uncurry $ \(MultiValue.Cons (_, initialTime)) param -> do + state <- start param + return (initialTime, state)) + + (\pcs -> + EventListMT.switchTimeL + (\initialTime bt -> do + (context, param) <- + create + (SV.pack . + List.map + (\((i,a),len) -> + EE.Stored $ + Marshal.pack + (fromIntegral len :: Word, + fromIntegral i :: Word, + a)) . + EventListBT.toPairList $ + bt) + + -- FIXME: handle memory exhaustion + let n = TypeNum.integralFromProxy pn + arr <- Array.mallocArray n + flip mapM_ (Map.toList $ PCS.initial pcs) $ \(i,a) -> + if i >= n + then error "Plug.Input.controllerSet: array too small" + else pokeElemOff arr i $ EE.Stored $ Marshal.pack a + + return + ((arr, context), + ((EE.castFromStoredPtr arr, fromIntegral initialTime :: Word), + param))) + {- + It would be more elegant, + if we could pass Arrays around just like Vectors. + + return (context, ((sampleArray (\i -> maybe Tuple.undef Tuple.valueOf $ Map.lookup i (PCS.initial pcs)), time), param))) + -} + (EventListTT.flatten (PCS.stream pcs))) + (\(arr, context) -> + Alloc.free arr >> delete context) + +{- +We might provide a plug that maps from a sequence of time-stamped controller events +to a stream of (Array Controller Value). +This way, we could select controllers more easily from within an causal arrow. +The disadvantage is, that MIDI controller numbers are then hard-wired into the arrow. +Instead we could use a stream of (Array Index Value) +and a global mapping (Array Controller (Maybe Index)). +This way would both save memory and make the controller numbers exchangeable. +We also have to cope with initialization of values +and have to assert that the exponential function +is computed only once per constant piece in controllerExponential. +-} diff --git a/src/Synthesizer/LLVM/Plug/Output.hs b/src/Synthesizer/LLVM/Plug/Output.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Plug/Output.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE Rank2Types #-} +module Synthesizer.LLVM.Plug.Output ( + T(..), + Default(..), + split, + storableVector, + ) where + +import qualified Synthesizer.Zip as Zip + +import qualified LLVM.Extra.Multi.Value.Storable as Storable +import qualified LLVM.Extra.Multi.Value.Marshal as Marshal +import qualified LLVM.Extra.Multi.Value as MultiValue +import qualified LLVM.Extra.Memory as Memory + +import qualified LLVM.Core as LLVM + +import Control.Applicative (liftA2) + +import qualified Synthesizer.LLVM.Storable.Vector as SVU +import qualified Data.StorableVector as SV +import qualified Data.StorableVector.Base as SVB + +import qualified Foreign.ForeignPtr as FPtr + +import Data.Tuple.Strict (zipPair) + + +data T a b = + forall state ioContext parameters. + (Marshal.C parameters, Memory.C state) => + Cons + (forall r. + MultiValue.T parameters -> a -> state -> LLVM.CodeGenFunction r state) + -- compute next value + (forall r. MultiValue.T parameters -> LLVM.CodeGenFunction r state) + -- initial state + (Int -> IO (ioContext, parameters)) + {- initialization from IO monad + This is called once per output chunk + with the number of input samples. + This number is also the maximum possible number of output samples. + This will be run within Unsafe.performIO, + so no observable In/Out actions please! + -} + (Int -> ioContext -> IO b) + {- + finalization from IO monad, also run within Unsafe.performIO + The integer argument is the actually produced size of data. + We must clip the allocated output vectors accordingly. + -} + + +class Default b where + type Element b + deflt :: T (Element b) b + + +instance (Default c, Default d) => Default (Zip.T c d) where + type Element (Zip.T c d) = (Element c, Element d) + deflt = split deflt deflt + +split :: T a c -> T b d -> T (a,b) (Zip.T c d) +split (Cons nextA startA createA deleteA) + (Cons nextB startB createB deleteB) = Cons + (MultiValue.uncurry $ \parameterA parameterB (a,b) (sa,sb) -> + liftA2 (,) (nextA parameterA a sa) (nextB parameterB b sb)) + (MultiValue.uncurry $ \parameterA parameterB -> + liftA2 (,) (startA parameterA) (startB parameterB)) + (\len -> liftA2 zipPair (createA len) (createB len)) + (\len (ca,cb) -> liftA2 Zip.Cons (deleteA len ca) (deleteB len cb)) + + +instance (Storable.C a) => Default (SV.Vector a) where + type Element (SV.Vector a) = MultiValue.T a + deflt = storableVector + +storableVector :: (Storable.C a) => T (MultiValue.T a) (SV.Vector a) +storableVector = Cons + (\ _param -> MultiValue.liftM . Storable.storeNext) + return + (\len -> do + vec <- SVB.create len (const $ return ()) + -- offset should be always zero, but we must not rely on that + let (_fp,ptr,_l) = SVU.unsafeToPointers vec + return (vec, ptr)) + (\len vec -> do + let (fp,_s,_l) = SVB.toForeignPtr vec + -- keep the foreign ptr alive + FPtr.touchForeignPtr fp + return $ SV.take len vec) diff --git a/src/Synthesizer/LLVM/Private.hs b/src/Synthesizer/LLVM/Private.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Private.hs @@ -0,0 +1,27 @@ +module Synthesizer.LLVM.Private where + +import qualified LLVM.Extra.MaybeContinuation as MaybeCont +import qualified LLVM.Extra.Multi.Value as MultiValue + +import qualified LLVM.Core as LLVM + +import qualified Type.Data.Num.Decimal as TypeNum + +import Control.Applicative (liftA2) + + +unbool :: MultiValue.T Bool -> LLVM.Value Bool +unbool (MultiValue.Cons b) = b + +noLocalPtr :: f -> (LLVM.Value (LLVM.Ptr (LLVM.Struct ())) -> f) +noLocalPtr = const + +getPairPtrs :: + (LLVM.IsSized a, LLVM.IsSized b) => + LLVM.Value (LLVM.Ptr (LLVM.Struct (a, (b, ())))) -> + MaybeCont.T r c (LLVM.Value (LLVM.Ptr a), LLVM.Value (LLVM.Ptr b)) +getPairPtrs ptr = + MaybeCont.lift $ + liftA2 (,) + (LLVM.getElementPtr0 ptr (TypeNum.d0, ())) + (LLVM.getElementPtr0 ptr (TypeNum.d1, ())) diff --git a/src/Synthesizer/LLVM/Private/Render.hs b/src/Synthesizer/LLVM/Private/Render.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Private/Render.hs @@ -0,0 +1,267 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE FlexibleContexts #-} +module Synthesizer.LLVM.Private.Render where + +import qualified Synthesizer.LLVM.Generator.Source as Source +import qualified Synthesizer.LLVM.Storable.ChunkIterator as ChunkIt +import qualified Synthesizer.LLVM.Storable.LazySizeIterator as SizeIt +import qualified Synthesizer.LLVM.EventIterator as EventIt +import Synthesizer.LLVM.Generator.Private (T(Cons)) + +import qualified Synthesizer.LLVM.Frame.Stereo as Stereo +import qualified Synthesizer.LLVM.Storable.Vector as SVU +import qualified Synthesizer.LLVM.ConstantPiece as Const + +import qualified Synthesizer.PiecewiseConstant.Signal as PC + +import qualified LLVM.DSL.Render.Argument as Arg +import qualified LLVM.DSL.Execution as Exec +import LLVM.DSL.Expression (Exp(Exp)) + +import qualified LLVM.Extra.Multi.Value.Storable as Storable +import qualified LLVM.Extra.Multi.Value.Marshal as Marshal +import qualified LLVM.Extra.Multi.Value as MultiValue +import qualified LLVM.Extra.Memory as Memory +import qualified LLVM.Extra.MaybeContinuation as MaybeCont +import qualified LLVM.Extra.Maybe as Maybe +import qualified LLVM.Extra.Control as C +import qualified LLVM.Extra.Arithmetic as A +import qualified LLVM.Extra.Tuple as Tuple + +import qualified LLVM.Core as LLVM + +import qualified Type.Data.Num.Decimal as TypeNum + +import qualified Data.StorableVector.Lazy as SVL +import qualified Data.StorableVector as SV + +import qualified Data.EventList.Relative.BodyTime as EventList +import qualified Numeric.NonNegative.Wrapper as NonNeg +import qualified Numeric.NonNegative.Chunky as NonNegChunky + +import Control.Monad (join) +import Control.Applicative (liftA3) + +import Foreign.ForeignPtr (touchForeignPtr) +import Foreign.Ptr (Ptr) + +import Data.Foldable (traverse_) +import Data.Int (Int) +import Data.Word (Word, Word8, Word32) + + + +foreign import ccall safe "dynamic" derefStartPtr :: + Exec.Importer (LLVM.Ptr param -> IO (LLVM.Ptr globalState)) + +foreign import ccall safe "dynamic" derefStopPtr :: + Exec.Importer (LLVM.Ptr globalState -> IO ()) + + + +type Pair a b = LLVM.Struct (a,(b,())) +type Triple a b c = LLVM.Struct (a,(b,(c,()))) + +tripleStruct :: + (LLVM.IsSized a, LLVM.IsSized b, LLVM.IsSized c) => + LLVM.Value a -> LLVM.Value b -> LLVM.Value c -> + LLVM.CodeGenFunction r (LLVM.Value (Triple a b c)) +tripleStruct a b c = do + s0 <- LLVM.insertvalue Tuple.undef a TypeNum.d0 + s1 <- LLVM.insertvalue s0 b TypeNum.d1 + LLVM.insertvalue s1 c TypeNum.d2 + + +type WithGlobalState param = LLVM.Struct (param, ()) + +{- | +This is a pretty ugly hack, but its seems to be the least ugly one. +We need to solve the following problem: +We have a function of type @Exp param -> T value@. +This means that all methods in @T value@ depend on @Exp param@. +We need to choose one piece of LLVM code in @Exp param@ +that generates appropriate code for all methods in @T value@. +If we access a function parameter via @Memory.load paramPtr@ +this means that all methods must end up in the same LLVM function +in order to access this parameter. +Thus I have to put all functionality in one LLVM function +and then the three functions in 'compileChunky' +jump into the handler function with a 'Word8' code +specifying the actual sub-routine. +We need to squeeze all possible inputs and outputs +through one function interface. + +However, since the handler is marked as internal +the optimizer inlines it in the three functions from 'compileChunky' +and eliminates dead code. +This way, we end up with the code that we would have written otherwise. + +The alternative would be to construct @T value@ multiple times. +Due to existential quantification we cannot prove +that the pointer types of different methods match, +so we need to cast pointers. +However, with the current approach we also have to do that. +-} +compileHandler :: + (Marshal.C param, Marshal.Struct param ~ paramStruct, + Storable.C a, MultiValue.T a ~ value) => + (Exp param -> T value) -> + LLVM.CodeGenModule + (LLVM.Function + (Word8 -> LLVM.Ptr paramStruct -> Word -> Ptr a -> + IO (Pair (LLVM.Ptr (WithGlobalState paramStruct)) Word))) +compileHandler sig = + LLVM.createNamedFunction LLVM.InternalLinkage "handlesignal" $ + \phase paramPtr loopLen bufferPtr -> + case sig $ Exp (Memory.load paramPtr) of + Cons next start stop -> do + paramGlobalStatePtr <- LLVM.bitcast paramPtr + + let create = do + newParamGlobalStatePtr <- LLVM.malloc + (global,state) <- start + flip LLVM.store newParamGlobalStatePtr =<< + join + (liftA3 tripleStruct + (LLVM.load paramPtr) + (Memory.compose global) + (Memory.compose state)) + newOpaqueParamGlobalStatePtr <- + LLVM.bitcast + (newParamGlobalStatePtr `asTypeOf` paramGlobalStatePtr) + LLVM.insertvalue Tuple.undef + newOpaqueParamGlobalStatePtr TypeNum.d0 + + let delete = do + globalPtr <- + LLVM.getElementPtr0 paramGlobalStatePtr (TypeNum.d1, ()) + stop =<< Memory.load globalPtr + LLVM.free paramGlobalStatePtr + return Tuple.undef + + let fill = do + globalPtr <- + LLVM.getElementPtr0 paramGlobalStatePtr (TypeNum.d1, ()) + statePtr <- + LLVM.getElementPtr0 paramGlobalStatePtr (TypeNum.d2, ()) + global <- Memory.load globalPtr + sInit <- Memory.load statePtr + local <- LLVM.alloca + (pos,sExit) <- + Storable.arrayLoopMaybeCont loopLen bufferPtr sInit $ + \ ptr s0 -> do + (y,s1) <- next global local s0 + MaybeCont.lift $ Storable.store y ptr + return s1 + Memory.store (Maybe.fromJust sExit) statePtr + LLVM.insertvalue Tuple.undef pos TypeNum.d1 + + doCreate <- A.cmp LLVM.CmpEQ (LLVM.valueOf 0) phase + doDelete <- A.cmp LLVM.CmpEQ (LLVM.valueOf 1) phase + C.ret =<< + (C.ifThenElse doCreate create $ + C.ifThenElse doDelete delete fill) + + +class RunArg a where + type DSLArg a + buildArg :: Arg.T a (DSLArg a) + +instance RunArg () where + type DSLArg () = () + buildArg = Arg.unit + +instance (RunArg a, RunArg b) => RunArg (a,b) where + type DSLArg (a,b) = (DSLArg a, DSLArg b) + buildArg = Arg.pair buildArg buildArg + +instance (RunArg a, RunArg b, RunArg c) => RunArg (a,b,c) where + type DSLArg (a,b,c) = (DSLArg a, DSLArg b, DSLArg c) + buildArg = Arg.triple buildArg buildArg buildArg + +instance RunArg Float where + type DSLArg Float = Exp Float + buildArg = Arg.primitive + +instance RunArg Int where + type DSLArg Int = Exp Int + buildArg = Arg.primitive + +instance RunArg Word where + type DSLArg Word = Exp Word + buildArg = Arg.primitive + +instance RunArg Word32 where + type DSLArg Word32 = Exp Word32 + buildArg = Arg.primitive + +instance (RunArg a) => RunArg (Stereo.T a) where + type DSLArg (Stereo.T a) = Stereo.T (DSLArg a) + buildArg = + case buildArg of + Arg.Cons pass create -> + Arg.Cons + (fmap pass . Stereo.unExpression) + (\s -> do + pf <- traverse create s + return (fst<$>pf, traverse_ snd pf)) + +instance + (TypeNum.Natural n, Marshal.C a, LLVM.IsSized (Marshal.Struct a), + TypeNum.Natural (n TypeNum.:*: LLVM.SizeOf (Marshal.Struct a))) => + RunArg (MultiValue.Array n a) where + type DSLArg (MultiValue.Array n a) = Exp (MultiValue.Array n a) + buildArg = Arg.primitive + +instance (Storable.C a) => RunArg (SV.Vector a) where + type DSLArg (SV.Vector a) = T (MultiValue.T a) + buildArg = + Arg.Cons + Source.storableVector + (\av -> do + let (fp,ptr,l) = SVU.unsafeToPointers av + return (Source.consStorableVector ptr l, touchForeignPtr fp)) + +newtype Buffer a = Buffer (SV.Vector a) + +buffer :: SV.Vector a -> Buffer a +buffer = Buffer + +instance (Storable.C a) => RunArg (Buffer a) where + type DSLArg (Buffer a) = Exp (Source.StorableVector a) + buildArg = + Arg.Cons id + (\(Buffer av) -> do + let (fp,ptr,l) = SVU.unsafeToPointers av + return (Source.consStorableVector ptr l, touchForeignPtr fp)) + +instance (Storable.C a) => RunArg (SVL.Vector a) where + type DSLArg (SVL.Vector a) = T (MultiValue.T a) + buildArg = + Arg.newDispose ChunkIt.new ChunkIt.dispose Source.storableVectorLazy + +class TimeInteger int where + subdivideLong :: EventList.T (NonNeg.T int) a -> EventList.T NonNeg.Int a + +instance TimeInteger Int where + subdivideLong = id + +instance TimeInteger Integer where + subdivideLong = PC.subdivideLongStrict + +instance + (time ~ NonNeg.T int, TimeInteger int, Marshal.C a) => + RunArg (EventList.T time a) where + type DSLArg (EventList.T time a) = T (Const.T (MultiValue.T a)) + buildArg = + Arg.newDispose + (EventIt.new . subdivideLong) EventIt.dispose Source.eventList + +instance (a ~ SVL.ChunkSize) => RunArg (NonNegChunky.T a) where + type DSLArg (NonNegChunky.T a) = T (Const.T ()) + buildArg = + Arg.newDispose SizeIt.new SizeIt.dispose Source.lazySize diff --git a/src/Synthesizer/LLVM/Random.hs b/src/Synthesizer/LLVM/Random.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Random.hs @@ -0,0 +1,262 @@ +{-# LANGUAGE TypeFamilies #-} +{- | +Very simple random number generator according to Knuth +which should be fast and should suffice for generating just noise. + +-} +module Synthesizer.LLVM.Random where + +import qualified LLVM.Extra.ScalarOrVector as SoV +import qualified LLVM.Extra.Vector as Vector + +import qualified LLVM.Extra.Arithmetic as A + +import qualified LLVM.Core.Guided as Guided +import LLVM.Core + (CodeGenFunction, Value, Vector, + zext, trunc, lshr, valueOf) +import qualified LLVM.Core as LLVM +import qualified Type.Data.Num.Decimal as TypeNum + +import qualified Data.NonEmpty.Class as NonEmptyC +import Data.Function.HT (nest) + +import Data.Int (Int32) +import Data.Word (Word32, Word64) + + +factor :: Integral a => a +factor = 40692 + +modulus :: Integral a => a +modulus = 2147483399 -- 2^31-249 + +{- +We have to split the 32 bit integer in order to avoid overflow on multiplication. +'split' must be chosen, such that 'splitRem' is below 2^16. +-} +split :: Word32 +split = succ $ div modulus factor + +splitRem :: Word32 +splitRem = split * factor - modulus + + +{- | +efficient computation of @mod (s*factor) modulus@ +without Integer or Word64, as in 'next64'. +-} +next :: Word32 -> Word32 +next s = + let (sHigh, sLow) = divMod s split + in flip mod modulus $ + splitRem*sHigh + factor*sLow + +next64 :: Word32 -> Word32 +next64 s = + fromIntegral $ + flip mod modulus $ + factor * (fromIntegral s :: Word64) + +nextCG32 :: Value Word32 -> CodeGenFunction r (Value Word32) +nextCG32 s = do + sHigh <- A.mul (valueOf splitRem) =<< LLVM.idiv s (valueOf split) + sLow <- A.mul (valueOf factor) =<< LLVM.irem s (valueOf split) + flip A.irem (valueOf modulus) =<< A.add sHigh sLow + +nextCG64 :: Value Word32 -> CodeGenFunction r (Value Word32) +nextCG64 s = + trunc =<< + {- + This is slow on x86 since the native @div@ is not used + since LLVM wants to prevent overflow. + We know that there cannot be an overflow, + but I do not know how to tell LLVM. + -} + flip A.irem (valueOf (modulus :: Word64)) =<< + A.mul (valueOf factor) =<< + zext s + +nextCG :: Value Word32 -> CodeGenFunction r (Value Word32) +nextCG s = do + x <- A.mul (valueOf $ factor :: Value Word64) =<< zext s + {- + split 64 result between bit 30 and bit 31 + we cannot split above bit 31, + since then 'low' can be up to 2^32-1 + and then later addition overflows. + -} + let p2e31 = 2^(31::Int) + low <- A.and (valueOf $ p2e31-1) =<< trunc x + high <- trunc =<< flip lshr (valueOf (31 :: Word64)) x + -- fac = mod (2^31) modulus + let fac = p2e31 - modulus + {- + fac < 250 + high < factor + fac*high < factor*250 + low < 2^31 + low + fac*high + < 2^31 + factor*250 + < 2*modulus + Thus modulo by modulus needs at most one subtraction. + -} + subtractIfPossible (valueOf modulus) + =<< A.add low + =<< A.mul (valueOf fac) high + + +{- +How to vectorise? +E.g. by repeated distribution of modulus and split at bit 31. +Can we replace div by modulus by mul with (2^31+249) ? +-} +vectorParameter :: + Integral a => + Int -> a +vectorParameter n = + fromIntegral $ nest n next 1 + +vectorSeed :: + (TypeNum.Positive n) => + Word32 -> Vector n Word32 +vectorSeed seed = + LLVM.cyclicVector $ NonEmptyC.iterate next seed +-- vector $ NonEmptyC.iterate next seed + +vector64 :: Value (Vector n Word64) -> Value (Vector n Word64) +vector64 = id + +{- +In case of a vector random generator the factor depends on the vector size +and thus we cannot do optimizations on a constant factor as in nextCG. +Thus we just compute the product @factor*seed@ as is +(this is of type @Word32 -> Word32 -> Word64@) +and try to compute @urem@ without using LLVM's @urem@ +that calls __umoddi3 on every element. +Instead we optimize on the constant modulus +and utilize that is slightly smaller than 2^31. + +We split the product: + factor*seed = high0*2^31 + low0 + +Now it is +mod (factor*seed) modulus + = mod (high0*2^31 + low0) modulus + = mod (high0 * mod (2^31) modulus + low0) modulus + = mod (high0 * 249 + low0) modulus + +However, high0 * 249 + low0 is still too big, +it can be up to (excluding) 2^31 * 250. +Thus we repeat the split +high0 * 249 + low0 = high1 * 2^31 + low1 + +It is high1 < 250, and thus high1*249 < 62500, +high1 * 249 + low1 < 2*modulus. +With x = high1 * 249 + low1 +we have +mod (factor*seed) modulus + = if x + Value (Vector n Word32) -> + CodeGenFunction r (Value (Vector n Word32)) +nextVector s = do + {- + It seems that LLVM-2.6 on x86 does not make use of the fact, + that the upper doublewords are zero. + It seems to implement a full 64x64 multiplication in terms of pmuludq. + -} + (low0, high0) <- + splitVector31 =<< + umul32to64 (SoV.replicateOf (vectorParameter (Vector.size s))) s + -- fac = mod (2^31) modulus + let fac :: Integral a => a + fac = 2^(31::Int) - modulus + (low1, high1) <- + splitVector31 =<< + (\x -> A.add x =<< Vector.map zext low0) =<< + umul32to64 (SoV.replicateOf fac) high0 + + subtractIfPossible (SoV.replicateOf modulus) + =<< A.add low1 + =<< Vector.mul (SoV.replicateOf fac) high1 + +{- | +@subtractIfPossible d x@ returns @A.sub x d@ +if this is possible without underflow. +Otherwise it returns @x@. + +Only works for unsigned types. +-} +subtractIfPossible :: + (SoV.Real a) => + Value a -> Value a -> CodeGenFunction r (Value a) +subtractIfPossible d x = do + {- + An element should become smaller by subtraction. + If it becomes greater, then there was an overflow + and 'min' chooses the value before subtraction. + -} + SoV.min x =<< A.sub x d + -- alternatively (slower): + -- flip selectNonNegativeGeneric x =<< A.sub x d + +{- | +Select non-negative elements from the first vector, +otherwise select corresponding elements from the second vector. +-} +selectNonNegativeGeneric :: + (TypeNum.Positive n) => + Value (Vector n Int32) -> + Value (Vector n Int32) -> + CodeGenFunction r (Value (Vector n Int32)) +selectNonNegativeGeneric x y = do + b <- A.cmp LLVM.CmpGE x A.zero + LLVM.select b x y + + +splitVector31 :: + (TypeNum.Positive n) => + Value (Vector n Word64) -> + CodeGenFunction r (Value (Vector n Word32), Value (Vector n Word32)) +splitVector31 x = do + low <- A.and (SoV.replicateOf (2^(31::Int)-1)) =<< Vector.map trunc x + high <- Vector.map trunc =<< flip lshr (SoV.replicateOf (31 :: Word64) `asTypeOf` x) x + return (low, high) + +{- | +This is the most obvious implementation +but unfortunately calls the expensive __umoddi3. +-} +nextVector64 :: + (TypeNum.Positive n) => + Value (Vector n Word32) -> + CodeGenFunction r (Value (Vector n Word32)) +nextVector64 s = + Vector.map trunc =<< + flip A.irem (SoV.replicateOf modulus) =<< + umul32to64 (SoV.replicateOf (vectorParameter (Vector.size s))) s + +umul32to64 :: + (TypeNum.Positive n) => + Value (Vector n Word32) -> + Value (Vector n Word32) -> + CodeGenFunction r (Value (Vector n Word64)) +umul32to64 x y = do + x64 <- Guided.ext Guided.vector x + y64 <- Guided.ext Guided.vector y + A.mul x64 y64 diff --git a/src/Synthesizer/LLVM/RingBuffer.hs b/src/Synthesizer/LLVM/RingBuffer.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/RingBuffer.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE TypeFamilies #-} +module Synthesizer.LLVM.RingBuffer where + +import qualified LLVM.Extra.MaybeContinuation as Maybe +import qualified LLVM.Extra.Memory as Memory +import qualified LLVM.Extra.Control as C +import qualified LLVM.Extra.Arithmetic as A +import qualified LLVM.Extra.Tuple as Tuple + +import qualified LLVM.Core as LLVM +import LLVM.Core (CodeGenFunction, Value) + +import Data.Word (Word) + +import Prelude hiding (length) + + +{- +I have chosen this type parameter +in order make sure that you can only retrieve from the buffer +what you have put into it. +E.g. if you store a SerialVector in it, +you can only load a SerialVector from it, but not a Vector, +although both of them use the same type for storage. +-} +data T a = + Cons { + buffer :: Value (MemoryPtr a), + length :: Value Word, + current :: Value Word, + oldest_ :: Value Word + } + +type MemoryPtr a = LLVM.Ptr (Memory.Struct a) + +{- | +This function does not check for range violations. +If the ring buffer was generated by @track initial time@, +then the minimum index is zero and the maximum index is @time@. +Index zero refers to the current sample +and index @time@ refers to the oldest one. +-} +index :: (Memory.C a) => Value Word -> T a -> CodeGenFunction r a +index i rb = do + k <- flip A.irem (length rb) =<< A.add (current rb) i + Memory.load =<< LLVM.getElementPtr (buffer rb) (k, ()) + +{- | +Fetch the oldest value in the ring buffer. +For the result of @track initial time@ +this is equivalent to @index time@ but more efficient. +-} +oldest :: (Memory.C a) => T a -> CodeGenFunction r a +oldest rb = + Memory.load =<< LLVM.getElementPtr (buffer rb) (oldest_ rb, ()) + + +trackConstCreate :: (p -> t) -> p -> IO ((), t) +trackConstCreate getTime p = return ((), getTime p) + + +trackNext :: + (Memory.C al) => + (tl -> Value Word) -> + (tl, Value (MemoryPtr al)) -> () -> + al -> Value Word -> + Maybe.T r z (T al, Value Word) +trackNext valueTime (size,ptr) () a remain0 = Maybe.lift $ do + Memory.store a =<< LLVM.getElementPtr ptr (remain0, ()) + cont <- A.cmp LLVM.CmpGT remain0 A.zero + let size0 = valueTime size + remain1 <- C.ifThenSelect cont size0 (A.dec remain0) + size1 <- A.inc size0 + return (Cons ptr size1 remain0 remain1, remain1) + +trackStart :: + (Memory.C al) => + (tl -> Value Word) -> + (al, tl) -> + CodeGenFunction r ((tl, Value (MemoryPtr al)), Value Word) +trackStart valueTime (initial, size) = do + let size0 = valueTime size + size1 <- A.inc size0 + ptr <- LLVM.arrayMalloc size1 + -- cf. LLVM.Storable.Signal.fill + C.arrayLoop size1 ptr () $ \ ptri () -> + Memory.store initial ptri + return ((size,ptr), size0) + +trackStop :: + (LLVM.IsType am) => + (tl, Value (LLVM.Ptr am)) -> + Value Word -> + CodeGenFunction r () +trackStop (_size,ptr) _remain = LLVM.free ptr + +trackCreate :: + (Tuple.Value a) => + (p -> a) -> + (p -> t) -> + p -> + IO ((), (a, t)) +trackCreate getInitial getTime p = + return ((), (getInitial p, getTime p)) + +trackDelete :: () -> IO () +trackDelete () = return () diff --git a/src/Synthesizer/LLVM/Server/CausalPacked/Common.hs b/src/Synthesizer/LLVM/Server/CausalPacked/Common.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Server/CausalPacked/Common.hs @@ -0,0 +1,37 @@ +module Synthesizer.LLVM.Server.CausalPacked.Common where + +import Synthesizer.LLVM.Server.Common (SampleRate(SampleRate), Real) + +import qualified Synthesizer.LLVM.MIDI.BendModulation as BM + +import qualified Data.EventList.Relative.TimeTime as EventListTT + +import qualified Numeric.NonNegative.Class as NonNeg + +import Prelude hiding (Real) + + +-- ToDo: might be moved to event-list package +chopEvents :: + (NonNeg.C time, Num time) => + time -> + EventListTT.T time body -> + [EventListTT.T time body] +chopEvents chunkSize = + let go evs = + -- splitBeforeTime? + let (chunk,rest) = EventListTT.splitAtTime chunkSize evs + in if EventListTT.duration chunk == 0 + then [] + else chunk : go rest + in go + + +transposeModulation :: + (Functor stream) => + SampleRate Real -> + Real -> + stream (BM.T Real) -> + stream (BM.T Real) +transposeModulation (SampleRate sampleRate) freq = + fmap (BM.shift (freq/sampleRate)) diff --git a/src/Synthesizer/LLVM/Server/CausalPacked/Instrument.hs b/src/Synthesizer/LLVM/Server/CausalPacked/Instrument.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Server/CausalPacked/Instrument.hs @@ -0,0 +1,1038 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE Rank2Types #-} +{- | +This module contains some instruments with Causal arrow interface. +The interface is a bit low-level +since you have to write the transformations of the Haskell-side +separately from the computations on the LLVM side. +A nicer integration is used in +"Synthesizer.LLVM.Server.CausalPacked.InstrumentPlug". +However, we preserve this module in order to show +how things work internally. +-} +module Synthesizer.LLVM.Server.CausalPacked.Instrument ( + ping, + pingRelease, + helixSound, + pingStereoReleaseFM, + filterSawStereoFM, + tineStereoFM, + bellNoiseStereoFM, + wind, + windPhaser, + softStringShapeFM, cosineStringStereoFM, + arcSawStringStereoFM, arcSineStringStereoFM, + arcSquareStringStereoFM, arcTriangleStringStereoFM, + fmStringStereoFM, + sampledSound, sampledSoundMono, + Control, DetuneBendModControl, WithEnvelopeControl, StereoChunk, + Frequency, Time, + pingControlledEnvelope, stringControlledEnvelope, + reorderEnvelopeControl, + frequencyControl, zipEnvelope, + ) where + +import Synthesizer.LLVM.Server.Packed.Instrument (stereoNoise) +import Synthesizer.LLVM.Server.CausalPacked.Common (transposeModulation) +import Synthesizer.LLVM.Server.CommonPacked +import Synthesizer.LLVM.Server.Common hiding + (Instrument, Frequency, Time, Control, transposeModulation) +import Synthesizer.LLVM.Server.Common (Arg(Frequency, Time)) + +import qualified Synthesizer.LLVM.Server.SampledSound as Sample +import qualified Synthesizer.LLVM.Storable.Process as PSt +import qualified Synthesizer.MIDI.CausalIO.Process as MIO +import qualified Synthesizer.CausalIO.Gate as Gate +import qualified Synthesizer.CausalIO.Process as PIO + +import qualified Synthesizer.LLVM.Filter.Universal as UniFilter +import qualified Synthesizer.LLVM.Filter.Allpass as Allpass +import qualified Synthesizer.LLVM.Filter.Moog as Moog +import qualified Synthesizer.LLVM.Causal.Exponential2 as Exp +import qualified Synthesizer.LLVM.Frame.Stereo as Stereo +import qualified Synthesizer.LLVM.Frame as Frame +import qualified Synthesizer.LLVM.Frame.SerialVector as Serial +import qualified Synthesizer.LLVM.Causal.Helix as Helix +import qualified Synthesizer.LLVM.Causal.Functional as F +import qualified Synthesizer.LLVM.Causal.ControlledPacked as CtrlPS +import qualified Synthesizer.LLVM.Causal.Render as Render +import qualified Synthesizer.LLVM.Causal.ProcessPacked as CausalPS +import qualified Synthesizer.LLVM.Causal.Process as Causal +import qualified Synthesizer.LLVM.Generator.SignalPacked as SigPS +import qualified Synthesizer.LLVM.Generator.Signal as Sig +import qualified Synthesizer.LLVM.Interpolation as Interpolation +import qualified Synthesizer.LLVM.Wave as WaveL +import Synthesizer.LLVM.Causal.Functional (($&), (&|&)) +import Synthesizer.LLVM.Causal.Process (($<), ($>), ($<#)) + +import qualified Synthesizer.LLVM.MIDI.BendModulation as BM +import qualified Synthesizer.LLVM.MIDI as MIDIL +import qualified Synthesizer.PiecewiseConstant.Signal as PC +import qualified Synthesizer.Causal.Class as CausalClass +import qualified Synthesizer.Generic.Cut as CutG +import qualified Synthesizer.Zip as Zip +import qualified Data.EventList.Relative.BodyTime as EventListBT + +import qualified Synthesizer.Storable.Signal as SigSt +import qualified Data.StorableVector.Lazy as SVL +import qualified Data.StorableVector as SV + +import qualified LLVM.DSL.Expression as Expr +import LLVM.DSL.Expression (Exp, (<=*), (>*)) + +import qualified LLVM.Extra.Multi.Value as MultiValue +import qualified LLVM.Extra.Tuple as Tuple +import qualified LLVM.Core as LLVM + +import qualified Type.Data.Num.Decimal as TypeNum + +import qualified Control.Applicative.HT as App +import qualified Control.Monad.HT as M +import Control.Arrow (Arrow, arr, first, second, (&&&), (<<^), (^<<)) +import Control.Category (id, (.)) +import Control.Applicative (liftA2, liftA3, (<$>)) +import Control.Functor.HT (unzip) + +import qualified Data.Traversable as Trav +import Data.Semigroup ((<>)) +import Data.Monoid (mappend) +import Data.Tuple.HT (mapPair) + +import qualified Number.DimensionTerm as DN + +import NumericPrelude.Numeric +import NumericPrelude.Base hiding (id, unzip, (.)) + + +type Instrument a sig = SampleRate a -> MIO.Instrument a sig + +type Control = EventListBT.T PC.ShortStrictTime + +type Time = DN.Time Real +type Frequency = DN.Frequency Real + +type Chunk = SV.Vector Vector +type StereoChunk = SV.Vector (Stereo.T Vector) +type BendModControl = Control (BM.T Real) +type DetuneBendModControl = Zip.T (Control Real) (Control (BM.T Real)) + +type PIOId a = PIO.T a a + + + +frequencyFromBendModulationPacked :: + Exp Real -> + F.T inp (MultiValue.T (BM.T Real)) -> + F.T inp VectorValue +frequencyFromBendModulationPacked speed fm = + MIDIL.frequencyFromBendModulationPacked speed $& (BM.unMultiValue <$> fm) + +stereoFrequenciesFromDetuneBendModulation :: + Exp Real -> + (F.T inp (MultiValue.T Real), + F.T inp (MultiValue.T (BM.T Real))) -> + F.T inp (Stereo.T VectorValue) +stereoFrequenciesFromDetuneBendModulation speed (detune, freq) = + Causal.envelopeStereo $& + frequencyFromBendModulationPacked speed freq + &|& + (Causal.map (fmap Serial.upsample) $& + liftA2 Stereo.cons (one + detune) (one - detune)) + + +frequencyFromSampleRate :: SampleRate a -> DN.Frequency a +frequencyFromSampleRate (SampleRate sr) = DN.frequency sr + +halfLifeControl :: + (Functor f) => + SampleRate Real -> + f Time -> + f (Exp.ParameterPacked Vector) +halfLifeControl sr = + fmap (Exp.parameterPackedPlain . + flip DN.mulToScalar (frequencyFromSampleRate sr)) + +frequencyControl :: + (Functor f) => + SampleRate Real -> + f Frequency -> + f Real +frequencyControl sr = + fmap (flip DN.divToScalar $ frequencyFromSampleRate sr) + +takeThreshold :: Exp Real -> Causal.T VectorValue VectorValue +takeThreshold threshold = + Causal.takeWhile (\y -> threshold <=* Serial.subsample y) + + +type EnvelopeControl = + Zip.T MIO.GateChunk + (Zip.T (Control Time) (Control Time)) + +type WithEnvelopeControl remainder = + Zip.T MIO.GateChunk + (Zip.T + (Zip.T (Control Time) (Control Time)) + remainder) + +reorderEnvelopeControl :: + (Arrow arrow, CutG.Read remainder) => + arrow + (WithEnvelopeControl remainder) + (Zip.T EnvelopeControl remainder) +reorderEnvelopeControl = + arr $ \(Zip.Cons gate (Zip.Cons times ctrl)) -> + Zip.consChecked "ping gate ctrl" + (Zip.consChecked "ping gate times" gate times) ctrl + + +zipEnvelope :: + (Arrow arrow, CutG.Transform a, CutG.Transform b) => + arrow EnvelopeControl a -> + arrow (WithEnvelopeControl b) (Zip.T a b) +zipEnvelope env = + Zip.arrowFirstShorten env + . + reorderEnvelopeControl + + +ping :: IO (Instrument Real Chunk) +ping = + fmap (\proc sampleRate vel freq -> + proc sampleRate vel freq + . + Gate.toStorableVector) $ + Render.run $ + wrapped $ \(Number vel) (Frequency freq) -> + constant time 0.2 $ \halfLife _sr -> + Causal.fromSignal $ + SigPS.exponential2 halfLife (amplitudeFromVelocity vel) + * + SigPS.osci WaveL.saw zero freq + + +pingReleaseEnvelope :: + IO (Real -> Real -> + SampleRate Real -> Real -> + PIO.T MIO.GateChunk Chunk) +pingReleaseEnvelope = + liftA2 + (\sustain release dec rel sr vel -> + PSt.continuePacked + (sustain sr dec vel + . + Gate.toChunkySize) + (\y -> + release sr rel y + . + Gate.allToChunkySize)) + (Render.run $ + wrapped $ \(Time decay) (Number vel) (SampleRate _sr) -> + Causal.fromSignal $ + SigPS.exponential2 + -- FixMe: is division vectorSize correct? + (decay / fromIntegral vectorSize) (amplitudeFromVelocity vel)) + (Render.run $ + wrapped $ \(Time releaseHL) (Number level) -> + constant time 1 $ \releaseTime _sr -> + Causal.take + (Expr.roundToIntFast $ releaseTime / fromIntegral vectorSize) + . + Causal.fromSignal (SigPS.exponential2 releaseHL level)) + +pingRelease :: IO (Real -> Real -> Instrument Real Chunk) +pingRelease = + liftA2 + (\osci envelope dec rel sr vel freq -> + osci sr freq + . + envelope dec rel sr vel) + (Render.run $ + wrapped $ \(Frequency freq) (SampleRate _sr) -> + Causal.envelope $> SigPS.osci WaveL.saw zero freq) + pingReleaseEnvelope + + +pingControlledEnvelope :: + Maybe Real -> + IO (SampleRate Real -> Real -> + PIO.T EnvelopeControl Chunk) +pingControlledEnvelope threshold = + liftA2 + (\sustain release sr vel -> + PSt.continuePacked + (sustain sr vel + . + Gate.shorten + . + Zip.arrowSecond (arr (halfLifeControl sr . Zip.first))) + (\y -> + release sr y + <<^ + halfLifeControl sr . Zip.second . Zip.second)) + (Render.run $ + wrapped $ \(Number vel) (SampleRate _sr) -> + Exp.causalPacked (amplitudeFromVelocity vel) + <<^ Exp.unMultiValueParameterPacked) + (Render.run $ + wrapped $ \(Number level) (SampleRate _sr) -> + let expo = Exp.causalPacked level <<^ Exp.unMultiValueParameterPacked + in case threshold of + Just y -> takeThreshold (Expr.cons y) . expo + Nothing -> expo) + + +pingStereoReleaseFM :: + IO (SampleRate Real -> Real -> Real -> + PIO.T + (WithEnvelopeControl + (Zip.T + (Zip.T (Control Real) (Control Time)) + (Zip.T + (Zip.T (Control Real) (Control Time)) + DetuneBendModControl))) + StereoChunk) +pingStereoReleaseFM = + liftA2 + (\osc env sr vel freq -> + osc sr + . + Zip.arrowSecond + (Zip.arrowSplit + (Zip.arrowSecond $ arr $ halfLifeControl sr) + ((Zip.arrowSecond $ Zip.arrowSecond $ + arr $ transposeModulation sr freq) + . + (Zip.arrowFirst $ Zip.arrowSecond $ + arr $ halfLifeControl sr))) + . + zipEnvelope (env sr vel)) + (Render.run $ + constant frequency 10 $ \speed _sr -> + (arr Stereo.multiValue + . + Causal.envelopeStereo + . + second + (F.withArgs $ \((shape0,shapeDecay),((phase,phaseDecay),fm)) -> + let shape = Causal.map Serial.upsample $& shape0 + shapeCtrl = + 1/pi + (shape-1/pi) * + (Exp.causalPacked 1 + <<^ Exp.unMultiValueParameterPacked + $& shapeDecay) + freqs = stereoFrequenciesFromDetuneBendModulation speed fm + expo = + (Causal.map Serial.upsample $& phase) * + (Exp.causalPacked 1 <<^ Exp.unMultiValueParameterPacked + $& phaseDecay) + osci :: + Causal.T + (VectorValue, (VectorValue, VectorValue)) VectorValue + osci = CausalPS.shapeModOsci WaveL.rationalApproxSine1 + in liftA2 Stereo.cons + (osci $& shapeCtrl &|& (expo &|& fmap Stereo.left freqs)) + (osci $& shapeCtrl &|& + (negate expo &|& fmap Stereo.right freqs))))) + (pingControlledEnvelope (Just 0.01)) + + + +filterSawStereoFM :: + IO (SampleRate Real -> Real -> Real -> + PIO.T + (WithEnvelopeControl + (Zip.T + (Zip.T (Control Frequency) (Control Time)) + DetuneBendModControl)) + StereoChunk) +filterSawStereoFM = + liftA2 + (\osc env sr vel freq -> + osc sr + . + Zip.arrowSecond + (Zip.arrowSplit + (Zip.arrowSplit + (arr $ frequencyControl sr) + (arr $ halfLifeControl sr)) + (Zip.arrowSecond $ + arr $ transposeModulation sr freq)) + . + zipEnvelope (env sr vel)) + (Render.run $ + constant frequency 10 $ \speed -> + constant frequency 100 $ \lowerFreq _sr -> + (arr Stereo.multiValue + . + Causal.envelopeStereo + . + second + (F.withArgs $ \((cutoff,cutoffDecay),fm) -> + let freqs = stereoFrequenciesFromDetuneBendModulation speed fm + {- bound control in order to avoid too low resonant frequency, + which makes the filter instable -} + expo = + takeThreshold lowerFreq $& + (Causal.map Serial.upsample $& cutoff) * + (Exp.causalPacked 1 <<^ Exp.unMultiValueParameterPacked + $& cutoffDecay) + in Causal.stereoFromMonoControlled + (UniFilter.lowpass ^<< CtrlPS.process) + $& + ((Causal.quantizeLift + (Causal.map + (UniFilter.parameter 10 + . + Serial.subsample)) + $<# (100 / fromIntegral vectorSize :: Real)) + $& + expo) + &|& + (Causal.stereoFromMono + (CausalPS.osci WaveL.saw $< zero) $& + freqs)))) + (pingControlledEnvelope (Just 0.01)) + +tineStereoFM :: + IO (SampleRate Real -> Real -> Real -> + PIO.T + (WithEnvelopeControl + (Zip.T + (Zip.T (Control Real) (Control Real)) + DetuneBendModControl)) + StereoChunk) +tineStereoFM = + liftA2 + (\osc env sr vel freq -> + osc sr vel + . + (Zip.arrowSecond $ Zip.arrowSecond $ + Zip.arrowSecond $ + arr $ transposeModulation sr freq) + . + zipEnvelope (env sr vel)) + (Render.run $ + wrapped $ \(Number vel) -> + constant frequency 5 $ \speed -> + constant time 1 $ \halfLife _sr -> + (arr Stereo.multiValue + . + Causal.envelopeStereo + . + second + (F.withArgs $ \((index0,depth0), fm) -> + let freqs = stereoFrequenciesFromDetuneBendModulation speed fm + index = Causal.map Serial.upsample $& index0 + depth = Causal.map Serial.upsample $& depth0 + expo = F.fromSignal $ SigPS.exponential2 halfLife (1 + vel) + osci indexDepth freq = + case unzip indexDepth of + (index1,depth1) -> + CausalPS.osci WaveL.approxSine2 $& + expo * depth1 * + (CausalPS.osci WaveL.approxSine2 + $& zero &|& index1*freq) + &|& + freq + in stereoFromMonoControlled osci (index&|&depth) freqs))) + (pingControlledEnvelope (Just 0.01)) + +{- | +'Stereo.liftApplicative' specialised to 'T'. + +Should be moved to Functional utility module. +(Functional module itself would cause cyclic dependency.) +-} +stereoFromMonoControlled, + _stereoFromMonoControlledArgs, + _stereoFromMonoControlledGrounded, + _stereoFromMonoControlledGuided, + _stereoFromMonoControlledPrepared, + _stereoFromMonoControlledPrepared2 :: + (Tuple.Phi a, Tuple.Phi b, Tuple.Phi c) => + (Tuple.Undefined a, Tuple.Undefined b, Tuple.Undefined c) => + (forall inp0. F.T inp0 c -> F.T inp0 a -> F.T inp0 b) -> + F.T inp c -> F.T inp (Stereo.T a) -> F.T inp (Stereo.T b) +stereoFromMonoControlled proc ctrl stereo = + Causal.stereoFromMonoControlled + (F.compile $ uncurry proc $ unzip $ F.lift id) + $& + ctrl &|& stereo + +_stereoFromMonoControlledArgs proc ctrl stereo = + Causal.stereoFromMonoControlled + (F.withArgs (uncurry proc) <<^ mapPair (F.AnyArg, F.AnyArg)) + $& + ctrl &|& stereo + +_stereoFromMonoControlledGrounded proc ctrl stereo = + Causal.stereoFromMonoControlled + (F.withGroundArgs $ \(F.Ground c, F.Ground s) -> proc c s) + $& + ctrl &|& stereo + +_stereoFromMonoControlledGuided proc ctrl stereo = + Causal.stereoFromMonoControlled + (F.withGuidedArgs (F.atom, F.atom) (uncurry proc)) + $& + ctrl &|& stereo + +_stereoFromMonoControlledPrepared proc ctrl stereo = + Causal.stereoFromMonoControlled + (F.withPreparedArgs (F.pairArgs F.atomArg F.atomArg) (uncurry proc)) + $& + ctrl &|& stereo + +_stereoFromMonoControlledPrepared2 proc ctrl stereo = + Causal.stereoFromMonoControlled + (F.withPreparedArgs2 F.atomArg F.atomArg proc) + $& + ctrl &|& stereo + + +type RealValue = MultiValue.T Real + +bellNoiseStereoFM :: + IO (SampleRate Real -> Real -> Real -> + PIO.T + (WithEnvelopeControl + (Zip.T + (Zip.T (Control Real) (Control Real)) + DetuneBendModControl)) + StereoChunk) +bellNoiseStereoFM = + liftA3 + (\osc env envInf sr vel freq -> + osc sr + . + (Zip.arrowSecond $ Zip.arrowSecond $ + Zip.arrowSecond $ + arr $ transposeModulation sr freq) + . + zipEnvelope + (Zip.arrowFanoutShorten + (env sr (vel*0.5)) + (let shortenTimes :: + Real -> + PIOId (Zip.T (Control Time) (Control Time)) + shortenTimes n = + let rn = recip n + in (Zip.arrowFirst $ arr $ fmap $ DN.scale rn) + . + (Zip.arrowSecond $ arr $ fmap $ DN.scale rn) + in PIO.zip + (envInf sr (vel*2) + . + Zip.arrowSecond (shortenTimes 4)) + (envInf sr (vel*4) + . + Zip.arrowSecond (shortenTimes 7))))) + (Render.run $ + constant noiseReference 20000 $ \noiseRef -> + constant frequency 5 $ \speed _sr -> + (F.withArgs $ \((env1,(env4,env7)),((noiseAmp0,noiseReson),fm)) -> + let noiseAmp = Causal.map Serial.upsample $& noiseAmp0 + noiseParam :: + Causal.T + (RealValue, RealValue) + (Moog.Parameter TypeNum.D8 RealValue) + noiseParam = + Causal.quantizeLift + (Causal.zipWith (Moog.parameter TypeNum.d8)) + $<# (100 / fromIntegral vectorSize :: Real) + noise = F.fromSignal (SigPS.noise 12 noiseRef) + freqs = stereoFrequenciesFromDetuneBendModulation speed fm + osci amp env n = + CausalPS.amplifyStereo amp $& + Causal.envelopeStereo $& + env &|& + (Causal.stereoFromMono + (CausalPS.osci WaveL.approxSine4 $< zero) + $& + CausalPS.amplifyStereo n + $& + freqs) + in Stereo.multiValue <$> + (Causal.envelopeStereo $& + (noiseAmp * env1) + &|& + Stereo.liftApplicative + (\freq -> + CtrlPS.process $& + (noiseParam $& noiseReson &|& + (Causal.map Serial.subsample $& freq)) + &|& + noise) + freqs) + + osci 1.00 env1 1 + + osci 0.10 env4 4 + + osci 0.01 env7 7)) + (pingControlledEnvelope (Just 0.01)) + (pingControlledEnvelope Nothing) + + + +stringControlledEnvelope :: + IO (SampleRate Real -> Real -> + PIO.T EnvelopeControl Chunk) +stringControlledEnvelope = + liftA3 + (\attack sustain release sr vel -> + let amp = amplitudeFromVelocity vel + in PSt.continuePacked + ((attack sr amp <> + {- we could also feed the sustain process + with a signal with sample type () -} + sustain sr amp) + . + Gate.shorten + . + Zip.arrowSecond (arr (halfLifeControl sr . Zip.first))) + (\y -> + release sr y + <<^ + halfLifeControl sr . Zip.second . Zip.second)) + (Render.run $ + wrapped $ \(Number amp) (SampleRate _sr) -> + Causal.fromSignal (SigPS.constant amp) + - + takeThreshold 1e-4 + . + Exp.causalPacked amp <<^ Exp.unMultiValueParameterPacked) + (Render.run $ + wrapped $ \(Number amp) (SampleRate _sr) -> + Causal.fromSignal (SigPS.constant amp)) + (Render.run $ + wrapped $ \(Number level) (SampleRate _sr) -> + takeThreshold 0.01 + . + Exp.causalPacked level <<^ Exp.unMultiValueParameterPacked) + + +windCore :: + F.T a (MultiValue.T Real) -> + F.T a (MultiValue.T (BM.T Real)) -> + SampleRate (Exp Real) -> + F.T a (Stereo.T VectorValue) +windCore reson fm = + constant frequency 0.2 $ \speed sr -> + let modu = + Causal.map Serial.subsample $& + (fmap (`asTypeOf` (undefined :: VectorValue)) $ + frequencyFromBendModulationPacked speed fm) + in Causal.stereoFromMonoControlled CtrlPS.process $& + (Causal.zipWith (Moog.parameter TypeNum.d8) $& reson &|& modu) + &|& + F.fromSignal (stereoNoise sr) + +wind :: + IO (SampleRate Real -> Real -> Real -> + PIO.T + (WithEnvelopeControl DetuneBendModControl) + StereoChunk) +wind = + liftA2 + (\osc env sr vel freq -> + osc sr + . + (Zip.arrowSecond $ Zip.arrowSecond $ + arr $ transposeModulation sr freq) + . + zipEnvelope (env sr vel)) + (Render.run $ \sr -> + F.withArgs $ \(env,(reson,fm)) -> + Stereo.multiValue <$> + Causal.envelopeStereo $& env &|& windCore reson fm sr) + stringControlledEnvelope + + +windPhaser :: + IO (SampleRate Real -> Real -> Real -> + PIO.T + (WithEnvelopeControl + (Zip.T (Control Real) + (Zip.T (Control Frequency) DetuneBendModControl))) + StereoChunk) +windPhaser = + liftA2 + (\osc env sr vel freq -> + osc sr + . + (Zip.arrowSecond $ Zip.arrowSecond $ + Zip.arrowSplit + (arr $ fmap (Allpass.flangerParameter TypeNum.d8) . + frequencyControl sr) + (Zip.arrowSecond $ + arr $ transposeModulation sr freq)) + . + zipEnvelope (env sr vel)) + (Render.run $ \sr -> + (F.withArgs $ \(env,(phaserMix0,(phaserFreq,(reson,fm)))) -> + let phaserMix = Causal.map Serial.upsample $& phaserMix0 + noise = windCore reson fm sr + + in Stereo.multiValue <$> + Causal.envelopeStereo $& + env &|& + ((Causal.envelopeStereo $& (1 - phaserMix) &|& noise) + + + (Causal.envelopeStereo $& + phaserMix &|& + (Stereo.arrowFromMonoControlled CtrlPS.process $& + (Allpass.cascadeParameterUnMultiValue <$> phaserFreq) + &|& noise))))) + stringControlledEnvelope + + +phaserOsci :: + (Exp Real -> Exp Real -> Causal.T a VectorValue) -> + Causal.T a (Stereo.T VectorValue) +phaserOsci osci = + CausalPS.amplifyStereo 0.25 + . + Trav.traverse sumNested + (Stereo.cons + (zipWith osci [0.1, 0.7, 0.2, 0.3] [1.0, -0.4, 0.5, -0.7]) + (zipWith osci [0.4, 0.9, 0.6, 0.5] [0.4, -1.0, 0.7, -0.5])) + + +type + StringInstrument = + SampleRate Real -> Real -> Real -> + PIO.T + (WithEnvelopeControl + (Zip.T (Control Real) DetuneBendModControl)) + StereoChunk + +softStringShapeCore :: + (forall r. + VectorValue -> + VectorValue -> + LLVM.CodeGenFunction r VectorValue) -> + IO StringInstrument +softStringShapeCore wave = + liftA2 + (\osc env sr vel freq -> + osc sr + . + (Zip.arrowSecond $ Zip.arrowSecond $ + Zip.arrowSecond $ + arr $ transposeModulation sr freq) + . + zipEnvelope (env sr vel)) + (Render.run $ + constant frequency 5 $ \speed _sr -> + (arr Stereo.multiValue + . + Causal.envelopeStereo + . + second + (F.withArgs $ \(shape0,(det0,fm)) -> + let det = Causal.map Serial.upsample $& det0 + shape = Causal.map Serial.upsample $& shape0 + modu = frequencyFromBendModulationPacked speed fm + osci :: + Exp Real -> + Exp Real -> + Causal.T + (VectorValue, + {- wave shape parameter -} + (VectorValue, VectorValue) + {- detune, frequency modulation -}) + VectorValue + osci p d = + CausalPS.shapeModOsci wave + . + second + (CausalClass.feedFst (SigPS.constant p) + . + Causal.envelope + . + first (one + CausalPS.amplify d)) + + in phaserOsci osci $& shape &|& det &|& modu))) + stringControlledEnvelope + +arcStringStereoFM :: + (forall r. + VectorValue -> + LLVM.CodeGenFunction r VectorValue) -> + IO StringInstrument +arcStringStereoFM wave = + softStringShapeCore + (\k p -> + M.liftJoin2 Frame.amplifyMono + (WaveL.approxSine4 =<< WaveL.halfEnvelope p) + (wave =<< WaveL.replicate k p)) + +softStringShapeFM, cosineStringStereoFM, + arcSawStringStereoFM, arcSineStringStereoFM, + arcSquareStringStereoFM, arcTriangleStringStereoFM :: + IO StringInstrument +softStringShapeFM = + softStringShapeCore WaveL.rationalApproxSine1 +cosineStringStereoFM = + softStringShapeCore + (\k p -> WaveL.approxSine2 =<< WaveL.replicate k p) +arcSawStringStereoFM = arcStringStereoFM WaveL.saw +arcSineStringStereoFM = arcStringStereoFM WaveL.approxSine2 +arcSquareStringStereoFM = arcStringStereoFM WaveL.square +arcTriangleStringStereoFM = arcStringStereoFM WaveL.triangle + + +fmStringStereoFM :: + IO (SampleRate Real -> Real -> Real -> + PIO.T + (WithEnvelopeControl + (Zip.T + (Zip.T (Control Real) (Control Real)) + DetuneBendModControl)) + StereoChunk) +fmStringStereoFM = + liftA2 + (\osc env sr vel freq -> + osc sr + . + (Zip.arrowSecond $ Zip.arrowSecond $ + Zip.arrowSecond $ + arr $ transposeModulation sr freq) + . + zipEnvelope (env sr vel)) + (Render.run $ + constant frequency 5 $ \speed _sr -> + (F.withArgs $ \(env,((depth0,shape0),(det0,fm))) -> + let det = Causal.map Serial.upsample $& det0 + shape = Causal.map Serial.upsample $& shape0 + depth = + Causal.envelope $& + env &|& + (Causal.map Serial.upsample $& depth0) + modu = frequencyFromBendModulationPacked speed fm + + osci :: + Exp Real -> + Exp Real -> + Causal.T + ((VectorValue, VectorValue) + {- phase modulation depth, modulator distortion -}, + (VectorValue, VectorValue) + {- detune, frequency modulation -}) + VectorValue + osci p d = + CausalPS.osci WaveL.approxSine2 + . + ((Causal.envelope + . + second + (CausalPS.shapeModOsci WaveL.rationalApproxSine1 + . second (CausalClass.feedFst (SigPS.constant p))) + <<^ + (\((dp, ds), f) -> (dp, (ds, f)))) + &&& arr snd) + . + second + (Causal.envelope . + first (one + CausalPS.amplify d)) + + in Stereo.multiValue <$> + Causal.envelopeStereo $& + env &|& + (phaserOsci osci $& (depth &|& shape) &|& (det &|& modu)))) + stringControlledEnvelope + + + +sampledSound :: + IO (Sample.T -> + SampleRate Real -> Real -> Real -> + PIO.T + (Zip.T MIO.GateChunk DetuneBendModControl) + StereoChunk) +sampledSound = + liftA2 + (\osc freqMod smp sr vel freq -> + let pos = Sample.positions smp + in assembleParts osc smp sr vel + . + Zip.arrowSecond + ((id :: PIOId StereoChunk) + . + freqMod sr + . + (Zip.arrowSecond $ arr $ + transposeModulation sr (freq * Sample.period pos)))) + (Render.run $ \sr (amp, smp) -> + Stereo.multiValue + ^<< + Causal.stereoFromMono (resamplingProc sr (amp, smp)) + <<^ + Stereo.unMultiValue) + (Render.run $ + constant frequency 3 $ \speed _sr -> + fmap Stereo.multiValue $ + F.withArgs $ stereoFrequenciesFromDetuneBendModulation speed) + + +{- | +mainly for testing purposes +-} +sampledSoundMono :: + IO (Sample.T -> + SampleRate Real -> Real -> Real -> + PIO.T (Zip.T MIO.GateChunk BendModControl) Chunk) +sampledSoundMono = + liftA2 + (\osc freqMod smp sr vel freq -> + let pos = Sample.positions smp + in assembleParts osc smp sr vel + . + Zip.arrowSecond + ((id :: PIOId Chunk) + . + freqMod sr + . + (arr $ transposeModulation sr (freq * Sample.period pos)))) + (Render.run resamplingProc) + (Render.run $ + constant frequency 3 $ \speed _sr -> + F.withArgs $ frequencyFromBendModulationPacked speed) + +{- +We split the frequency modulation signal +in order to get a smooth frequency modulation curve. +Without (periodic) frequency modulation +we could just split the piecewise constant control curve @fm@. +-} +assembleParts :: + (CutG.Transform a, CutG.Transform b) => + (SampleRate Real -> (Real, SVL.Vector Real) -> PIO.T a b) -> + Sample.T -> SampleRate Real -> Real -> + PIO.T (Zip.T (Gate.Chunk gate) a) b +assembleParts osc smp sr vel = + let pos = Sample.positions smp + amp = 2 * amplitudeFromVelocity vel + (attack, sustain, release) = Sample.parts smp + osci smpBody = osc sr (amp, smpBody) + in mappend + (osci + (attack `SigSt.append` + SVL.cycle (SigSt.take (Sample.loopLength pos) sustain)) + . + Gate.shorten) + (osci release <<^ Zip.second) + +resamplingProc :: + SampleRate (Exp Real) -> + (Exp Real, Sig.T (MultiValue.T Real)) -> + Causal.T VectorValue VectorValue +resamplingProc _sr (amp, smp) = + CausalPS.amplify amp + . + CausalPS.pack + (Causal.frequencyModulationLinear + {- + (Sig.fromStorableVector $ + fmap (SV.concat . SVL.chunks . SVL.take 1000000) smp) + -} + smp + {- (Sig.osci WaveL.saw 0 (1 / 324 {- samplePeriod smp -})) -}) + +helixSound :: + IO (Sample.T -> + SampleRate Real -> Real -> Real -> + PIO.T + (Zip.T MIO.GateChunk + (Zip.T (Control Real) DetuneBendModControl)) + StereoChunk) +helixSound = + App.lift4 + (\helix zigZag integrate freqMod smp sr vel freq -> + let pos = Sample.positions smp + amp = 2 * amplitudeFromVelocity vel + rateFactor = + DN.divToScalar + (Sample.sampleRate smp) + (frequencyFromSampleRate sr) + releaseStart = + fromIntegral $ + Sample.loopStart pos + Sample.loopLength pos + releaseStop = + fromIntegral $ + Sample.start pos + Sample.length pos + poss = + (fromIntegral $ Sample.start pos, + fromIntegral $ Sample.loopStart pos, + fromIntegral $ Sample.loopLength pos) + in helix sr amp (Sample.period pos) + (Render.buffer $ SV.concat $ SVL.chunks $ Sample.body smp) + . + Zip.arrowFirstShorten + (mappend + (zigZag sr poss . Gate.shorten) + (integrate sr (releaseStart, releaseStop) + <<^ Zip.second)) + . + Zip.arrowSecond + (freqMod sr + . + (Zip.arrowSecond $ arr $ transposeModulation sr freq)) + . + arr (\(Zip.Cons gate (Zip.Cons speed fm)) -> + Zip.Cons (Zip.Cons gate (fmap (rateFactor*) speed)) fm)) + makeHelix + makeZigZag + makeIntegrate + (Render.run $ + constant frequency 3 $ \speed _sr -> + fmap Stereo.multiValue $ + F.withArgs $ stereoFrequenciesFromDetuneBendModulation speed) + +makeHelix :: + IO (SampleRate Real -> Real -> Real -> Render.Buffer Real -> + PIO.T (Zip.T Chunk StereoChunk) StereoChunk) +makeHelix = + Render.run $ + wrapped $ + \(Number amp) (Number per) (SampleRate _sr) smp -> + arr Stereo.multiValue + . + CausalPS.amplifyStereo amp + . + Causal.stereoFromMono + (Helix.staticPacked + Interpolation.linear + Interpolation.linear + (Expr.roundToIntFast per) per + smp + . + second (CausalPS.osciCore $< 0)) + . + arr (\(shape, freq) -> (,) shape <$> Stereo.unMultiValue freq) + +makeZigZag :: + IO (SampleRate Real -> (Real, Real, Real) -> + PIO.T (Control Real) Chunk) +makeZigZag = + Render.run $ + wrapped $ + \(Number start, Number loopStart, Number loopLength) (SampleRate _sr) -> + CausalPS.raise start + . + -- CausalPS.pack (Helix.zigZagLong (loopStart-start) loopLength) + Helix.zigZagLongPacked (loopStart-start) loopLength + . + Causal.map Serial.upsample + +makeIntegrate :: + IO (SampleRate Real -> (Real, Real) -> + PIO.T (Control Real) Chunk) +makeIntegrate = + Render.run $ + wrapped $ + \(Number start, Number stop) (SampleRate _sr) -> + Causal.takeWhile (\v -> stop >* Serial.subsample v) + . + CausalPS.integrate start + . + Causal.map Serial.upsample diff --git a/src/Synthesizer/LLVM/Server/CausalPacked/InstrumentPlug.hs b/src/Synthesizer/LLVM/Server/CausalPacked/InstrumentPlug.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Server/CausalPacked/InstrumentPlug.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE Rank2Types #-} +{- | +The Instruments in this module have the same causal arrow interface +as the ones in "Synthesizer.LLVM.Server.CausalPacked.Instrument", +but here we use the higher level interface +of the "Synthesizer.LLVM.Causal.FunctionalPlug" module. +-} +module Synthesizer.LLVM.Server.CausalPacked.InstrumentPlug ( + tineStereoFM, + helixNoise, + ) where + +import Synthesizer.LLVM.Server.CausalPacked.Instrument ( + Control, DetuneBendModControl, + WithEnvelopeControl, StereoChunk, + pingControlledEnvelope, + stringControlledEnvelope, + reorderEnvelopeControl) +import Synthesizer.LLVM.Server.CausalPacked.Common (transposeModulation) +import Synthesizer.LLVM.Server.CommonPacked (VectorValue) +import Synthesizer.LLVM.Server.Common ( + SampleRate, expSampleRate, Real, + Arg(Number), wrapped, + constant, frequency, time) + +import qualified Synthesizer.CausalIO.Process as PIO + +import qualified Synthesizer.LLVM.Frame.Stereo as Stereo +import qualified Synthesizer.LLVM.Frame.SerialVector as Serial +import qualified Synthesizer.LLVM.Causal.Helix as Helix +import qualified Synthesizer.LLVM.Causal.FunctionalPlug as FP +import qualified Synthesizer.LLVM.Causal.ProcessPacked as CausalPS +import qualified Synthesizer.LLVM.Causal.Process as Causal +import qualified Synthesizer.LLVM.Generator.SignalPacked as SigPS +import qualified Synthesizer.LLVM.Generator.Signal as Sig +import qualified Synthesizer.LLVM.Interpolation as Interpolation +import qualified Synthesizer.LLVM.Wave as WaveL +import Synthesizer.LLVM.Causal.FunctionalPlug (($&), (&|&)) + +import qualified Synthesizer.LLVM.MIDI.BendModulation as BM +import qualified Synthesizer.LLVM.MIDI as MIDIL +import qualified Synthesizer.Zip as Zip + +import qualified LLVM.DSL.Expression as Expr +import LLVM.DSL.Expression (Exp) + +import qualified LLVM.Extra.Multi.Value as MultiValue + +import Control.Category ((.)) +import Control.Applicative (liftA2, (<$>)) + +import NumericPrelude.Numeric +import NumericPrelude.Base hiding (id, (.)) + + +stereoFrequenciesFromDetuneBendModulation :: + Exp Real -> + (FP.T p inp (MultiValue.T Real), + FP.T p inp (MultiValue.T (BM.T Real))) -> + FP.T p inp (Stereo.T VectorValue) +stereoFrequenciesFromDetuneBendModulation speed (detune, freq) = + Causal.envelopeStereo $& + (MIDIL.frequencyFromBendModulationPacked speed $& + (BM.unMultiValue <$> freq)) + &|& + (Causal.map (fmap Serial.upsample) $& + liftA2 Stereo.cons (one + detune) (one - detune)) + +tineStereoFM :: + IO (SampleRate Real -> Real -> Real -> + PIO.T + (WithEnvelopeControl + (Zip.T + (Zip.T (Control Real) (Control Real)) + DetuneBendModControl)) + StereoChunk) +tineStereoFM = + liftA2 + (\osc env sr vel freq -> + osc (sr, freq) (sr, vel) + . + Zip.arrowFirstShorten (env sr vel) + . + reorderEnvelopeControl) + (FP.withArgs $ \(env, ((index0,depth0), (detune,fm))) pl -> + (\f -> case Expr.unzip pl of (sr,vel) -> f (expSampleRate sr) vel) $ + wrapped $ \(Number vel) -> + constant time 1 $ \halfLife -> + constant frequency 5 $ \speed _sr -> + let freqs = + stereoFrequenciesFromDetuneBendModulation + speed + (FP.plug detune, + FP.plug $ + liftA2 (uncurry transposeModulation) FP.askParameter fm) + index = Causal.map Serial.upsample $& FP.plug index0 + depth = Causal.map Serial.upsample $& FP.plug depth0 + expo = FP.fromSignal $ SigPS.exponential2 halfLife (1 + vel) + osci freq = + CausalPS.osci WaveL.approxSine2 $& + expo * depth * + (CausalPS.osci WaveL.approxSine2 + $& zero &|& index*freq) + &|& + freq + in fmap Stereo.multiValue $ + Causal.envelopeStereo $& + FP.plug env &|& Stereo.liftApplicative osci freqs) + (pingControlledEnvelope (Just 0.01)) + + +helixNoise :: + IO (SampleRate Real -> Real -> Real -> + PIO.T + (WithEnvelopeControl + (Zip.T (Control Real) DetuneBendModControl)) + StereoChunk) +helixNoise = + liftA2 + (\osc env sr vel freq -> + osc (sr, freq) sr + . + Zip.arrowFirstShorten (env sr vel) + . + reorderEnvelopeControl) + (FP.withArgs $ \(env, (speed0, (detune,fm))) sr -> + (\f -> f (expSampleRate sr)) $ + constant frequency 5 $ \modSpeed _sr -> + let freqs = + stereoFrequenciesFromDetuneBendModulation + modSpeed + (FP.plug detune, + FP.plug $ + liftA2 (uncurry transposeModulation) FP.askParameter fm) + speed = Causal.map Serial.upsample $& FP.plug speed0 + in fmap Stereo.multiValue $ + Causal.envelopeStereo $& + FP.plug env &|& Stereo.liftApplicative (helixOsci speed) freqs) + stringControlledEnvelope + +helixOsci :: + FP.T pp inp VectorValue -> + FP.T pp inp VectorValue -> + FP.T pp inp VectorValue +helixOsci speed freq = + CausalPS.pack + (Helix.dynamicLimited Interpolation.cubic Interpolation.cubic + 64 (64 :: Exp Real) (Sig.noise 66 0.2)) + $& + speed &|& + (CausalPS.osciCore $& 0 &|& freq) diff --git a/src/Synthesizer/LLVM/Server/CausalPacked/Speech.hs b/src/Synthesizer/LLVM/Server/CausalPacked/Speech.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Server/CausalPacked/Speech.hs @@ -0,0 +1,493 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoImplicitPrelude #-} +module Synthesizer.LLVM.Server.CausalPacked.Speech ( + loadMasks, + loadMasksGrouped, + loadMasksKeyboard, + maskNamesGrouped, + phonemeMask, + vowelMask, + vowelBand, + filterFormant, + filterFormants, + VowelSynth, + VowelSynthEnv, + EnvelopeType(..), + CarrierType(..), + PhonemeType(..), + ) where + +import Synthesizer.LLVM.Server.CausalPacked.Instrument + (StereoChunk, Control, Frequency, frequencyControl, + WithEnvelopeControl, zipEnvelope, + stringControlledEnvelope, pingControlledEnvelope) +import Synthesizer.LLVM.Server.CommonPacked (Vector) +import Synthesizer.LLVM.Server.Common + (SampleRate(SampleRate), Real, wrapped, + Arg(Frequency), constant, noiseReference) +import qualified Synthesizer.LLVM.Server.SampledSound as Sample + +import qualified Synthesizer.MIDI.CausalIO.Process as MIO +import qualified Synthesizer.CausalIO.Gate as Gate +import qualified Synthesizer.CausalIO.Process as PIO + +import qualified Synthesizer.LLVM.Frame.Stereo as Stereo +import qualified Synthesizer.LLVM.Frame.SerialVector as Serial +import qualified Synthesizer.LLVM.Filter.Universal as UniFilterL +import qualified Synthesizer.LLVM.Filter.NonRecursive as FiltNR +import qualified Synthesizer.LLVM.Causal.FunctionalPlug as FP +import qualified Synthesizer.LLVM.Causal.ControlledPacked as CtrlPS +import qualified Synthesizer.LLVM.Causal.Render as CausalRender +import qualified Synthesizer.LLVM.Causal.Process as Causal +import qualified Synthesizer.LLVM.Generator.SignalPacked as SigPS +import qualified Synthesizer.LLVM.Generator.Render as Render +import qualified Synthesizer.LLVM.Generator.Signal as Sig +import Synthesizer.LLVM.Causal.FunctionalPlug (($&), (&|&)) +import Synthesizer.LLVM.Causal.Process (($*), ($<), ($>)) + +import qualified Synthesizer.Zip as Zip +import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg + +import qualified Synthesizer.PiecewiseConstant.Signal as PC + +import qualified Synthesizer.Generic.Control as CtrlG +import qualified Synthesizer.Generic.Signal as SigG + +import qualified Synthesizer.Plain.Filter.Recursive.Universal as UniFilter +import Synthesizer.Plain.Filter.Recursive (Pole(Pole)) + +import qualified Data.StorableVector.Lazy as SVL +import qualified Data.StorableVector as SV +import qualified Data.Map as Map ; import Data.Map (Map) + +import qualified LLVM.Extra.Multi.Value as MultiValue + +import qualified System.Path as Path +import System.Path ((), (<.>)) + +import Control.Arrow (arr, second, (^<<), (<<^), (***)) +import Control.Category ((.)) +import Control.Applicative (pure, liftA, liftA3, (<$>), (<*>)) + +import Data.Traversable (Traversable, traverse, forM) + +import NumericPrelude.Numeric +import NumericPrelude.Base hiding ((.)) + + +{- +stimmhaft +a, e, i, o, u, ae, oe, ue +l, m, n, ng + +Diphtong +ai, oi, au, ui, ei + +stimmlos/Zischlaute +f, h, w, s, sch, th, ch (weich), ch (kochen), r + +plosiv +b, p, g, k, d, t +-} + +{- +Formanten: +a - 700 Hz +i - 400 Hz, 2200 Hz +o - 600 Hz, 3000 Hz +f - white noise +sch - highpass cutoff 1500 Hz +-} + +type + VowelSynth = + SampleRate Real -> VoiceMsg.Pitch -> + PIO.T (Zip.T MIO.GateChunk StereoChunk) StereoChunk + +{- | +Synthesize vowels using bandpass filters. +-} +vowelBand :: IO VowelSynth +vowelBand = + liftA + (\filt sr p -> + case formants p of + Nothing -> arr $ const SV.empty + Just fs -> + filt sr fs + . + Gate.shorten) + (CausalRender.run $ + wrapped $ \(Frequency low, Frequency high) (SampleRate _sr) -> + Stereo.multiValue + ^<< + Causal.stereoFromMono + (let lowpass q f = + UniFilter.bandpass + ^<< + CtrlPS.process + $< + Sig.constant (UniFilter.parameter $ Pole q f) + in lowpass 100 low + lowpass 20 high) + <<^ + Stereo.unMultiValue) + +formants :: VoiceMsg.Pitch -> Maybe (Real, Real) +formants p = + case VoiceMsg.fromPitch p of + 00 -> Just ( 320, 800) -- u + 02 -> Just ( 500, 1000) -- o + 04 -> Just (1000, 1400) -- a + 05 -> Just (1500, 500) -- oe + 07 -> Just (1650, 320) -- ue + 09 -> Just (1800, 700) -- ae + 11 -> Just (2300, 500) -- e + 12 -> Just (3200, 320) -- i + _ -> Nothing + + +{- | +Synthesize vowels using sampled impulse responses. +-} +vowelMask :: + IO (Map VoiceMsg.Pitch (SV.Vector Real) -> VowelSynth) +vowelMask = + liftA + (\filt dict _sr p -> + case Map.lookup p dict of + Nothing -> arr $ const SV.empty + Just mask -> filt (Render.buffer mask) . Gate.shorten) + (CausalRender.run $ \mask -> + Stereo.multiValue + ^<< + Causal.stereoFromMono (FiltNR.convolvePacked mask) + <<^ + Stereo.unMultiValue) + + +type + VowelSynthEnv = + SampleRate Real -> Real {- Velocity -} -> VoiceMsg.Pitch -> + PIO.T (WithEnvelopeControl StereoChunk) StereoChunk + +data EnvelopeType = Continuous | Percussive + deriving (Eq, Ord, Show) + +data CarrierType = Voiced | Unvoiced | Rasp + deriving (Eq, Ord, Show) + +data PhonemeType = Filtered EnvelopeType CarrierType | Sampled + deriving (Eq, Ord, Show) + +{- | +Like 'vowelMask', but it does not simply open and close the gate abruptly. +Instead we use an envelope for fading the filtered sound in and out. +-} +phonemeMask :: + IO (Map VoiceMsg.Pitch (PhonemeType, SV.Vector Real) -> VowelSynthEnv) +phonemeMask = + pure + (\filt filtRasp filtNoise smp contEnv percEnv dict sr vel p -> + case Map.lookup p dict of + Nothing -> arr $ const SV.empty + Just (typ, mask) -> + let maskBuf = Render.buffer mask in + case typ of + Filtered env carrier -> + (case carrier of + Voiced -> filt maskBuf + Unvoiced -> filtNoise sr maskBuf . arr Zip.first + Rasp -> + filtRasp maskBuf $ + case sr of + SampleRate r -> + SVL.cycle $ SVL.take (round $ r/20) $ + CtrlG.exponential SigG.defaultLazySize + (r/40) 1) + . + zipEnvelope + (case env of + Continuous -> contEnv sr vel + Percussive -> percEnv sr vel) + Sampled -> + smp (SVL.fromChunks $ repeat mask) + . + arr Zip.first + . + zipEnvelope (contEnv sr vel)) + <*> (CausalRender.run $ \mask -> + Stereo.multiValue <$> + Causal.envelopeStereo + . + second + (Causal.stereoFromMono (FiltNR.convolvePacked mask) + <<^ Stereo.unMultiValue)) + <*> (CausalRender.run $ \mask env -> + Stereo.multiValue <$> + Causal.envelopeStereo + . + ((Causal.envelope $< SigPS.pack env) + *** + (Causal.stereoFromMono (FiltNR.convolvePacked mask) + <<^ Stereo.unMultiValue))) + <*> (CausalRender.run $ + constant noiseReference 1e7 $ \noiseRef _sr mask -> + Stereo.multiValue <$> + Causal.envelopeStereo $> + traverse + (\seed -> + FiltNR.convolvePacked mask $* SigPS.noise seed noiseRef) + (Stereo.cons 42 23)) + <*> (CausalRender.run $ \smp -> + (\x -> Stereo.consMultiValue x x) + ^<< + (Causal.envelope $> SigPS.pack smp)) + <*> stringControlledEnvelope + <*> pingControlledEnvelope (Just 0.01) + + +phonemeRr, + phonemeU, + phonemeO, + phonemeA, + phonemeOe, + phonemeOn, + phonemeUe, + phonemeUn, + phonemeAe, + phonemeE, + phonemeI, + + phonemeNg, + phonemeL, + phonemeM, + phonemeN, + phonemeR, + phonemeJ, + + phonemeW, + phonemeF, + phonemeSch, + phonemeH, + phonemeTh, + phonemeIch, + phonemeAch, + phonemeS, + + phonemeP, + phonemeK, + phonemeT, + + phonemeB, + phonemeG, + phonemeD + :: (PhonemeType, FilePath) +phonemeU = (Filtered Continuous Voiced, "u") +phonemeO = (Filtered Continuous Voiced, "o") +phonemeA = (Filtered Continuous Voiced, "a") +phonemeOe = (Filtered Continuous Voiced, "oe") +phonemeOn = (Filtered Continuous Voiced, "on") +phonemeUe = (Filtered Continuous Voiced, "ue") +phonemeUn = (Filtered Continuous Voiced, "un") +phonemeAe = (Filtered Continuous Voiced, "ae") +phonemeE = (Filtered Continuous Voiced, "e") +phonemeI = (Filtered Continuous Voiced, "i") + +phonemeNg = (Filtered Continuous Voiced, "ng") +phonemeL = (Filtered Continuous Voiced, "l") +phonemeM = (Filtered Continuous Voiced, "m") +phonemeN = (Filtered Continuous Voiced, "n") +phonemeR = (Filtered Continuous Voiced, "r") +phonemeJ = (Filtered Continuous Voiced, "j") + +phonemeW = (Filtered Continuous Unvoiced, "w") +phonemeF = (Filtered Continuous Unvoiced, "f") +phonemeSch = (Filtered Continuous Unvoiced, "sch") +phonemeH = (Filtered Continuous Unvoiced, "h") +phonemeTh = (Filtered Continuous Unvoiced, "th") +phonemeIch = (Filtered Continuous Unvoiced, "ich") +phonemeAch = (Filtered Continuous Unvoiced, "ach") +phonemeS = (Filtered Continuous Unvoiced, "s") + +phonemeP = (Filtered Percussive Unvoiced, "p") +phonemeK = (Filtered Percussive Unvoiced, "k") +phonemeT = (Filtered Percussive Unvoiced, "t") + +phonemeB = (Filtered Percussive Voiced, "b") +phonemeG = (Filtered Percussive Voiced, "g") +phonemeD = (Filtered Percussive Voiced, "d") + +-- phonemeRr = (Sampled, "r")) : +phonemeRr = (Filtered Continuous Rasp, "ng") + + +maskNamesKeyboard :: Map VoiceMsg.Pitch (PhonemeType, FilePath) +maskNamesKeyboard = + Map.fromList $ + zip [VoiceMsg.toPitch 0 ..] $ + + phonemeL : phonemeNg : + phonemeM : phonemeJ : + phonemeN : + phonemeR : + phonemeP : + phonemeB : phonemeK : + phonemeG : phonemeT : + phonemeD : + + phonemeU : phonemeUe : + phonemeO : phonemeOe : + phonemeA : + phonemeE : phonemeAe : + phonemeI : + phonemeRr : + + phonemeW : phonemeF : + phonemeSch : + phonemeH : phonemeTh : + phonemeIch : phonemeAch : + phonemeS : + [] + +loadMasksKeyboard :: IO (Map VoiceMsg.Pitch (PhonemeType, SV.Vector Real)) +loadMasksKeyboard = + fmap (Map.insert (VoiceMsg.toPitch 29) + (Filtered Continuous Voiced, SV.singleton 1)) $ + loadMasks maskNamesKeyboard + + +maskNamesGrouped :: Map VoiceMsg.Pitch (PhonemeType, FilePath) +maskNamesGrouped = + Map.fromList $ + + (zip [VoiceMsg.toPitch 0 ..] $ + phonemeU : + phonemeO : + phonemeA : + phonemeOe : + phonemeUe : + phonemeAe : + phonemeE : + phonemeI : + phonemeOn : + phonemeUn : + []) + ++ + (zip [VoiceMsg.toPitch 16 ..] $ + phonemeJ : + phonemeL : + phonemeM : + phonemeN : + phonemeNg : + phonemeR : + []) + ++ + (zip [VoiceMsg.toPitch 32 ..] $ + phonemeW : + phonemeF : + phonemeSch : + phonemeH : + phonemeTh : + phonemeIch : + phonemeAch : + phonemeS : + []) + ++ + (zip [VoiceMsg.toPitch 48 ..] $ + phonemeRr : + []) + ++ + (zip [VoiceMsg.toPitch 64 ..] $ + phonemeP : + phonemeK : + phonemeT : + []) + ++ + (zip [VoiceMsg.toPitch 80 ..] $ + phonemeB : + phonemeG : + phonemeD : + []) + +loadMasksGrouped :: IO (Map VoiceMsg.Pitch (PhonemeType, SV.Vector Real)) +loadMasksGrouped = + fmap (Map.insert (VoiceMsg.toPitch 127) + (Filtered Continuous Voiced, SV.singleton 8)) $ + loadMasks maskNamesGrouped + + +loadMasks :: + (Traversable dict) => + dict (PhonemeType, FilePath) -> + IO (dict (PhonemeType, SV.Vector Real)) +loadMasks maskNames = + forM maskNames $ \(typ, name) -> + (,) typ . SV.concat . SVL.chunks <$> + Sample.load + (Path.relDir (if typ==Sampled then "phoneme" else "mask") + Path.relFile name <.> "wav") + + + +type Input a = FP.Input (SampleRate Real) a + +plugUniFilterParameter :: + Input a (Control Real) -> + Input a (Control Frequency) -> + FP.T (SampleRate Real) a (UniFilter.Parameter (MultiValue.T Real)) +plugUniFilterParameter reson freq = + fmap UniFilterL.unMultiValueParameter $ + FP.plug $ + liftA3 + (\resonChunk freqChunk sr -> + PC.zipWith + (\ r f -> UniFilter.parameter $ Pole r f) + resonChunk $ frequencyControl sr freqChunk) + reson freq FP.askParameter + + +type FormantControl = + Zip.T (Control Real) + (Zip.T (Control Real) (Control Frequency)) + +singleFormant :: + (Input inp (Control Real), + (Input inp (Control Real), Input inp (Control Frequency))) -> + Input inp StereoChunk -> + FP.T (SampleRate Real) inp (MultiValue.T (Stereo.T Vector)) +singleFormant (amp, (reson, freq)) x = + Stereo.multiValue <$> + Causal.envelopeStereo $& + (Causal.map Serial.upsample $& FP.plug amp) + &|& + (Causal.stereoFromMonoControlled + (UniFilter.bandpass ^<< CtrlPS.process) $& + plugUniFilterParameter reson freq + &|& + (Stereo.unMultiValue <$> FP.plug x)) + +filterFormant :: + IO (SampleRate Real -> + PIO.T + (Zip.T FormantControl StereoChunk) + StereoChunk) +filterFormant = + liftA + (\filt sr -> filt sr ()) + (FP.withArgs $ \(fmt, x) _unit -> singleFormant fmt x) + +filterFormants :: + IO (SampleRate Real -> + PIO.T (Zip.T + (Zip.T FormantControl + (Zip.T FormantControl + (Zip.T FormantControl + (Zip.T FormantControl FormantControl)))) + StereoChunk) + StereoChunk) +filterFormants = + liftA + (\filt sr -> filt sr ()) + (FP.withArgs $ \((fmt0, (fmt1, (fmt2, (fmt3, fmt4)))), x) _unit -> + foldl1 (+) $ map (flip singleFormant x) [fmt0, fmt1, fmt2, fmt3, fmt4]) diff --git a/src/Synthesizer/LLVM/Server/CausalPacked/SpeechExplore.hs b/src/Synthesizer/LLVM/Server/CausalPacked/SpeechExplore.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Server/CausalPacked/SpeechExplore.hs @@ -0,0 +1,370 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module Main where + +import Synthesizer.LLVM.Server.Common (Real, pioApply) + +import qualified Synthesizer.LLVM.Server.SampledSound as Sample +import qualified Sound.Sox.Write as SoxWrite + +import qualified Graphics.Gnuplot.Advanced as Plot +import qualified Graphics.Gnuplot.Terminal.WXT as WXT +import qualified Graphics.Gnuplot.Plot.TwoDimensional as Plot2D +import qualified Graphics.Gnuplot.Graph.TwoDimensional as Graph2D + +import qualified Synthesizer.LLVM.Causal.Controlled as Ctrl +import qualified Synthesizer.LLVM.Causal.Render as CausalRender +import qualified Synthesizer.LLVM.Causal.Process as Causal +import qualified Synthesizer.LLVM.Generator.Render as Render +import qualified Synthesizer.LLVM.Generator.Signal as Sig +import qualified Synthesizer.LLVM.Filter.Universal as UniFilterL +import qualified Synthesizer.LLVM.Filter.NonRecursive as FiltNR +import qualified Synthesizer.LLVM.Filter.FirstOrder as Filt1 +import Synthesizer.LLVM.Causal.Process (($*), ($<)) + +import qualified LLVM.DSL.Expression as Expr + +import qualified Synthesizer.Plain.Filter.Recursive.Universal as UniFilter +import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as FirstOrder +import Synthesizer.Plain.Filter.Recursive (Pole(Pole)) + +import qualified Synthesizer.Generic.Filter.NonRecursive as FiltNRG +import qualified Synthesizer.Generic.Fourier as Fourier +import qualified Synthesizer.Generic.Analysis as Analysis +import qualified Synthesizer.Generic.Signal as SigG +import qualified Synthesizer.Generic.Piece as Piece +import qualified Synthesizer.Causal.Filter.NonRecursive as FiltNRC +import qualified Synthesizer.Causal.Process as Causal +import qualified Synthesizer.State.Signal as SigS +import Synthesizer.Piecewise ((#|-), (-|#), (#|), (|#)) + +import qualified Data.StorableVector.Lazy as SVL +import qualified Data.StorableVector as SV + +import Control.Arrow ((<<<), (^<<)) +import Control.Category ((.)) +import Control.Applicative ((<$>)) + +import Control.Functor.HT (void) + +import qualified Data.List.HT as ListHT +import qualified Data.List as List +import Data.Foldable (forM_) +import Data.Maybe.HT (toMaybe) +import Data.Maybe (catMaybes) +import Data.Tuple.HT (mapSnd) +import Data.Ord.HT (comparing) +import Data.Semigroup ((<>)) +import Data.Monoid (mempty) +import Data.Word (Word) + +import qualified System.Path.PartClass as PathClass +import qualified System.Path as Path +import System.Path ((), (<.>)) + +import qualified Number.Complex as Complex + +import NumericPrelude.Numeric +import NumericPrelude.Base hiding (id, (.)) + + +sampleRateInt :: Int +sampleRateInt = 44100 + +sampleRate :: Real +sampleRate = fromIntegral sampleRateInt + +spectrum :: SVL.Vector Real -> SVL.Vector Real +spectrum xs = + SVL.map Complex.magnitude $ + SVL.take (div (SVL.length xs) 2) $ + Fourier.transformBackward $ + SVL.map Complex.fromReal xs + +timeDomain :: SVL.Vector Real -> SVL.Vector (Complex.T Real) +timeDomain xs = + Fourier.transformForward $ + SVL.append + (SVL.map Complex.fromReal xs) + (SVL.replicate SVL.defaultChunkSize (SVL.length xs) 0) + +chop :: Int -> SVL.Vector Real -> [SVL.Vector Real] +chop n = + map (SVL.take n) . + takeWhile (not . SVL.null) . + iterate (SVL.drop n) + +spectrumPlot :: SVL.Vector Real -> Plot2D.T Real Real +spectrumPlot xs = + let k = sampleRate / fromIntegral (SVL.length xs) + step = 16 + avg chunk = SVL.foldl (+) zero chunk / fromIntegral step + in Plot2D.list Graph2D.lines $ + zip (iterate (fromIntegral step * k +) 0) $ + map avg $ chop step $ + spectrum xs + +plotSpectrum :: SVL.Vector Real -> IO () +plotSpectrum xs = + void $ + Plot.plot WXT.cons $ + spectrumPlot xs + +saveSound :: (PathClass.AbsRel ar) => Path.File ar -> SVL.Vector Real -> IO () +saveSound path xs = + void $ SoxWrite.simple SVL.hPut mempty (Path.toString path) sampleRateInt xs + +tmpWave :: String -> Path.AbsFile +tmpWave name = Path.absDir "/tmp" Path.relFile name <.> "wav" + +phonemeWave :: String -> Path.RelFile +phonemeWave name = Path.relDir "phoneme" Path.relFile name <.> "wav" + +maskWave :: String -> Path.RelFile +maskWave name = Path.relDir "mask" Path.relFile name <.> "wav" + +loadPhoneme :: String -> IO (SVL.Vector Real) +loadPhoneme name = do + putStrLn name + Sample.load $ phonemeWave name + + +-- * modelling formants using bandpass filters + +type Formant a = (UniFilter.Result a -> a, Pole Real, Real) + +formants_a_noise :: [Formant a] +formants_a_noise = + (UniFilter.bandpass, Pole 20 900, 1) : + (UniFilter.bandpass, Pole 20 1200, 0.4) : + (UniFilter.bandpass, Pole 10 2600, 0.07) : + [] + +formants_f :: [Formant a] +formants_f = + (UniFilter.lowpass, Pole 2 4000, 0.6) : + (UniFilter.lowpass, Pole 2 11000, 0.3) : + [] + +formants_sch :: [Formant a] +formants_sch = + (UniFilter.bandpass, Pole 5 1500, 1.3) : + (UniFilter.lowpass, Pole 2 3000, 0.6) : + [] + +synthesis :: IO (SVL.ChunkSize -> SVL.Vector Real) +synthesis = + Render.run $ + (sum (map (\(typ, Pole q f, amp) -> + Causal.amplify (Expr.cons amp) + <<< + typ + ^<< + Ctrl.process + $< + (fmap UniFilterL.unMultiValueParameter $ Sig.constant $ + Expr.cons $ UniFilter.parameter $ Pole q $ f / sampleRate)) + formants_sch) + $* Sig.noise 174373 0.02) + +compareSpec ::IO () +compareSpec = do + sampled <- Sample.load (phonemeWave "sch") + synthesized <- synthesis + void $ Plot.plot WXT.cons $ + spectrumPlot sampled + <> + spectrumPlot + (SVL.take (SVL.length sampled) $ + synthesized (SVL.chunkSize 4096)) + +render ::IO () +render = do + synthesized <- synthesis + saveSound (Path.relFile "sch-synth.wav") $ + SVL.take sampleRateInt $ + synthesized (SVL.chunkSize 4096) + + +-- * purification of sampled periods + +-- ** using a comb filter + +type Comb = Real -> Word -> SVL.Vector Real -> SVL.Vector Real + +makeComb :: IO Comb +makeComb = + (\proc gain time -> pioApply (proc gain time)) + <$> + CausalRender.run Causal.comb + +makeHighComb :: IO Comb +makeHighComb = + fmap (\proc gain time -> pioApply (proc gain time)) + $ + CausalRender.run $ \gain time -> + Causal.comb gain time + . + (Filt1.highpassCausal $< + Sig.constant (FirstOrder.parameter (1000 / Expr.cons sampleRate))) + +scorePeriod :: + Comb -> Real -> Word -> SVL.Vector Real -> (Real, SVL.Vector Real) +scorePeriod comb gain period sig = + let end = SVL.takeEnd (3 * fromIntegral period) $ comb gain period sig + in (Analysis.volumeEuclideanSqr end, end) + +vowelNames :: [String] +vowelNames = ["a", "e", "i", "o", "on", "u", "un", "oe", "ue", "ae"] + +tonalNames :: [String] +tonalNames = vowelNames ++ ["l", "m", "n", "ng", "r", "j"] + +sibilantNames :: [String] +sibilantNames = ["f", "h", "w", "s", "sch", "th", "ich", "ach"] + +stopConsonantNames :: [String] +stopConsonantNames = ["p", "k", "t", "b", "g", "d"] + +scanPeriods ::IO () +scanPeriods = do + comb <- makeComb + forM_ tonalNames $ \name -> do + sampled <- loadPhoneme name + let scores = + flip map [350 .. 400] $ \period -> + (period, + flip map [0.9, 0.99, 0.999] $ \gain -> + fst $ scorePeriod comb gain period sampled) + -- mapM_ print scores + putStrLn $ + "maximum: " ++ + show (List.maximumBy (comparing snd) $ map (mapSnd maximum) scores) + + +normalize :: SVL.Vector Real -> SVL.Vector Real +normalize = + FiltNRG.normalize ((4*) . Analysis.volumeEuclidean) + + +{- +We use the zero with the least derivative +in order to reduce jumps at the loop point. +In order to further reduce jumps, we cross-fade two adjacent periods. +It must be @length period3 = 3*len@. +@period3@ must contain a zero in the center chunk of size @len@. +-} +bestRotation :: Int -> SVL.Vector Real -> SVL.Vector Real +bestRotation len period3 = + let start = + fst $ + List.minimumBy (comparing snd) $ catMaybes $ + zipWith (fmap . (,)) [0..] $ + ListHT.mapAdjacent + (\x y -> toMaybe (signum x /= signum y) (abs(x-y))) $ + SVL.unpack $ SVL.take len $ SVL.drop (len-1) period3 + in Causal.apply + (Causal.applyFst + (FiltNRC.crossfade len) + (SVL.drop (start+len) period3)) + (SVL.drop start period3) + +findPeriod :: Comb -> SVL.Vector Real -> SVL.Vector Real +findPeriod comb sampled = + normalize $ + uncurry (bestRotation . fromIntegral) $ + mapSnd snd $ + List.maximumBy (comparing (fst . snd)) $ + flip map [350 .. 400] $ \period -> + (period, scorePeriod comb 0.99 period sampled) + +extractPeriods ::IO () +extractPeriods = do + comb <- makeHighComb + forM_ tonalNames $ \name -> + saveSound (maskWave name) . findPeriod comb =<< loadPhoneme name + + +-- ** using the frequency spectrum + +makeFilter :: IO (SV.Vector Real -> SVL.Vector Real -> SVL.Vector Real) +makeFilter = + (\proc mask -> pioApply (proc (Render.buffer mask))) + <$> + CausalRender.run FiltNR.convolve + +normalizeMax :: SVL.Vector Real -> SVL.Vector Real +normalizeMax = FiltNRG.normalize Analysis.volumeMaximum + +envelope :: Int -> SVL.Vector Real +envelope sizeInt = + let size = fromIntegral sizeInt + rampSize = size / 8 + in Piece.run SigG.defaultLazySize $ + 0 |# (rampSize, Piece.cosine) #|- + 1 -|# (size-2*rampSize, Piece.step) #|- + 1 -|# (rampSize, Piece.cosine) #| (0::Float) + +data Transfer = + Transfer { + transferSpectrum, + transferShrunkenSpectrum, + transferEnvelope, + transferWindow :: SVL.Vector Real + } + +transfer :: SVL.Vector Real -> Transfer +transfer sampled = + let halfResponseSize = 256 + responseSize = 2*halfResponseSize + halfShrink = div (SVL.length sampled) (2*responseSize) + shrink = 2*halfShrink + spec = spectrum $ SVL.take (shrink*responseSize) sampled + shrunkenSpec = + SigG.fromState SigG.defaultLazySize $ + SigS.init $ SigS.cons 0 $ SigS.map SigG.sum $ + SigG.sliceVertical shrink $ SVL.drop halfShrink spec + env = envelope responseSize + window = + FiltNRG.envelope env $ + uncurry (flip SVL.append) $ + SVL.splitAt halfResponseSize $ + normalizeMax $ SVL.map Complex.real $ + timeDomain shrunkenSpec + in Transfer { + transferSpectrum = spec, + transferShrunkenSpectrum = shrunkenSpec, + transferEnvelope = env, + transferWindow = window + } + +testTransfer ::IO () +testTransfer = do + trans <- transfer <$> Sample.load (phonemeWave "o-noise") + filt <- makeFilter + saveSound (tmpWave "spectrum") $ + normalizeMax $ transferSpectrum trans + saveSound (tmpWave "shrunkenspectrum") $ + normalizeMax $ transferShrunkenSpectrum trans + saveSound (tmpWave "envelope") $ transferEnvelope trans + saveSound (tmpWave "window") $ transferWindow trans + let window = SV.concat $ SVL.chunks $ transferWindow trans + saveSound (tmpWave "filtered") $ + filt window $ SVL.concat $ replicate 100 $ SVL.cons 1 $ + SVL.replicate SVL.defaultChunkSize 380 0 + saveSound (tmpWave "chirp") $ + filt window $ SVL.concat $ + map (\n -> SVL.cons 1 $ SVL.replicate SVL.defaultChunkSize n 0) $ + [350..450] + +transferMasks ::IO () +transferMasks = do +-- forM_ (map (++"-noise") vowelNames) $ \name -> do + forM_ (tonalNames++sibilantNames++stopConsonantNames) $ \name -> do + trans <- transfer <$> loadPhoneme name + saveSound (maskWave name) $ normalize $ transferWindow trans + let spectrumPath = tmpWave $ "spec-" ++ name + saveSound spectrumPath $ normalizeMax $ transferShrunkenSpectrum trans + + +main :: IO () +main = transferMasks diff --git a/src/Synthesizer/LLVM/Server/Common.hs b/src/Synthesizer/LLVM/Server/Common.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Server/Common.hs @@ -0,0 +1,342 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE EmptyDataDecls #-} +module Synthesizer.LLVM.Server.Common ( + Real, + SampleRate(SampleRate), expSampleRate, + Instrument, + ($+), + constant, ($++), + frequency, time, noiseReference, number, + Quantity(..), Arg(..), Frequency, Time, Number, + Input(..), InputArg(..), Parameter, Control, Signal, + ArgTuple(..), + Wrapped(..), + amplitudeFromVelocity, + ($/), + + piecewiseConstant, + transposeModulation, + + pioApply, + pioApplyCont, + pioApplyToLazyTime, + + controllerAttack, controllerDetune, controllerTimbre0, controllerTimbre1, + controllerFilterCutoff, controllerFilterResonance, + controllerVolume, + ) where + +import qualified Synthesizer.LLVM.Generator.Signal as Sig +import qualified Synthesizer.LLVM.Private.Render as Render +import Synthesizer.LLVM.Causal.Process (($*)) + +import qualified Synthesizer.LLVM.MIDI.BendModulation as BM +import qualified Synthesizer.LLVM.ConstantPiece as Const +import qualified Synthesizer.MIDI.Storable as MidiSt +import qualified Synthesizer.MIDI.EventList as Ev +import qualified Synthesizer.PiecewiseConstant.Signal as PC +import qualified Synthesizer.CausalIO.Process as PIO +import qualified Synthesizer.Generic.Signal as SigG + +import qualified Sound.MIDI.Controller as Ctrl +import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg + +import qualified LLVM.DSL.Render.Argument as Arg +import qualified LLVM.DSL.Expression as Expr +import LLVM.DSL.Expression (Exp) + +import qualified LLVM.Extra.Multi.Value.Marshal as Marshal +import qualified LLVM.Extra.Multi.Value as MultiValue +import qualified LLVM.Extra.Memory as Memory + +import qualified Data.StorableVector.Lazy as SVL +import qualified Data.StorableVector as SV +import Foreign.Storable (Storable) + +import qualified Numeric.NonNegative.Chunky as NonNegChunky +import qualified Numeric.NonNegative.Wrapper as NonNegW + +import Control.Applicative (Applicative, liftA2, pure, (<*>), (<$>)) + +import qualified Data.Traversable as Trav +import qualified Data.Foldable as Fold + +import qualified System.Unsafe as Unsafe + +import qualified Algebra.Transcendental as Trans +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring + +import NumericPrelude.Numeric +import NumericPrelude.Base +import Prelude () + + + +type Real = Float + +type Instrument a sig = SampleRate a -> MidiSt.Instrument a sig + + +newtype SampleRate a = SampleRate a + deriving (Show) + +instance Functor SampleRate where + fmap f (SampleRate sr) = SampleRate (f sr) + +instance Fold.Foldable SampleRate where + foldMap f (SampleRate sr) = f sr + +instance Trav.Traversable SampleRate where + traverse f (SampleRate sr) = SampleRate <$> f sr + +instance Applicative SampleRate where + pure = SampleRate + SampleRate f <*> SampleRate sr = SampleRate $ f sr + + +instance (Render.RunArg a) => Render.RunArg (SampleRate a) where + type DSLArg (SampleRate a) = SampleRate (Render.DSLArg a) + buildArg = + case Render.buildArg of + Arg.Cons pass create -> + Arg.Cons + (SampleRate . pass) + (\(SampleRate sr) -> create sr) + +instance (MultiValue.C a) => MultiValue.C (SampleRate a) where + type Repr (SampleRate a) = MultiValue.Repr a + cons = multiValueSampleRate . fmap MultiValue.cons + undef = multiValueSampleRate $ pure MultiValue.undef + zero = multiValueSampleRate $ pure MultiValue.zero + phi bb = + fmap multiValueSampleRate . + Trav.traverse (MultiValue.phi bb) . unMultiValueSampleRate + addPhi bb a b = + Fold.sequence_ $ + liftA2 (MultiValue.addPhi bb) + (unMultiValueSampleRate a) (unMultiValueSampleRate b) + +instance (Marshal.C a) => Marshal.C (SampleRate a) where + pack (SampleRate a) = Marshal.pack a + unpack = SampleRate . Marshal.unpack + +multiValueSampleRate :: + SampleRate (MultiValue.T a) -> MultiValue.T (SampleRate a) +multiValueSampleRate (SampleRate (MultiValue.Cons a)) = MultiValue.Cons a + +unMultiValueSampleRate :: + MultiValue.T (SampleRate a) -> SampleRate (MultiValue.T a) +unMultiValueSampleRate (MultiValue.Cons a) = SampleRate (MultiValue.Cons a) + + +expSampleRate :: Exp (SampleRate a) -> SampleRate (Exp a) +expSampleRate = SampleRate . Expr.lift1 MultiValue.cast + + + +($/) :: (Functor f) => f (a -> b) -> a -> f b +f $/ x = fmap ($ x) f + + +infixr 0 $+, $++ + +($+) :: + (SampleRate a -> b -> c) -> + (c -> SampleRate a -> d) -> + SampleRate a -> b -> d +(p$+f) sampleRate param = f (p sampleRate param) sampleRate + +($++) :: + (SampleRate a -> b -> c, b) -> + (c -> SampleRate a -> d) -> + SampleRate a -> d +((p,param)$++f) sampleRate = f (p sampleRate param) sampleRate + +constant :: + (SampleRate a -> b -> c) -> b -> + (c -> SampleRate a -> d) -> + SampleRate a -> d +constant p param f sampleRate = f (p sampleRate param) sampleRate + + +frequency :: (Field.C a) => SampleRate a -> a -> a +frequency (SampleRate sr) param = param / sr + +time :: (Ring.C a) => SampleRate a -> a -> a +time (SampleRate sr) param = param * sr + +noiseReference :: (Field.C a) => SampleRate a -> a -> a +noiseReference (SampleRate sr) freq = sr/freq + +number :: SampleRate a -> a -> a +number = flip const + + +data Number +data Frequency +data Time +data NoiseReference + +class Quantity quantity a where + data Arg quantity a + eval :: SampleRate a -> a -> Arg quantity a + +instance Quantity Number a where + data Arg Number a = Number a + eval sampleRate a = Number $ number sampleRate a + +instance (Field.C a) => Quantity Frequency a where + data Arg Frequency a = Frequency a + eval sampleRate a = Frequency $ frequency sampleRate a + +instance (Ring.C a) => Quantity Time a where + data Arg Time a = Time a + eval sampleRate a = Time $ time sampleRate a + +instance (Field.C a) => Quantity NoiseReference a where + data Arg NoiseReference a = NoiseReference a + eval sampleRate a = NoiseReference $ noiseReference sampleRate a + + +class Input signal a where + data InputArg signal a + type InputSource signal a + evalInput :: SampleRate a -> InputSource signal a -> InputArg signal a + +data Parameter b + +instance Input (Parameter b) a where + data InputArg (Parameter b) a = Parameter b + type InputSource (Parameter b) a = b + evalInput _sr = Parameter + +data Control b + +instance Input (Control b) a where + data InputArg (Control b) a = Control (Sig.T b) + type InputSource (Control b) a = Sig.T b + evalInput _sr = Control + +data Signal b + +instance Input (Signal b) a where + data InputArg (Signal b) a = Signal (Sig.T b) + type InputSource (Signal b) a = Sig.T b + evalInput _sr = Signal + + +class ArgTuple a tuple where + type ArgPlain tuple + evalTuple :: SampleRate a -> ArgPlain tuple -> tuple + +instance (Quantity quantity b, a ~ b) => ArgTuple a (Arg quantity b) where + type ArgPlain (Arg quantity b) = b + evalTuple = eval + +instance (Input signal b, a ~ b) => ArgTuple a (InputArg signal b) where + type ArgPlain (InputArg signal b) = InputSource signal b + evalTuple = evalInput + +instance (ArgTuple a b, ArgTuple a c) => ArgTuple a (b,c) where + type ArgPlain (b,c) = (ArgPlain b, ArgPlain c) + evalTuple sampleRate (b,c) = (evalTuple sampleRate b, evalTuple sampleRate c) + +instance (ArgTuple a b, ArgTuple a c, ArgTuple a d) => ArgTuple a (b,c,d) where + type ArgPlain (b,c,d) = (ArgPlain b, ArgPlain c, ArgPlain d) + evalTuple sampleRate (b,c,d) = + (evalTuple sampleRate b, evalTuple sampleRate c, evalTuple sampleRate d) + + + +class Wrapped a f where + type Unwrapped f + wrapped :: f -> SampleRate a -> Unwrapped f + +instance (a ~ b) => Wrapped a (SampleRate b -> f) where + type Unwrapped (SampleRate b -> f) = f + wrapped f = f + +instance + (a ~ b, Quantity quantity b, Wrapped a f) => + Wrapped a (Arg quantity b -> f) where + type Unwrapped (Arg quantity b -> f) = b -> Unwrapped f + wrapped f sampleRate arg = + wrapped (f (eval sampleRate arg)) sampleRate + +instance + (a ~ b, Input signal b, Wrapped a f) => + Wrapped a (InputArg signal b -> f) where + type Unwrapped (InputArg signal b -> f) = + InputSource signal b -> Unwrapped f + wrapped f sampleRate arg = + wrapped (f (evalInput sampleRate arg)) sampleRate + +instance + (ArgTuple a b, ArgTuple a c, Wrapped a f) => + Wrapped a ((b,c) -> f) where + type Unwrapped ((b,c) -> f) = (ArgPlain b, ArgPlain c) -> Unwrapped f + wrapped f sampleRate arg = + wrapped (f (evalTuple sampleRate arg)) sampleRate + +instance + (ArgTuple a b, ArgTuple a c, ArgTuple a d, Wrapped a f) => + Wrapped a ((b,c,d) -> f) where + type Unwrapped ((b,c,d) -> f) = + (ArgPlain b, ArgPlain c, ArgPlain d) -> Unwrapped f + wrapped f sampleRate arg = + wrapped (f (evalTuple sampleRate arg)) sampleRate + + +{-# INLINE amplitudeFromVelocity #-} +amplitudeFromVelocity :: (Trans.C a) => a -> a +amplitudeFromVelocity vel = fromInteger 4 ^? vel + + +piecewiseConstant :: (Memory.C a) => Sig.T (Const.T a) -> Sig.T a +piecewiseConstant = Const.flatten + +transposeModulation :: (Field.C a, Expr.Aggregate a am) => + SampleRate a -> a -> Sig.T (Const.T (BM.T am)) -> Sig.T (Const.T (BM.T am)) +transposeModulation (SampleRate sampleRate) freq xs = + Const.causalMap (BM.shift (freq/sampleRate)) $* xs + + + +pioApply :: + (Storable a, Storable b) => + PIO.T (SV.Vector a) (SV.Vector b) -> SVL.Vector a -> SVL.Vector b +pioApply = pioApplyCont (const SVL.empty) + +pioApplyCont :: + (Storable a, Storable b) => + (SVL.Vector a -> SVL.Vector b) -> + PIO.T (SV.Vector a) (SV.Vector b) -> SVL.Vector a -> SVL.Vector b +pioApplyCont cont proc sig = Unsafe.performIO $ do + act <- PIO.runStorableChunkyCont proc + return $ act cont sig + +pioApplyToLazyTime :: + (Storable b) => + PIO.T SigG.LazySize (SV.Vector b) -> Ev.LazyTime -> SVL.Vector b +pioApplyToLazyTime proc sig = Unsafe.performIO $ do + act <- PIO.runCont proc + return $ SVL.fromChunks $ act (const []) $ + map (SigG.LazySize . NonNegW.toNumber) $ + concatMap PC.chopLongTime $ NonNegChunky.toChunks sig + + + +controllerAttack, controllerDetune, controllerTimbre0, controllerTimbre1, + controllerFilterCutoff, controllerFilterResonance, + controllerVolume :: VoiceMsg.Controller +controllerAttack = Ctrl.attackTime +controllerDetune = Ctrl.chorusDepth -- Ctrl.effect3Depth +controllerTimbre0 = Ctrl.soundVariation +controllerTimbre1 = Ctrl.timbre +controllerFilterCutoff = Ctrl.effect4Depth +controllerFilterResonance = Ctrl.effect5Depth +controllerVolume = Ctrl.volume diff --git a/src/Synthesizer/LLVM/Server/CommonPacked.hs b/src/Synthesizer/LLVM/Server/CommonPacked.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Server/CommonPacked.hs @@ -0,0 +1,47 @@ +module Synthesizer.LLVM.Server.CommonPacked where + +import Synthesizer.LLVM.Server.Common + +import qualified Synthesizer.LLVM.Frame.SerialVector.Code as Serial + +import qualified Data.NonEmpty as NonEmpty + +import qualified Type.Data.Num.Decimal as TypeNum + +import qualified Algebra.Field as Field +import qualified Algebra.Additive as Additive + +import NumericPrelude.Numeric +import NumericPrelude.Base +import Prelude () + + +sumNested :: (Additive.C a) => [a] -> a +sumNested = + maybe Additive.zero (NonEmpty.foldBalanced (+)) . NonEmpty.fetch + + +-- maybe this can be merged into a PCS.controllerDiscrete +stair :: Real -> Real +stair i = + let n = fromIntegral (round i :: Int) + r = i - n + in n + 0.01*r + + +type Vector = Serial.T VectorSize Real +type VectorValue = Serial.Value VectorSize Real +type VectorSize = TypeNum.D4 + + +-- ToDo: generalize to Integral class +vectorSize :: Int +vectorSize = + TypeNum.integralFromSingleton + (TypeNum.singleton :: TypeNum.Singleton VectorSize) + +vectorRate :: (Field.C a) => SampleRate a -> a +vectorRate (SampleRate sr) = sr / fromIntegral vectorSize + +vectorTime :: (Field.C a) => SampleRate a -> a -> a +vectorTime (SampleRate sr) param = param * sr / fromIntegral vectorSize diff --git a/src/Synthesizer/LLVM/Server/Packed/Instrument.hs b/src/Synthesizer/LLVM/Server/Packed/Instrument.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Server/Packed/Instrument.hs @@ -0,0 +1,1506 @@ +{- +ToDo: +organization: + compile instrument when switching a MIDI program + However caching and sharing might be a good idea + like for quickly changing between tomatensalat syllabels. + Ideally we just need to run instrument generation using unsafeInterleaveIO. + This however will trigger instrument compilation + when the sound is played the first time. + This may cause buffer underruns. + On the other hand, forcing instrument compilation on program changes + might still cause buffer underruns. + + +instruments: + tonal noise can be produced by modulating pink noise + experimental: multiply with waveforms other than sine + use bits of an ASCII code as waveform + use a greymap picture as source of waveforms + mix of detuned noisy-waverforms, try different and uniform waveforms + mix of sawtooth, where every sawtooth is modulated with red noise + mix of sine with harmonics where every harmonic is modulated differently + Flute: sine + filtered noise + Drum with various parameters + derive percussive instruments from fmString and arcString (for bass synths) + an FM sound with a slowly changing timbre + by using a very slightly detuned frequency for the modulator + making a tone out of noise using time stretch with helix algorithm + a chorus effect could be applied by two successive helix stretches + or by mixture of two stretches signals + additionally a resonant filter could be applied + a kind of Karplus-Strong algorithm with a non-linear function of past values + e.g. y(t) = f(y(t-d), y(t-2*d)) + where d is the tone period and f is non-linear, maybe chaotic function. + In order to limit the appearance of chaotic waveforms, + we could combine this with a lowpass filter. + let attack and release depend on On and Off velocity + tineStereoFM: + continuous control of the modulation index + by linear interpolation of waves between modulations with integral indices. + E.g. modulation index 2.3 means + 0.7*modulation with index 2 and 0.3*modulation with index 3. + +effects: + reverb and controllable delay + phaser or Chebyshev filter + reverb where many single combs are mixed + every comb has ever-increasing frequency, but is faded in and out. + Should give an endless effect where the reverb becomes higher and higher. + +continuous sounds: + fly + water/bubbles + when I accidentally did not scale filter frequency with sample rate, + the filter sound much like water bubbles. + I think a control curve consisting of some ramps will do the same. + hail, Geiger counter, pitch applied by comb filter + at a very high impulse rate the impulses itself + can generate an almost periodic signal + + +Speech sounds improvements (tomatensalat) + use PSOLA for transposition + To this end divide signal into tonal part and residue (noise) + by a comb filter. + Maybe a non-linear comb filter may help, + that selects the center value from the filter window, + if the side values are similar + and returns zero, if the the side values differ too much. + Process the tonal part by PSOLA and + simply mix it with the non-tonal part on replay. + +Harmonizer-like: + We like to input an audio signal of speech + and a set of keys, and the speech is extended to chords + according to the pressed keys. + The lowest key is interpreted as base frequency of the input audio speech. + A PSOLA method transposes the audio input. + +Resonant filter controlled by keys + applied to an audio input signal + or an ordinary audio signal generated by other keys. + The splitting of keys however could be performed + by a MIDI event stream editor. +-} + +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE EmptyDataDecls #-} +module Synthesizer.LLVM.Server.Packed.Instrument ( + InputArg(..), + FrequencyControl, + Modulation, + DetuneModulation, + + pingRelease, + pingStereoRelease, + pingStereoReleaseFM, + squareStereoReleaseFM, + bellStereoFM, + bellNoiseStereoFM, + tine, + tineStereo, + softString, + softStringFM, + tineStereoFM, + tineControlledFM, + fenderFM, + tineModulatorBankFM, + tineBankFM, + resonantFMSynth, + softStringDetuneFM, + softStringShapeFM, cosineStringStereoFM, + arcSineStringStereoFM, arcTriangleStringStereoFM, + arcSquareStringStereoFM, arcSawStringStereoFM, + fmStringStereoFM, + wind, + windPhaser, + filterSawStereoFM, + brass, + sampledSound, + + -- * helper functions + stereoNoise, + frequencyFromBendModulation, + piecewiseConstantVector, + + -- * for testing + pingReleaseEnvelope, + adsr, + ) where + +import Synthesizer.LLVM.Server.CommonPacked +import Synthesizer.LLVM.Server.Common + +import qualified Synthesizer.LLVM.Server.SampledSound as Sample +import qualified Synthesizer.LLVM.MIDI.BendModulation as BM +import qualified Synthesizer.LLVM.ConstantPiece as Const +import qualified Synthesizer.MIDI.PiecewiseConstant as PC +import qualified Synthesizer.MIDI.EventList as Ev + +import Synthesizer.MIDI.Storable (chunkSizesFromLazyTime) + +import qualified Synthesizer.LLVM.Frame.Stereo as Stereo +import qualified Synthesizer.LLVM.Filter.Universal as UniFilterL +import qualified Synthesizer.LLVM.Filter.Allpass as Allpass +import qualified Synthesizer.LLVM.Filter.Moog as MoogL +import qualified Synthesizer.LLVM.MIDI as MIDIL +import qualified Synthesizer.LLVM.Causal.Render as CausalRender +import qualified Synthesizer.LLVM.Causal.ControlledPacked as CtrlPS +import qualified Synthesizer.LLVM.Causal.ProcessPacked as CausalPS +import qualified Synthesizer.LLVM.Causal.Process as Causal +import qualified Synthesizer.LLVM.Causal.Functional as F +import qualified Synthesizer.LLVM.Generator.Render as Render +import qualified Synthesizer.LLVM.Generator.SignalPacked as SigPS +import qualified Synthesizer.LLVM.Generator.Signal as Sig +import qualified Synthesizer.LLVM.Storable.Signal as SigStL +import qualified Synthesizer.LLVM.Frame.SerialVector as Serial +import qualified Synthesizer.LLVM.Frame as Frame +import qualified Synthesizer.LLVM.Wave as WaveL +import Synthesizer.LLVM.Causal.Process (($<#), ($*), ($<), ($>)) +import Synthesizer.LLVM.Causal.Functional (($&), (&|&)) + +import qualified LLVM.DSL.Expression as Expr +import qualified LLVM.Extra.Multi.Value as MultiValue +import LLVM.DSL.Expression (Exp) + +import qualified LLVM.Extra.Arithmetic as A +import qualified LLVM.Core as LLVM +import qualified Type.Data.Num.Decimal as TypeNum + +import qualified Synthesizer.Causal.Class as CausalClass +import qualified Synthesizer.Generic.Cut as CutG +import qualified Synthesizer.Storable.Signal as SigSt +import qualified Data.StorableVector.Lazy.Pattern as SVP +import qualified Data.StorableVector.Lazy as SVL + +import qualified Synthesizer.Plain.Filter.Recursive.Universal as UniFilter + +import qualified Control.Monad.HT as M +import Control.Arrow ((<<<), (^<<), (<<^), (&&&), (***), arr, first, second) +import Control.Category (id) +import Control.Applicative (liftA2, liftA3) + +import qualified Data.Traversable as Trav +import Data.Traversable (traverse) +import Data.Semigroup ((<>)) + +import Data.Tuple.HT (fst3, snd3, thd3) + +import qualified Numeric.NonNegative.Chunky as NonNegChunky + +import qualified Algebra.Additive as Additive + +import NumericPrelude.Numeric (zero, one, round, (^?), (+), (-), (*)) +import Prelude hiding (Real, round, break, id, (+), (-), (*)) + + + +frequencyControl :: + (MultiValue.Field a, MultiValue.RationalConstant a) => + SampleRate (Exp a) -> + Sig.T (Const.T (MultiValue.T a)) -> + Sig.T (Const.T (MultiValue.T a)) +frequencyControl sr xs = Const.causalMap (frequency sr) $* xs + +data FrequencyControl a + +instance + (a ~ Exp b, MultiValue.Field b, MultiValue.RationalConstant b) => + Input (FrequencyControl b) a where + data InputArg (FrequencyControl b) a = + FrequencyControl (Sig.T (Const.T (MultiValue.T b))) + type InputSource (FrequencyControl b) a = + Sig.T (Const.T (MultiValue.T b)) + evalInput sampleRate = + FrequencyControl . frequencyControl sampleRate + + +modulation :: + (MultiValue.Field a, MultiValue.RationalConstant a) => + SampleRate (Exp a) -> + (Sig.T (Const.T (MultiValue.T (BM.T a))), Exp a) -> + Sig.T (Const.T (BM.T (MultiValue.T a))) +modulation sr (fm,freq) = + transposeModulation sr freq (fmap BM.unMultiValue <$> fm) + +data Modulation a + +instance + (a ~ Exp b, MultiValue.Field b, MultiValue.RationalConstant b) => + Input (Modulation b) a where + data InputArg (Modulation b) a = + Modulation (Sig.T (Const.T (BM.T (MultiValue.T b)))) + type InputSource (Modulation b) a = + (Sig.T (Const.T (MultiValue.T (BM.T b))), Exp b) + evalInput sampleRate (fm,freq) = + Modulation $ modulation sampleRate (fm,freq) + + +detuneModulation :: + (MultiValue.Field a, MultiValue.RationalConstant a) => + SampleRate (Exp a) -> + (b, Sig.T (Const.T (MultiValue.T (BM.T a))), Exp a) -> + (b, Sig.T (Const.T (BM.T (MultiValue.T a)))) +detuneModulation sr (det,fm,freq) = + (det, transposeModulation sr freq (fmap BM.unMultiValue <$> fm)) + +data DetuneModulation a + +instance + (a ~ Exp b, MultiValue.Field b, MultiValue.RationalConstant b) => + Input (DetuneModulation b) a where + data InputArg (DetuneModulation b) a = + DetuneModulation + (Sig.T (Const.T (MultiValue.T b)), + Sig.T (Const.T (BM.T (MultiValue.T b)))) + type InputSource (DetuneModulation b) a = + (Sig.T (Const.T (MultiValue.T b)), + Sig.T (Const.T (MultiValue.T (BM.T b))), + Exp b) + evalInput sampleRate (det,fm,freq) = + DetuneModulation $ detuneModulation sampleRate (det,fm,freq) + + +type RealValue = MultiValue.T Real + +frequencyFromBendModulation :: + Exp Real -> + Sig.T (Const.T (BM.T RealValue)) -> + Sig.T VectorValue +frequencyFromBendModulation speed fmFreq = + MIDIL.frequencyFromBendModulationPacked speed $* piecewiseConstant fmFreq + +stereoFrequenciesFromDetuneBendModulation :: + Exp Real -> + (Sig.T (Const.T RealValue), Sig.T (Const.T (BM.T RealValue))) -> + Sig.T (Stereo.T VectorValue) +stereoFrequenciesFromDetuneBendModulation speed (det,fm) = + (Causal.envelopeStereo $< frequencyFromBendModulation speed fm) + <<< + liftA2 Stereo.cons (one + id) (one - id) + $* piecewiseConstantVector det + +piecewiseConstantVector :: Sig.T (Const.T RealValue) -> Sig.T VectorValue +piecewiseConstantVector xs = + piecewiseConstant (Const.causalMap Serial.upsample $* xs) + +pingReleaseEnvelope :: + IO (Real -> Real -> + SigSt.ChunkSize -> + SampleRate Real -> Real -> Ev.LazyTime -> SigSt.T Vector) +pingReleaseEnvelope = + liftA2 + (\pressed release decay rel vcsize sr vel dur -> + SigStL.continuePacked + (pioApplyToLazyTime (pressed sr decay vel) dur) + (\x -> release vcsize sr rel x)) + (CausalRender.run $ + wrapped $ \(Time decay) (Number velocity) (SampleRate _sr) -> + Causal.fromSignal + (SigPS.exponential2 decay (amplitudeFromVelocity velocity))) + (Render.run $ + wrapped $ \(Time releaseHL) (Number amplitude) (SampleRate _sr) -> + let releaseTime = releaseHL * 5 / fromIntegral vectorSize + in Causal.take (Expr.roundToIntFast releaseTime) $* + SigPS.exponential2 releaseHL amplitude) + +pingRelease :: + IO (Real -> Real -> SigSt.ChunkSize -> Instrument Real Vector) +pingRelease = + liftA2 + (\osc env dec rel vcsize sr vel freq dur -> + pioApply (osc sr freq) (env dec rel vcsize sr vel dur)) + (CausalRender.run $ wrapped $ \(Frequency freq) (SampleRate _sr) -> + Causal.envelope $> SigPS.osci WaveL.saw zero freq) + pingReleaseEnvelope + +pingStereoRelease :: + IO (Real -> Real -> SigSt.ChunkSize -> Instrument Real (Stereo.T Vector)) +pingStereoRelease = + liftA2 + (\osc env dec rel vcsize sr vel freq dur -> + pioApply (osc sr freq) (env dec rel vcsize sr vel dur)) + (CausalRender.run $ wrapped $ \(Frequency freq) (SampleRate _sr) -> + Stereo.multiValue <$> + Causal.envelopeStereo $> + liftA2 Stereo.cons + (SigPS.osci WaveL.saw zero (0.999*freq)) + (SigPS.osci WaveL.saw zero (1.001*freq))) + pingReleaseEnvelope + +pingStereoReleaseFM :: + IO (Real -> Real -> + PC.T Real -> + PC.T Real -> + Real -> Real -> + SigSt.ChunkSize -> + PC.T (BM.T Real) -> + Instrument Real (Stereo.T Vector)) +pingStereoReleaseFM = + liftA2 + (\osc env dec rel detune shape phase phaseDecay vcsize fm + sr vel freq dur -> + pioApply + (osc sr (phase, phaseDecay) shape (detune, fm, freq)) + (env dec rel vcsize sr vel dur)) + (CausalRender.run $ + wrapped $ + \(Number phase, Time decay) (Control shape) (DetuneModulation fm) -> + constant frequency 10 $ \speed _sr -> + Stereo.multiValue <$> + Causal.envelopeStereo $> + ((Causal.stereoFromMonoControlled + (CausalPS.shapeModOsci WaveL.rationalApproxSine1) + $< piecewiseConstantVector shape) + <<^ Stereo.interleave + $< (liftA2 Stereo.cons id (Additive.negate id) + $* SigPS.exponential2 decay phase) + $* stereoFrequenciesFromDetuneBendModulation speed fm)) + pingReleaseEnvelope + +{- | +Square like wave constructed as difference +of two phase shifted sawtooth like oscillations. +-} +squareStereoReleaseFM :: + IO (Real -> Real -> + PC.T Real -> + PC.T Real -> + PC.T Real -> + SigSt.ChunkSize -> + PC.T (BM.T Real) -> + Instrument Real (Stereo.T Vector)) +squareStereoReleaseFM = + liftA2 + (\osc env dec rel detune shape phase vcsize fm sr vel freq dur -> + pioApply + (osc sr (phase, shape) (detune, fm, freq)) + (env dec rel vcsize sr vel dur)) + (CausalRender.run $ + wrapped $ \(Control phs, Control shp) (DetuneModulation fm) -> + constant frequency 10 $ \speed _sr -> + (let chanOsci :: + Causal.T + ((VectorValue, VectorValue), VectorValue) + VectorValue + chanOsci = + ((CausalPS.shapeModOsci WaveL.rationalApproxSine1 + <<< + second (first (Additive.negate id))) + - + CausalPS.shapeModOsci WaveL.rationalApproxSine1) + <<^ + (\((p,s),f) -> (s,(p,f))) + in Stereo.multiValue <$> + Causal.envelopeStereo $> + ((Causal.stereoFromMonoControlled chanOsci + $< liftA2 (,) + (piecewiseConstantVector phs) + (piecewiseConstantVector shp)) + $* stereoFrequenciesFromDetuneBendModulation speed fm))) + pingReleaseEnvelope + + +type Triple a = (a, a, a) + +bellStereoFM :: + IO (Real -> Real -> + PC.T Real -> + SigSt.ChunkSize -> + PC.T (BM.T Real) -> + Instrument Real (Stereo.T Vector)) +bellStereoFM = + liftA2 + (\osc env dec rel detune vcsize fm sr vel freq dur -> + pioApply + (osc sr (detune, fm, freq) vel + (env (dec/4) rel vcsize sr vel dur) + (env (dec/7) rel vcsize sr vel dur)) + (env dec rel vcsize sr vel dur)) + (CausalRender.run $ + wrapped $ + \(DetuneModulation fm) (Number vel) (Signal env4) (Signal env7) -> + constant frequency 5 $ \speed _sr -> + (let osci :: + (Triple VectorValue -> VectorValue) -> + Exp Real -> + Exp Real -> + Causal.T + (Triple VectorValue, Stereo.T VectorValue) + (Stereo.T VectorValue) + osci sel v d = + Causal.envelopeStereo + <<< + (arr sel *** + (CausalPS.amplifyStereo v + <<< + Causal.stereoFromMono + (CausalPS.osci WaveL.approxSine4 $< zero) + <<< + CausalPS.amplifyStereo d)) + in Stereo.multiValue <$> + sumNested + [osci fst3 0.6 1, + osci snd3 (0.02 * 50^?vel) 4, + osci thd3 (0.02 * 100^?vel) 7] + <<< + CausalClass.feedSnd + (stereoFrequenciesFromDetuneBendModulation speed fm) + <<< + arr (\(e1,(e4,e7)) -> (e1,e4,e7)) + $> {- + Be careful, those storable vectors shorten the whole sound + if they have shorter release than the main envelope. + -} + liftA2 (,) env4 env7)) + pingReleaseEnvelope + +bellNoiseStereoFM :: + IO (Real -> Real -> + PC.T Real -> PC.T Real -> + SigSt.ChunkSize -> + PC.T (BM.T Real) -> + Instrument Real (Stereo.T Vector)) +bellNoiseStereoFM = + liftA2 + (\osc env dec rel noiseAmp noiseReson vcsize fm sr vel freq dur -> + pioApply + (osc sr (fm, freq) (noiseAmp, noiseReson) vel + (env (dec/4) rel vcsize sr vel dur) + (env (dec/7) rel vcsize sr vel dur)) + (env dec rel vcsize sr vel dur)) + (CausalRender.run $ + wrapped $ + \(Modulation fm) (Control noiseAmp, Control noiseReson) + (Number vel) (Signal env4) (Signal env7) -> + constant noiseReference 20000 $ \noiseRef -> + constant frequency 5 $ \speed _sr -> + (let osci :: + (Triple VectorValue -> VectorValue) -> + Exp Real -> + Exp Real -> + Causal.T (Triple VectorValue, VectorValue) VectorValue + osci sel v d = + Causal.envelope + <<< + (arr sel *** + (CausalPS.amplify v + <<< + (CausalPS.osci WaveL.approxSine4 $< zero) + <<< + CausalPS.amplify d)) + + noise :: + (Triple VectorValue -> VectorValue) -> + Exp Real -> + Causal.T (Triple VectorValue, VectorValue) VectorValue + noise sel d = + (Causal.envelope $< piecewiseConstantVector noiseAmp) + <<< + Causal.envelope + <<< + (arr sel *** + ({- UniFilter.lowpass + ^<< -} + (CtrlPS.process $> SigPS.noise 12 noiseRef) + <<< +{- + (Causal.quantizeLift + (Causal.zipWith UniFilterL.parameter) + $<# (128 / fromIntegral vectorSize :: Real)) +-} + (Causal.quantizeLift + (Causal.zipWith (MoogL.parameter TypeNum.d8)) + $<# (128 / fromIntegral vectorSize :: Real)) + <<< + CausalClass.feedFst (piecewiseConstant noiseReson) + <<< + Causal.map Serial.subsample + <<< + CausalPS.amplify d)) + in liftA2 Stereo.consMultiValue + (sumNested + [osci fst3 0.6 (1*0.999), + osci snd3 (0.02 * 50^?vel) (4*0.999), + osci thd3 (0.02 * 100^?vel) (7*0.999), + noise fst3 0.999]) + (sumNested + [osci fst3 0.6 (1*1.001), + osci snd3 (0.02 * 50^?vel) (4*1.001), + osci thd3 (0.02 * 100^?vel) (7*1.001), + noise fst3 1.001]) + <<< + CausalClass.feedSnd (frequencyFromBendModulation speed fm) + <<< + arr (\(e1,(e4,e7)) -> (e1,e4,e7)) + $> {- + Be careful, those storable vectors shorten the whole sound + if they have shorter release than the main envelope. + -} + liftA2 (,) env4 env7)) + pingReleaseEnvelope + + +tine :: IO (Real -> Real -> SigSt.ChunkSize -> Instrument Real Vector) +tine = + liftA2 + (\osc env dec rel vcsize sr vel freq dur -> + pioApply (osc sr vel freq) (env dec rel vcsize sr 0 dur)) + (CausalRender.run $ + wrapped $ \(Number vel) (Frequency freq) -> + constant time 1 $ \halfLife _sr -> + (Causal.envelope $> + (CausalPS.osci WaveL.approxSine2 + $> SigPS.constant freq + $* (Causal.envelope + $< SigPS.exponential2 halfLife (vel+1) + $* SigPS.osci WaveL.approxSine2 zero (2*freq))))) + pingReleaseEnvelope + +tineStereo :: + IO (Real -> Real -> SigSt.ChunkSize -> Instrument Real (Stereo.T Vector)) +tineStereo = + liftA2 + (\osc env dec rel vcsize sr vel freq dur -> + pioApply (osc sr vel freq) (env dec rel vcsize sr 0 dur)) + (CausalRender.run $ + wrapped $ \(Number vel) (Frequency freq) -> + constant time 1 $ \halfLife _sr -> + (let chanOsci d = + CausalPS.osci WaveL.approxSine2 $> SigPS.constant (freq*d) + in Stereo.multiValue <$> + Causal.envelopeStereo $> + (liftA2 Stereo.cons (chanOsci 0.995) (chanOsci 1.005) + $* (SigPS.exponential2 halfLife (vel+1) * + SigPS.osci WaveL.approxSine2 zero (2*freq))))) + pingReleaseEnvelope + + +softStringReleaseEnvelope :: + IO (Real -> SampleRate Real -> Real -> Ev.LazyTime -> SigSt.T Vector) +softStringReleaseEnvelope = + liftA2 + (\rev env attackTime sr vel dur -> + let attackTimeVector :: Word + attackTimeVector = round (attackTime * vectorRate sr) + {- + release <- take attackTime beginning + would yield a space leak, thus we first split 'beginning' + and then concatenate it again + -} + {- + We can not easily generate attack and sustain separately, + because we want to use the chunk structure implied by 'dur'. + -} + (attack, sustain) = + SigSt.splitAt (fromIntegral attackTimeVector) $ + pioApplyToLazyTime + (env sr (amplitudeFromVelocity vel) attackTimeVector) + dur + release = rev attack + in attack <> sustain <> release) + SigStL.makeReversePacked + (CausalRender.run $ + wrapped $ \(Number amp) (Parameter attackTimeVector) (SampleRate _sr) -> + Causal.fromSignal $ + (<> SigPS.constant amp) $ + (CausalPS.amplify amp <<< + Causal.take attackTimeVector + $* SigPS.parabolaFadeInInf + (fromIntegral vectorSize * + Expr.fromIntegral attackTimeVector))) + +softString :: IO (Instrument Real (Stereo.T Vector)) +softString = + liftA2 + (\osc env sr vel freq dur -> + pioApply (osc sr freq) (env 1 sr vel dur)) + (CausalRender.run $ + wrapped $ \(Frequency freq) (SampleRate _sr) -> + let osci d = SigPS.osci WaveL.saw zero (d * freq) + in Stereo.multiValue <$> + Causal.envelopeStereo $> + (liftA2 Stereo.cons + (osci 1.005 + osci 0.998) + (osci 1.002 + osci 0.995))) + softStringReleaseEnvelope + + +softStringFM :: IO (PC.T (BM.T Real) -> Instrument Real (Stereo.T Vector)) +softStringFM = + liftA2 + (\osc env fm sr vel freq dur -> + pioApply (osc sr (fm, freq)) (env 1 sr vel dur)) + (CausalRender.run $ + wrapped $ \(Modulation fm) -> + constant frequency 5 $ \speed _sr -> + let osci d = (CausalPS.osci WaveL.saw $< zero) <<< CausalPS.amplify d + in Stereo.multiValue <$> + (Causal.envelopeStereo $> + (liftA2 Stereo.cons + (osci 1.005 + osci 0.998) + (osci 1.002 + osci 0.995) + $* frequencyFromBendModulation speed fm))) + softStringReleaseEnvelope + + +tineStereoFM :: + IO (Real -> Real -> + SigSt.ChunkSize -> + PC.T (BM.T Real) -> + Instrument Real (Stereo.T Vector)) +tineStereoFM = + liftA2 + (\osc env dec rel vcsize fm sr vel freq dur -> + pioApply (osc sr vel (fm, freq)) (env dec rel vcsize sr 0 dur)) + (CausalRender.run $ + wrapped $ \(Number vel) (Modulation fm) -> + constant time 1 $ \halfLife -> + constant frequency 5 $ \speed _sr -> + (let chanOsci d = + CausalPS.osci WaveL.approxSine2 + <<< second (CausalPS.amplify d) + in Stereo.multiValue <$> + Causal.envelopeStereo $> + (liftA2 Stereo.cons (chanOsci 0.995) (chanOsci 1.005) + <<< + (((Causal.envelope + $< SigPS.exponential2 halfLife (vel+1)) + <<< (CausalPS.osci WaveL.approxSine2 $< zero) + <<< CausalPS.amplify 2) + &&& id) + $* frequencyFromBendModulation speed fm))) + pingReleaseEnvelope + + +_tineControlledProc, tineControlledFnProc :: + Sig.T (Const.T RealValue) -> + Sig.T (Const.T RealValue) -> + Exp Real -> + SampleRate (Exp Real) -> + Causal.T (Stereo.T VectorValue) (Stereo.T VectorValue) +_tineControlledProc index depth vel = constant time 1 $ \halfLife _sr -> + Causal.stereoFromMono (CausalPS.osci WaveL.approxSine2) + <<< + Stereo.interleave + ^<< + ((Causal.envelopeStereo + $< (piecewiseConstantVector depth + * + SigPS.exponential2 halfLife (vel+1))) + <<< + Causal.stereoFromMono (CausalPS.osci WaveL.approxSine2 $< zero) + <<< + (Causal.envelopeStereo $< piecewiseConstantVector index)) + &&& id + +tineControlledFnProc index depth vel = constant time 1 $ \halfLife _sr -> + F.withGuidedArgs F.atom $ \freq -> + Causal.stereoFromMono (CausalPS.osci WaveL.approxSine2) + $& + liftA2 (liftA2 (,)) + ((Causal.envelopeStereo + $< (piecewiseConstantVector depth + * + SigPS.exponential2 halfLife (vel+1))) + <<< + Causal.stereoFromMono (CausalPS.osci WaveL.approxSine2 $< zero) + <<< + (Causal.envelopeStereo $< piecewiseConstantVector index) + $& + freq) + freq + +tineControlledFM :: + IO (Real -> Real -> + PC.T Real -> + PC.T Real -> PC.T Real -> + SigSt.ChunkSize -> + PC.T (BM.T Real) -> + Instrument Real (Stereo.T Vector)) +tineControlledFM = + liftA2 + (\osc env dec rel detune index depth vcsize fm sr vel freq dur -> + pioApply + (osc sr (index, depth) vel (detune, fm, freq)) + (env dec rel vcsize sr 0 dur)) + (CausalRender.run $ + wrapped $ \(Control index, Control depth) + (Number vel) (DetuneModulation fm) -> + constant frequency 5 $ \speed sr -> + Stereo.multiValue <$> + Causal.envelopeStereo $> + (tineControlledFnProc index depth vel sr $* + stereoFrequenciesFromDetuneBendModulation speed fm)) + pingReleaseEnvelope + + +fenderProc :: + Sig.T (Const.T RealValue) -> + Sig.T (Const.T RealValue) -> + Sig.T (Const.T RealValue) -> + Exp Real -> + SampleRate (Exp Real) -> + Causal.T (Stereo.T VectorValue) (Stereo.T VectorValue) +fenderProc fade index depth vel = constant time 1 $ \halfLife _sr -> + F.withGuidedArgs F.atom $ \stereoFreq -> + let channel_n_1 :: + F.T VectorValue VectorValue -> + F.T VectorValue VectorValue + channel_n_1 freq = + CausalPS.osci WaveL.approxSine2 + $& + ((Causal.envelope + $< (piecewiseConstantVector depth + * + SigPS.exponential2 halfLife (vel+1))) + <<< + (CausalPS.osci WaveL.approxSine2 $< zero) + <<< + (Causal.envelope $< piecewiseConstantVector index) + $& + freq) + &|& + freq + channel_1_2 :: + F.T VectorValue VectorValue -> + F.T VectorValue VectorValue + channel_1_2 freq = + CausalPS.osci WaveL.approxSine2 + $& + ((Causal.envelope + $< (piecewiseConstantVector depth + * + SigPS.exponential2 halfLife (vel+1))) + <<< + (CausalPS.osci WaveL.approxSine2 $< zero) + $& + freq) + &|& + (CausalPS.amplify 2 $& freq) + in (Causal.stereoFromMonoControlled + (fadeProcess + (F.compile $ channel_n_1 $ F.lift id) + (F.compile $ channel_1_2 $ F.lift id)) + $< piecewiseConstantVector fade) + $& + stereoFreq + +fenderFM :: + IO (Real -> Real -> + PC.T Real -> + PC.T Real -> PC.T Real -> PC.T Real -> + SigSt.ChunkSize -> + PC.T (BM.T Real) -> + Instrument Real (Stereo.T Vector)) +fenderFM = + liftA2 + (\osc env dec rel detune index depth fade vcsize fm sr vel freq dur -> + pioApply + (osc sr (index, depth) fade vel (detune, fm, freq)) + (env dec rel vcsize sr 0 dur)) + (CausalRender.run $ + wrapped $ \(Control index, Control depth) (Control fade) + (Number vel) (DetuneModulation fm) -> + constant frequency 5 $ \speed sr -> + Stereo.multiValue <$> + Causal.envelopeStereo $> + (fenderProc fade index depth vel sr $* + stereoFrequenciesFromDetuneBendModulation speed fm)) + pingReleaseEnvelope + + +fmModulator :: + Exp Real -> + Exp Real -> + Sig.T (Const.T RealValue) -> + SampleRate (Exp Real) -> + Causal.T (Stereo.T VectorValue) (Stereo.T VectorValue) +fmModulator vel n depth = constant time 1 $ \halfLife _sr -> + (Causal.envelopeStereo + $< (piecewiseConstantVector depth + * + SigPS.exponential2 halfLife (vel+1))) + <<< + Causal.stereoFromMono (CausalPS.osci WaveL.approxSine2 $< zero) + <<< + CausalPS.amplifyStereo n + +tineModulatorBankFM :: + IO (Real -> Real -> + PC.T Real -> + PC.T Real -> PC.T Real -> PC.T Real -> PC.T Real -> + SigSt.ChunkSize -> + PC.T (BM.T Real) -> + Instrument Real (Stereo.T Vector)) +tineModulatorBankFM = + liftA2 + (\osc env + dec rel detune + depth1 depth2 depth3 depth4 + vcsize fm sr vel freq dur -> + pioApply + (osc sr depth1 depth2 depth3 depth4 vel (detune, fm, freq)) + (env dec rel vcsize sr 0 dur)) + (CausalRender.run $ + wrapped $ + \(Control depth1) (Control depth2) (Control depth3) (Control depth4) + (Number vel) (DetuneModulation fm) -> + constant frequency 5 $ \speed sr -> + Stereo.multiValue <$> + (Causal.envelopeStereo $> + (Causal.stereoFromMono (CausalPS.osci WaveL.approxSine2) + <<< + Stereo.interleave + ^<< + sumNested + [fmModulator vel 1 depth1 sr, + fmModulator vel 2 depth2 sr, + fmModulator vel 3 depth3 sr, + fmModulator vel 4 depth4 sr] + &&& id + $* + stereoFrequenciesFromDetuneBendModulation speed fm))) + pingReleaseEnvelope + +tineBankFM :: + IO (Real -> Real -> + PC.T Real -> + PC.T Real -> PC.T Real -> PC.T Real -> PC.T Real -> + PC.T Real -> PC.T Real -> PC.T Real -> PC.T Real -> + SigSt.ChunkSize -> + PC.T (BM.T Real) -> + Instrument Real (Stereo.T Vector)) +tineBankFM = + liftA2 + (\osc env + dec rel detune + depth1 depth2 depth3 depth4 + partial1 partial2 partial3 partial4 + vcsize fm sr vel freq dur -> + pioApply + (osc sr depth1 depth2 depth3 depth4 + partial1 partial2 partial3 partial4 + vel (detune, fm, freq)) + (env dec rel vcsize sr 0 dur)) + (CausalRender.run $ + wrapped $ + \(Control depth1) (Control depth2) (Control depth3) (Control depth4) + (Control partial1) (Control partial2) + (Control partial3) (Control partial4) + (Number vel) (DetuneModulation fm) -> + constant frequency 5 $ \speed sr -> + + (let partial :: + VectorValue -> Int -> VectorValue -> + LLVM.CodeGenFunction r VectorValue + partial amp n t = + A.mul amp =<< + WaveL.partial WaveL.approxSine2 n t + in Stereo.multiValue <$> + Causal.envelopeStereo $> + (Causal.stereoFromMono + (CausalPS.shapeModOsci + (\(p1,(p2,(p3,p4))) t -> do + y1 <- A.mul p1 =<< WaveL.approxSine2 t + y2 <- partial p2 2 t + y3 <- partial p3 3 t + y4 <- partial p4 4 t + A.add y1 =<< A.add y2 =<< A.add y3 y4) + $< + (liftA2 (,) (piecewiseConstantVector partial1) $ + liftA2 (,) (piecewiseConstantVector partial2) $ + liftA2 (,) (piecewiseConstantVector partial3) + (piecewiseConstantVector partial4))) + <<< + Stereo.interleave + ^<< + sumNested + [fmModulator vel 1 depth1 sr, + fmModulator vel 2 depth2 sr, + fmModulator vel 3 depth3 sr, + fmModulator vel 4 depth4 sr] + &&& id + $* + stereoFrequenciesFromDetuneBendModulation speed fm))) + pingReleaseEnvelope + + +{- | +FM synthesis where the modulator is a resonantly filtered sawtooth. +This way we get a sinus-like modulator where the sine frequency +(that is, something like the modulation index) can be controlled continously. +-} +resonantFMSynthProc :: + Sig.T (Const.T RealValue) -> + Sig.T (Const.T RealValue) -> + Sig.T (Const.T RealValue) -> + Exp Real -> + SampleRate (Exp Real) -> + Causal.T (Stereo.T VectorValue) (Stereo.T VectorValue) +resonantFMSynthProc reson index depth vel = + constant time 1 $ \halfLife _sr -> + F.withGuidedArgs (Stereo.cons F.atom F.atom) $ \stereoFreq -> + let chan :: F.T inp VectorValue -> F.T inp VectorValue + chan freq = + CausalPS.osci WaveL.approxSine2 + $& + ((Causal.envelope + $< (piecewiseConstantVector depth + * + SigPS.exponential2 halfLife (vel+1))) + <<< + UniFilter.lowpass + ^<< + CtrlPS.process + $& + (Causal.zipWith UniFilterL.parameter + <<< + CausalClass.feedFst (piecewiseConstant reson) + <<< + (Causal.envelope $< piecewiseConstant index) + <<< + Causal.map Serial.subsample + $& + freq) + &|& + ((CausalPS.osci WaveL.saw $< zero) + $& + freq)) + &|& + freq + in Trav.traverse chan stereoFreq + +resonantFMSynth :: + IO (Real -> Real -> + PC.T Real -> + PC.T Real -> PC.T Real -> PC.T Real -> + SigSt.ChunkSize -> + PC.T (BM.T Real) -> + Instrument Real (Stereo.T Vector)) +resonantFMSynth = + liftA2 + (\osc env dec rel detune reson index depth vcsize fm sr vel freq dur -> + pioApply + (osc sr (reson, index, depth) vel (detune, fm, freq)) + (env dec rel vcsize sr 0 dur)) + (CausalRender.run $ + wrapped $ + \(Control reson, Control index, Control depth) + (Number vel) (DetuneModulation fm) -> + constant frequency 5 $ \speed sr -> + Stereo.multiValue <$> + Causal.envelopeStereo $> + (resonantFMSynthProc reson index depth vel sr $* + stereoFrequenciesFromDetuneBendModulation speed fm)) + pingReleaseEnvelope + + +phaserOsci :: + (Exp Real -> Causal.T a VectorValue) -> + Causal.T a (Stereo.T VectorValue) +phaserOsci osci = + CausalPS.amplifyStereo 0.25 + <<< + liftA2 Stereo.cons + (sumNested $ map osci [1.0, -0.4, 0.5, -0.7]) + (sumNested $ map osci [0.4, -1.0, 0.7, -0.5]) + + +softStringDetuneFM :: + IO (Real -> + PC.T Real -> + PC.T (BM.T Real) -> + Instrument Real (Stereo.T Vector)) +softStringDetuneFM = + liftA2 + (\osc env att det fm sr vel freq dur -> + pioApply (osc sr det (fm, freq)) (env att sr vel dur)) + (let osci :: Exp Real -> Causal.T (VectorValue, VectorValue) VectorValue + osci d = + (CausalPS.osci WaveL.saw $< zero) + <<< + Causal.envelope + <<< + first (one + CausalPS.amplify d) + in CausalRender.run $ + wrapped $ \(Control det) (Modulation fm) -> + constant frequency 5 $ \speed _sr -> + Stereo.multiValue <$> + (Causal.envelopeStereo $> + (phaserOsci osci + $< piecewiseConstantVector det + $* frequencyFromBendModulation speed fm))) + softStringReleaseEnvelope + +{- +We might decouple the frequency of the enveloped tone +from the frequency of the envelope, +in order to get something like formants. +-} +softStringShapeFM, cosineStringStereoFM, + arcSineStringStereoFM, arcTriangleStringStereoFM, + arcSquareStringStereoFM, arcSawStringStereoFM :: + IO (Real -> + PC.T Real -> + PC.T Real -> + PC.T (BM.T Real) -> + Instrument Real (Stereo.T Vector)) +softStringShapeFM = + softStringShapeCore WaveL.rationalApproxSine1 +cosineStringStereoFM = + softStringShapeCore + (\k p -> WaveL.approxSine2 =<< WaveL.replicate k p) +arcSawStringStereoFM = arcStringStereoFM WaveL.saw +arcSineStringStereoFM = arcStringStereoFM WaveL.approxSine2 +arcSquareStringStereoFM = arcStringStereoFM WaveL.square +arcTriangleStringStereoFM = arcStringStereoFM WaveL.triangle + +arcStringStereoFM :: + (forall r. + VectorValue -> + LLVM.CodeGenFunction r VectorValue) -> + IO (Real -> + PC.T Real -> + PC.T Real -> + PC.T (BM.T Real) -> + Instrument Real (Stereo.T Vector)) +arcStringStereoFM wave = + softStringShapeCore + (\k p -> + M.liftJoin2 Frame.amplifyMono + (WaveL.approxSine4 =<< WaveL.halfEnvelope p) + (wave =<< WaveL.replicate k p)) + +softStringShapeCore :: + (forall r. + VectorValue -> + VectorValue -> + LLVM.CodeGenFunction r VectorValue) -> + IO (Real -> + PC.T Real -> + PC.T Real -> + PC.T (BM.T Real) -> + Instrument Real (Stereo.T Vector)) +softStringShapeCore wave = + liftA2 + (\osc env att det dist fm sr vel freq dur -> + pioApply (osc sr det dist (fm, freq)) (env att sr vel dur)) + (let osci :: + Exp Real -> + Causal.T + (VectorValue, + {- wave shape parameter -} + (VectorValue, VectorValue) + {- detune, frequency modulation -}) + VectorValue + osci d = + CausalPS.shapeModOsci wave + <<< + second + (CausalClass.feedFst zero + <<< + Causal.envelope + <<< + first (one + CausalPS.amplify d)) + in CausalRender.run $ + wrapped $ \(Control det) (Control dist) (Modulation fm) -> + constant frequency 5 $ \speed _sr -> + Stereo.multiValue <$> + (Causal.envelopeStereo $> + (phaserOsci osci + $< piecewiseConstantVector dist + $< piecewiseConstantVector det + $* frequencyFromBendModulation speed fm))) + softStringReleaseEnvelope + +fmStringStereoFM :: + IO (Real -> + PC.T Real -> + PC.T Real -> + PC.T Real -> + PC.T (BM.T Real) -> + Instrument Real (Stereo.T Vector)) +fmStringStereoFM = + liftA2 + (\osc env att det depth dist fm sr vel freq dur -> + pioApply (osc sr det depth dist (fm, freq)) (env att sr vel dur)) + (let osci :: + Exp Real -> + Causal.T + ((VectorValue, VectorValue) + {- phase modulation depth, modulator distortion -}, + (VectorValue, VectorValue) + {- detune, frequency modulation -}) + VectorValue + osci d = + CausalPS.osci WaveL.approxSine2 + <<< + (Causal.envelope + <<< + second + (CausalPS.shapeModOsci WaveL.rationalApproxSine1 + <<< second (CausalClass.feedFst zero)) + <<^ + (\((dp, ds), f) -> (dp, (ds, f)))) + &&& arr snd + <<< + second (Causal.envelope <<< first (one + CausalPS.amplify d)) + in CausalRender.run $ + wrapped $ + \(Control det) (Control depth) (Control dist) (Modulation fm) -> + constant frequency 5 $ \speed _sr -> + Stereo.multiValue <$> + (Causal.envelopeStereo <<< + (id &&& + (phaserOsci osci + <<< + CausalClass.feedSnd + (liftA2 (,) + (piecewiseConstantVector det) + (frequencyFromBendModulation speed fm)) + <<< + CausalClass.feedSnd (piecewiseConstantVector dist) + <<< + (Causal.envelope $< piecewiseConstantVector depth))))) + softStringReleaseEnvelope + + +stereoNoise :: SampleRate (Exp Real) -> Sig.T (Stereo.T VectorValue) +stereoNoise = + constant noiseReference 20000 $ \noiseRef _sr -> + traverse + (\uid -> SigPS.noise uid noiseRef) + (Stereo.cons 13 14) + +windCore :: + Sig.T (Const.T RealValue) -> + Sig.T (Const.T (BM.T RealValue)) -> + SampleRate (Exp Real) -> + Sig.T (Stereo.T VectorValue) +windCore reson fm = + constant frequency 0.2 $ \speed sr -> + Causal.stereoFromMonoControlled CtrlPS.process + $< (Causal.zipWith (MoogL.parameter TypeNum.d8) + $< piecewiseConstant reson + $* (Causal.map Serial.subsample $* + frequencyFromBendModulation speed fm)) + $* stereoNoise sr + +wind :: + IO (Real -> + PC.T Real -> + PC.T (BM.T Real) -> + Instrument Real (Stereo.T Vector)) +wind = + liftA2 + (\osc env att reson fm sr vel freq dur -> + pioApply (osc sr reson (fm, freq)) (env att sr vel dur)) + (CausalRender.run $ + wrapped $ \(Control reson) (Modulation fm) sr -> + Stereo.multiValue <$> + Causal.envelopeStereo $> windCore reson fm sr) + softStringReleaseEnvelope + + +fadeProcess :: + (A.PseudoRing v, A.IntegerConstant v) => + Causal.T a v -> + Causal.T a v -> + Causal.T (v, a) v +fadeProcess proc0 proc1 = + let k = arr fst + a0 = proc0 <<^ snd + a1 = proc1 <<^ snd + in (one-k)*a0 + k*a1 + + +windPhaser :: + IO (Real -> + PC.T Real -> + PC.T Real -> + PC.T Real -> + PC.T (BM.T Real) -> + Instrument Real (Stereo.T Vector)) +windPhaser = + liftA2 + (\osc env att phaserMix phaserFreq reson fm sr vel freq dur -> + pioApply + (osc sr phaserMix phaserFreq reson (fm, freq)) + (env att sr vel dur)) + (CausalRender.run $ + wrapped $ + \(Control phaserMix) (FrequencyControl phaserFreq) + (Control reson) (Modulation fm) sr -> + Stereo.multiValue <$> + (Causal.envelopeStereo $> + ((Causal.stereoFromMonoControlled + (fadeProcess (arr snd) CtrlPS.process + <<< + first (Causal.map Serial.upsample) + <<^ + (\((k,p),x) -> (k,(p,x)))) + $< liftA2 (,) + (piecewiseConstant phaserMix) + (piecewiseConstant + (Const.causalMap + (Allpass.flangerParameter TypeNum.d8) + $* phaserFreq))) + $* + windCore reson fm sr))) + softStringReleaseEnvelope + + +filterSawStereoFM :: + IO (Real -> Real -> + PC.T Real -> + Real -> Real -> + SigSt.ChunkSize -> + PC.T (BM.T Real) -> + Instrument Real (Stereo.T Vector)) +filterSawStereoFM = + liftA2 + (\osc env dec rel detune bright brightDecay vcsize fm sr vel freq dur -> + pioApply + (osc sr bright brightDecay (detune, fm, freq)) + (env dec rel vcsize sr vel dur)) + (CausalRender.run $ + wrapped $ \(Frequency bright) (Time brightDec) (DetuneModulation fm) -> + constant frequency 10 $ \speed -> + constant frequency 100 $ \cutoff _sr -> + (Stereo.multiValue <$> + Causal.envelopeStereo $> + (Causal.stereoFromMono + (UniFilter.lowpass + ^<< + CtrlPS.processCtrlRate 100 + (\k -> + Causal.map (UniFilterL.parameter 10) $* + {- bound control in order to avoid too low resonant frequency, + which makes the filter instable -} + Sig.exponentialBounded2 + cutoff (brightDec/k) bright) + <<< + CausalPS.osci WaveL.saw $< zero) + $* stereoFrequenciesFromDetuneBendModulation speed fm))) + pingReleaseEnvelope + + +{- | +The ADSR curve is composed from three parts: +Attack, Decay(+Sustain), Release. +Attack starts when the key is pressed +and lasts attackTime seconds +where it reaches height attackPeak*amplitudeOfVelocity. +It should be attackPeak>1 because in the following phase +we want to approach 1 from above. +Say the curve would approach the limit value L +if it would continue after the end of the attack phase, +the slope is determined by the halfLife with respect to this upper bound. +That is, attackHalfLife is the time in seconds where the attack curve +reaches or would reach L/2. +After Attack the Decay part starts at the same level +and decays to amplitudeOfVelocity. +The slope is again a halfLife, +that is, decayHalfLife is the time where the curve +drops from attackPeak*amplitudeOfVelocity to (attackPeak+1)/2*amplitudeOfVelocity. +This phase lasts as long as the key is pressed. +If the key is released the curve decays with half life releaseHalfLife. +-} +{- +1 - 2^(-attackTime/attackHalfLife) = peak +-} +adsr :: + IO (Real -> Real -> Real -> + Real -> Real -> + SigSt.ChunkSize -> + SampleRate Real -> Real -> Ev.LazyTime -> SigSt.T Vector) +adsr = + liftA3 + (\attack decay release + attackTime attackPeak attackHalfLife + decayHalfLife releaseHalfLife vcsize sr vel dur -> + let amp = amplitudeFromVelocity vel + (attackDur, decayDur) = + CutG.splitAt (round (attackTime * vectorRate sr)) dur + in SigStL.continuePacked + (pioApplyToLazyTime + (attack sr + attackHalfLife + (attackPeak * amp / (1 - 2^?(-attackTime/attackHalfLife)))) + attackDur + <> + pioApplyToLazyTime + (decay sr + decayHalfLife + ((attackPeak-1)*amp) + amp) + decayDur) + (\x -> release vcsize sr releaseHalfLife x)) + (CausalRender.run $ + wrapped $ \(Time halfLife) (Number amplitude) (SampleRate _sr) -> + Causal.fromSignal $ + SigPS.constant amplitude - SigPS.exponential2 halfLife amplitude) + (CausalRender.run $ wrapped $ + \(Time halfLife) (Number amplitude) (Number saturation) + (SampleRate _sr) -> + Causal.fromSignal $ + SigPS.constant saturation + SigPS.exponential2 halfLife amplitude) + (Render.run $ + wrapped $ \(Time releaseHL) (Number amplitude) (SampleRate _sr) -> + let releaseTime = releaseHL * 5 / fromIntegral vectorSize + in Causal.take (Expr.roundToIntFast releaseTime) $* + SigPS.exponential2 releaseHL amplitude) + +brass :: + IO (Real -> Real -> + Real -> Real -> Real -> Real -> + PC.T Real -> + PC.T Real -> + SigSt.ChunkSize -> + PC.T (BM.T Real) -> + Instrument Real (Stereo.T Vector)) +brass = + liftA2 + (\osc env attTime attPeak attHL + dec rel emph det dist vcsize fm sr vel freq dur -> + pioApply + (osc sr det dist (fm, freq) + (env attTime emph attHL dec rel vcsize sr vel dur)) + (env attTime attPeak attHL dec rel vcsize sr vel dur)) + (let osci :: + Exp Real -> + Causal.T + (VectorValue, + {- wave shrink/replication factor -} + (VectorValue, VectorValue) + {- detune, frequency modulation -}) + VectorValue + osci d = + CausalPS.shapeModOsci WaveL.rationalApproxSine1 + <<< + second + (CausalClass.feedFst zero + <<< + Causal.envelope + <<< + first (one + CausalPS.amplify d)) + in CausalRender.run $ + wrapped $ + \(Control det) (Control dist) (Modulation fm) (Signal emph) -> + constant frequency 5 $ \speed _sr -> + Stereo.multiValue <$> + Causal.envelopeStereo $> + (phaserOsci osci + <<< + CausalClass.feedFst (piecewiseConstantVector dist) + <<< + CausalClass.feedSnd (frequencyFromBendModulation speed fm) + <<< + (Causal.envelope $< piecewiseConstantVector det) + $* + emph)) + adsr + + +sampledSound :: + IO (Sample.T -> + PC.T (BM.T Real) -> + Instrument Real (Stereo.T Vector)) +sampledSound = + liftA2 + (\osc freqMod smp fm sr vel freq dur -> + {- + We split the frequency modulation signal + in order to get a smooth frequency modulation curve. + Without (periodic) frequency modulation + we could just split the piecewise constant control curve @fm@. + -} + let fmSig :: SigSt.T Vector + fmSig = + pioApplyToLazyTime + (freqMod sr (fm, freq * Sample.period pos)) + (PC.duration fm) + pos = Sample.positions smp + amp = 2 * amplitudeFromVelocity vel + (attack, sustain, release) = Sample.parts smp + in (\cont -> + pioApplyCont cont + (osc sr amp + (attack <> + SVL.cycle (SigSt.take (Sample.loopLength pos) sustain)) + (chunkSizesFromLazyTime dur)) + fmSig) + (pioApplyCont (const SigSt.empty) + (osc sr amp release (NonNegChunky.fromChunks (repeat 1000))))) + (CausalRender.run $ + wrapped $ \(Number amp) (Signal smp) (Signal dur) (SampleRate _sr) -> + Stereo.multiValue <$> + CausalPS.amplifyStereo amp + <<< + Causal.stereoFromMono + (CausalPS.pack (Causal.frequencyModulationLinear smp)) + <<< + liftA2 Stereo.cons + (CausalPS.amplify 0.999) + (CausalPS.amplify 1.001) + <<< + arr fst + <<< + CausalClass.feedSnd (Const.flatten dur)) + (CausalRender.run $ + wrapped $ \(Modulation fm) -> + constant frequency 3 $ \speed _sr -> + Causal.fromSignal $ frequencyFromBendModulation speed fm) + + +_sampledSoundLeaky :: + IO (Sample.T -> + PC.T (BM.T Real) -> + Instrument Real (Stereo.T Vector)) +_sampledSoundLeaky = + liftA2 + (\osc freqMod smp fm sr vel freq dur -> + {- + We split the frequency modulation signal + in order to get a smooth frequency modulation curve. + Without (periodic) frequency modulation + we could just split the piecewise constant control curve @fm@. + -} + let sustainFM, releaseFM :: SigSt.T Vector + (sustainFM, releaseFM) = + SVP.splitAt (chunkSizesFromLazyTime dur) $ + pioApplyToLazyTime + (freqMod sr (fm, freq * Sample.period pos)) + (PC.duration fm) + pos = Sample.positions smp + amp = 2 * amplitudeFromVelocity vel + (attack, sustain, release) = Sample.parts smp + in pioApply + (osc sr amp + (attack <> + SVL.cycle (SigSt.take (Sample.loopLength pos) sustain))) + sustainFM + <> + pioApply (osc sr amp release) releaseFM) + (CausalRender.run $ + wrapped $ \(Number amp) (Signal smp) (SampleRate _sr) -> + Stereo.multiValue <$> + CausalPS.amplifyStereo amp + <<< + Causal.stereoFromMono + (CausalPS.pack (Causal.frequencyModulationLinear smp)) + <<< + liftA2 Stereo.cons + (CausalPS.amplify 0.999) + (CausalPS.amplify 1.001)) + (CausalRender.run $ + wrapped $ \(Modulation fm) -> + constant frequency 3 $ \speed _sr -> + Causal.fromSignal $ frequencyFromBendModulation speed fm) diff --git a/src/Synthesizer/LLVM/Server/SampledSound.hs b/src/Synthesizer/LLVM/Server/SampledSound.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Server/SampledSound.hs @@ -0,0 +1,131 @@ +module Synthesizer.LLVM.Server.SampledSound where + +import Synthesizer.LLVM.Server.Common (Real) + +import qualified Sound.Sox.Read as SoxRead +import qualified Sound.Sox.Option.Format as SoxOption +import Control.Exception (bracket) + +import qualified Synthesizer.Storable.Signal as SigSt +import qualified Data.StorableVector.Lazy as SVL + +import qualified System.Path.PartClass as PathClass +import qualified System.Path as Path +import System.Path (()) + +import Data.Tuple.HT (mapPair) + +import qualified Number.DimensionTerm as DN + +import Prelude hiding (Real, length) + + + +data T = + Cons { + body :: SigSt.T Real, + sampleRate :: DN.Frequency Real, + positions :: Positions + } + +data Positions = + Positions { + start, length, + loopStart, loopLength :: Int, + period :: Real + } + + +-- ToDo: flag failure if files cannot be found, or just remain silent +load :: (PathClass.AbsRel ar) => Path.File ar -> IO (SVL.Vector Real) +load path = + bracket (SoxRead.open SoxOption.none (Path.toString path)) SoxRead.close $ + SoxRead.withHandle1 (SVL.hGetContentsSync SVL.defaultChunkSize) + +loadRanges :: (PathClass.AbsRel ar) => Path.Dir ar -> Info -> IO [T] +loadRanges dir (Info file sr poss) = + fmap + (\smp -> map (Cons smp (DN.frequency sr)) poss) + (load (dir file)) + + +data + Info = + Info { + infoName :: Path.RelFile, + infoRate :: Real, + infoPositions :: [Positions] + } + +info :: FilePath -> Real -> [Positions] -> Info +info path = Info (Path.relFile path) + + +parts :: T -> (SigSt.T Real, SigSt.T Real, SigSt.T Real) +parts smp = + let pos = positions smp + (attack,sustain) = + mapPair + (SigSt.drop (start pos), + SigSt.take (loopLength pos)) $ + SigSt.splitAt (loopStart pos) $ + body smp + release = + SigSt.drop (loopStart pos + loopLength pos) $ + SigSt.take (start pos + length pos) $ + body smp + in (attack, sustain, release) + + + +-- * examples + +tomatensalatPositions :: [Positions] +tomatensalatPositions = + Positions 0 29499 12501 15073 321.4 : + Positions 29499 31672 38163 17312 320.6 : + Positions 67379 28610 81811 10667 323.2 : + Positions 95989 31253 106058 16111 323.7 : + {- + vor dem 't' kommt noch das Ende vom 'a' + wir bräuchten eine weitere Positionsangabe, + um am Ende etwas überspringen zu können. + Ein Smart-Konstruktor wie 'positions' + könnte das bisherige Verhalten nachmachen. + -} + Positions 127242 38596 136689 11514 319.3 : + [] + + +tomatensalat :: Info +tomatensalat = + info "tomatensalat2.wav" 44100 tomatensalatPositions + + +halPositions :: [Positions] +halPositions = +-- Positions 2371 25957 7362 6321 : + Positions 2371 25957 (2371+25957) 1 320 : + Positions 40546 34460 63540 9546 317.4 : + Positions 79128 32348 94367 14016 317.8 : + Positions 112027 21227 125880 5500 322.5 : + Positions 146057 23235 168941 352 320 : + [] + +hal :: Info +hal = + info "haskell-in-leipzig2.wav" 44100 halPositions + + +graphentheoriePositions :: [Positions] +graphentheoriePositions = + Positions 0 29524 13267 14768 301.1 : + Positions 29524 35333 47624 9968 301.6 : + Positions 64857 31189 73818 16408 297.3 : + Positions 96046 31312 106206 18504 302.9 : + Positions 127358 32127 132469 16530 299.4 : + [] + +graphentheorie :: Info +graphentheorie = + info "graphentheorie0.wav" 44100 graphentheoriePositions diff --git a/src/Synthesizer/LLVM/Server/SampledSoundAnalysis.hs b/src/Synthesizer/LLVM/Server/SampledSoundAnalysis.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Server/SampledSoundAnalysis.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module Main where +-- module Synthesizer.LLVM.Server.SampledSoundAnalysis where + +import qualified Synthesizer.LLVM.Server.Default as Default +import qualified Synthesizer.LLVM.Server.SampledSound as Sample + +import Synthesizer.LLVM.Server.Common (Real) + +import qualified Graphics.Gnuplot.Advanced as Plot +import qualified Graphics.Gnuplot.Plot.TwoDimensional as Plot2D +import qualified Graphics.Gnuplot.Graph.TwoDimensional as Graph2D + +import qualified Synthesizer.Generic.Fourier as Fourier +import qualified Synthesizer.Generic.Signal as SigG + +import qualified Synthesizer.State.Signal as SigS +import qualified Synthesizer.Storable.Signal as SigSt +import qualified Data.StorableVector.Lazy as SVL + +import qualified System.Path as Path + +import qualified Data.Foldable as Fold +import Control.Functor.HT (void) +import Control.Monad (when) +import Data.Tuple.HT (snd3) +import Data.Monoid ((<>)) +import Data.Ord.HT (comparing) + +import qualified Number.Complex as Complex +import qualified Algebra.Field as Field +import qualified Algebra.Additive as Additive + +import NumericPrelude.Numeric +import NumericPrelude.Base hiding (id) +import Prelude () + +{- +I want to find the maximum of a peak with sub-sample precision. +Model: Lay parabola through maximum point and its left and right neighbors. + +Parabola through three points: (-1,a), (0,b), (1,c): + +Lagrange polynomial L_i: + +f(t) = a*L_-1(t) + b*L_0(t) + c*L_1(t) + = a*t*(t-1)/2 - b*(t+1)*(t-1) + c*t*(t+1)/2 + = a*(t^2-t)/2 + b*(1-t^2) + c*(t^2+t)/2 + +0 =!= f'(t) + = a*L_-1'(t) + b*L_0'(t) + c*L_1'(t) + = a*(2*t-1)/2 - b*2*t + c*(2*t+1)/2 +0 = a*(2*t-1) - b*4*t + c*(2*t+1) + = c-a + (2*a - 4*b + 2*c)*t +t = (a-c) / (2*a - 4*b + 2*c) + = (c-a) / (2 * (2*b - a - c)) + +t is always between -0.5 and 0.5. +An SMT solver at least is convinced of it: + +Prelude Data.SBV> prove $ \(a::SReal) (b::SReal) (c::SReal) -> a. abs ((a-c) / (a - 2*b + c)) .<= 1 +Q.E.D. + +Precondition: a>=0, b>=0, c>=0, a t<0.5 + +p = b-a +q = b-c + +t = (p-q)/(2*(p+q)) + +Parabola maximum is invariant with respect to vertical shifts. + +For non-negative data like in the absolute spectrum +this would not be a good model. +In this case we could model a peak with a Gaussian. +Essentially this means to apply the parabola model +to the logarithms of the non-negative values. + +However, autocorrelation data can contain negative values. +-} +{- | +The three numbers must not be equal, +and the center value must be the largest one. +-} +peakMaximum :: (Field.C a) => (a,a,a) -> a +peakMaximum (a,b,c) = + (c-a) / (2 * (2*b - a - c)) + + +{- +weight autocorrelation coefficients +since the later ones are computed from less overlapped signal parts. + +However, this emphasises later coefficients +and in one case the wrong maximum is chosen this way. +-} +weight :: Int -> SVL.Vector Real -> SVL.Vector Real +weight len = + SigG.zipWithState (\w c -> c / fromIntegral w) + (SigS.takeWhile (>0) $ + SigS.iterate (subtract 1) len) + +autocorrelation :: SVL.Vector Real -> SVL.Vector Real +autocorrelation xs = + SigSt.map Complex.real $ + Fourier.transformForward $ + SigSt.map (Complex.fromReal . Complex.magnitudeSqr) $ + Fourier.transformBackward $ + SigSt.map Complex.fromReal xs <> SigSt.map (const Additive.zero) xs + +argMax :: (Ord a) => [a] -> Int +argMax = + fst . Fold.maximumBy (comparing snd) . + zip (iterate succ 0) + +main :: IO () +main = + Fold.forM_ [Sample.tomatensalat, Sample.hal, Sample.graphentheorie] $ + \info -> do + putStrLn $ Path.toString $ Sample.infoName info + ranges <- Sample.loadRanges Default.sampleDirectory info + Fold.forM_ ranges $ \smp -> + let ignoreBeginning = 30 + body = snd3 $ Sample.parts smp + ac = + SVL.take (SVL.length body `div` 2) $ + -- weight (SVL.length body) $ + autocorrelation body + maxi = + (ignoreBeginning+) $ argMax $ SigSt.toList $ + SigSt.drop ignoreBeginning ac + a:b:c:_ = SigSt.toList $ SigSt.drop (maxi-1) ac + in if SVL.length body < 1000 + then putStrLn "no loop" + else do + when False $ print $ SVL.length body + when False $ print $ SVL.length ac + when False $ void $ Plot.plotDefault $ + Plot2D.list Graph2D.listLines $ SigSt.toList ac + print $ fromIntegral maxi + peakMaximum (a,b,c) diff --git a/src/Synthesizer/LLVM/Server/Scalar/Instrument.hs b/src/Synthesizer/LLVM/Server/Scalar/Instrument.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Server/Scalar/Instrument.hs @@ -0,0 +1,191 @@ +module Synthesizer.LLVM.Server.Scalar.Instrument ( + ping, + pingDur, + pingDurTake, + pingRelease, + pingStereoRelease, + tine, + tineStereo, + softString, + + -- * for testing + dummy, + ) where + +import Synthesizer.LLVM.Server.Common +import qualified Synthesizer.LLVM.Frame.Stereo as Stereo +import qualified Synthesizer.LLVM.Causal.Render as CausalRender +import qualified Synthesizer.LLVM.Causal.Process as Causal +import qualified Synthesizer.LLVM.Generator.Render as Render +import qualified Synthesizer.LLVM.Generator.Signal as Sig +import qualified Synthesizer.LLVM.Storable.Signal as SigStL +import qualified Synthesizer.LLVM.Wave as WaveL +import Synthesizer.Causal.Class (($<), ($>), ($*)) + +import qualified LLVM.DSL.Expression as Expr +import qualified LLVM.Extra.Multi.Value as MultiValue +import LLVM.DSL.Expression (Exp) + +import qualified Synthesizer.MIDI.EventList as Ev +import Synthesizer.MIDI.Storable (chunkSizesFromLazyTime) + +import qualified Synthesizer.Storable.Signal as SigSt +import qualified Data.StorableVector.Lazy.Pattern as SigStV + +import Control.Applicative (liftA, liftA2) +import Data.Semigroup ((<>)) + +import NumericPrelude.Numeric (zero, round, (+)) +import Prelude hiding (Real, round, break, (+)) + + +pingSig :: + SampleRate (Exp Real) -> Exp Real -> Exp Real -> Sig.T (MultiValue.T Real) +pingSig = + wrapped $ \(Number vel) (Frequency freq) -> + constant time 0.2 $ \halfLife _sr -> + Causal.envelope + $< Sig.exponential2 halfLife (amplitudeFromVelocity vel) + $* Sig.osci WaveL.saw zero freq + +ping :: IO (SigSt.ChunkSize -> SampleRate Real -> Real -> Real -> SigSt.T Real) +ping = Render.run pingSig + +pingDur :: IO (Instrument Real Real) +pingDur = + fmap (\sound sr vel freq -> pioApplyToLazyTime $ sound sr vel freq) $ + CausalRender.run (\sr vel freq -> Causal.fromSignal $ pingSig sr vel freq) + +pingDurTake :: IO (SigSt.ChunkSize -> Instrument Real Real) +pingDurTake = + fmap (\sound chunkSize sr vel freq dur -> + SigStV.take (chunkSizesFromLazyTime dur) $ + sound chunkSize sr vel freq) ping + +dummy :: SigSt.ChunkSize -> Instrument Real Real +dummy chunkSize = + \ _sr vel freq dur -> + SigStV.take (chunkSizesFromLazyTime dur) $ + SigSt.repeat chunkSize (vel + 1e-3*freq) + + + +pingReleaseEnvelope :: + IO (Real -> Real -> SigSt.ChunkSize -> + SampleRate Real -> Real -> Ev.LazyTime -> SigSt.T Real) +pingReleaseEnvelope = + liftA2 + (\pressed release decay rel chunkSize sr vel dur -> + SigStL.continue + (pioApplyToLazyTime (pressed sr decay vel) dur) + (\x -> release chunkSize sr rel x)) + (CausalRender.run $ + wrapped $ \(Time halfLife) (Number velocity) (SampleRate _sr) -> + Causal.fromSignal + (Sig.exponential2 halfLife (amplitudeFromVelocity velocity))) + (Render.run $ + wrapped $ \(Time release) (Number amplitude) (SampleRate _sr) -> + Causal.take (Expr.roundToIntFast (release*3)) $* + Sig.exponential2 release amplitude) + +pingRelease :: IO (Real -> Real -> SigSt.ChunkSize -> Instrument Real Real) +pingRelease = + liftA2 + (\osc env dec rel chunkSize sr vel freq dur -> + pioApply (osc sr freq) (env dec rel chunkSize sr vel dur)) + (CausalRender.run $ frequency $+ \freq _sr -> + Causal.envelope $> Sig.osci WaveL.saw zero freq) + pingReleaseEnvelope + +pingStereoRelease :: + IO (Real -> Real -> SigSt.ChunkSize -> Instrument Real (Stereo.T Real)) +pingStereoRelease = + liftA2 + (\osc env dec rel chunkSize sr vel freq dur -> + pioApply (osc sr freq) (env dec rel chunkSize sr vel dur)) + (CausalRender.run $ frequency $+ \freq _sr -> + Stereo.multiValue <$> + Causal.envelopeStereo $> + liftA2 Stereo.cons + (Sig.osci WaveL.saw zero (0.999*freq)) + (Sig.osci WaveL.saw zero (1.001*freq))) + pingReleaseEnvelope + + + +tine :: IO (Real -> Real -> SigSt.ChunkSize -> Instrument Real Real) +tine = + liftA2 + (\osc env dec rel chunkSize sr vel freq dur -> + pioApply (osc sr vel freq) (env dec rel chunkSize sr 0 dur)) + (CausalRender.run $ + wrapped $ \(Number vel) (Frequency freq) -> + constant time 1 $ \halfLife _sr -> + Causal.envelope $> + (Causal.osci WaveL.approxSine2 + $> Sig.constant freq + $* (Causal.envelope + $< Sig.exponential2 halfLife (vel+1) + $* Sig.osci WaveL.approxSine2 zero (2*freq)))) + pingReleaseEnvelope + +tineStereo :: + IO (Real -> Real -> SigSt.ChunkSize -> Instrument Real (Stereo.T Real)) +tineStereo = + liftA2 + (\osc env dec rel chunkSize sr vel freq dur -> + pioApply (osc sr vel freq) (env dec rel chunkSize sr 0 dur)) + (CausalRender.run $ + wrapped $ \(Number vel) (Frequency freq) -> + constant time 1 $ \halfLife _sr -> + let chanOsci d = + Causal.osci WaveL.approxSine2 $> Sig.constant (freq*d) + in Stereo.multiValue <$> + Causal.envelopeStereo $> + (liftA2 Stereo.cons (chanOsci 0.995) (chanOsci 1.005) $* + (Causal.envelope + $< Sig.exponential2 halfLife (vel+1) + $* Sig.osci WaveL.approxSine2 zero (2*freq)))) + pingReleaseEnvelope + + + +softStringReleaseEnvelope :: + IO (Real -> SampleRate Real -> Real -> Ev.LazyTime -> SigSt.T Real) +softStringReleaseEnvelope = + liftA + (\env attackTime (SampleRate sampleRate) vel dur -> + let attackTimeInt = round (attackTime * sampleRate) + {- + release <- take attackTime beginning + would yield a space leak, thus we first split 'beginning' + and then concatenate it again + -} + {- + We can not easily generate attack and sustain separately, + because we want to use the chunk structure implied by 'dur'. + -} + (attack, sustain) = + SigSt.splitAt attackTimeInt $ + pioApplyToLazyTime + (env + (fromIntegral attackTimeInt :: Word) + (amplitudeFromVelocity vel)) + dur + release = SigSt.reverse attack + in attack <> sustain <> release) + (CausalRender.run $ \attackTime amp -> Causal.fromSignal $ + Sig.amplify amp (Sig.parabolaFadeIn attackTime) <> Sig.constant amp) + +softString :: IO (Instrument Real (Stereo.T Real)) +softString = + liftA2 + (\osc env sr vel freq dur -> pioApply (osc sr freq) (env 1 sr vel dur)) + (CausalRender.run $ frequency $+ \freq _sr -> + let osci d = Sig.osci WaveL.saw zero (d * freq) + in Stereo.multiValue <$> + Causal.envelopeStereo $> + liftA2 Stereo.cons + (osci 1.005 + osci 0.998) + (osci 1.002 + osci 0.995)) + softStringReleaseEnvelope diff --git a/src/Synthesizer/LLVM/Storable/ChunkIterator.hs b/src/Synthesizer/LLVM/Storable/ChunkIterator.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Storable/ChunkIterator.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ForeignFunctionInterface #-} +module Synthesizer.LLVM.Storable.ChunkIterator where + +import qualified Data.StorableVector.Lazy as SVL +import qualified Data.StorableVector.Base as SVB + +import qualified LLVM.Core as LLVM + +import Data.Word (Word) +import Foreign.Storable (Storable, poke) +import Foreign.Ptr (FunPtr, Ptr, nullPtr) + +import Control.Monad (liftM2) + +import Foreign.StablePtr (StablePtr, newStablePtr, freeStablePtr, deRefStablePtr) +import Data.IORef (IORef, newIORef, readIORef, writeIORef) + + +{- +FFI declarations must not have constraints. +Thus we put them in the iterator datatype. +-} +data T a = (Storable a) => Cons (IORef [SVB.Vector a]) (IORef (SVB.Vector a)) + + +foreign import ccall "&nextChunk" + nextCallBack :: FunPtr (StablePtr (T a) -> LLVM.Ptr Word -> IO (Ptr a)) + +foreign export ccall "nextChunk" + next :: StablePtr (T a) -> Ptr Word -> IO (Ptr a) + + +new :: (Storable a) => SVL.Vector a -> IO (StablePtr (T a)) +new sig = + newStablePtr =<< + liftM2 Cons + (newIORef (SVL.chunks sig)) + (newIORef (error "first chunk must be fetched with nextChunk")) + +dispose :: StablePtr (T a) -> IO () +dispose = freeStablePtr + +next :: StablePtr (T a) -> Ptr Word -> IO (Ptr a) +next stable lenPtr = + deRefStablePtr stable >>= \state -> + case state of + Cons listRef chunkRef -> do + xt <- readIORef listRef + case xt of + [] -> return nullPtr + (x:xs) -> + {- We have to maintain a pointer to the current chunk + in order to protect it against garbage collection -} + writeIORef chunkRef x >> + writeIORef listRef xs >> + SVB.withStartPtr x + (\p l -> poke lenPtr (fromIntegral l) >> return p) diff --git a/src/Synthesizer/LLVM/Storable/LazySizeIterator.hs b/src/Synthesizer/LLVM/Storable/LazySizeIterator.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Storable/LazySizeIterator.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +module Synthesizer.LLVM.Storable.LazySizeIterator where + +import qualified Numeric.NonNegative.Chunky as Chunky +import qualified Data.StorableVector.Lazy.Pattern as SVP +import qualified Data.StorableVector.Lazy as SVL + +import Data.Word (Word) + +import Foreign.StablePtr (StablePtr, newStablePtr, freeStablePtr, deRefStablePtr) +import Foreign.Ptr (FunPtr) +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import qualified Data.List.HT as ListHT + + +newtype T = Cons (IORef [SVL.ChunkSize]) + +{- +For problems about Storable constraint, see ChunkIterator. +-} +foreign import ccall "&nextSize" + nextCallBack :: FunPtr (StablePtr T -> IO Word) + +foreign export ccall "nextSize" + next :: StablePtr T -> IO Word + + +new :: SVP.LazySize -> IO (StablePtr T) +new ls = + newStablePtr . Cons =<< newIORef (Chunky.toChunks (Chunky.normalize ls)) + +dispose :: StablePtr T -> IO () +dispose = freeStablePtr + +{- | +Zero pieces are filtered out. +If 'next' returns 0 then the end of the lazy size is reached. +-} +next :: StablePtr T -> IO Word +next stable = + deRefStablePtr stable >>= \state -> + case state of + Cons listRef -> + readIORef listRef >>= + ListHT.switchL + (return 0) + (\(SVL.ChunkSize time) xs -> + writeIORef listRef xs >> + return (fromIntegral time)) diff --git a/src/Synthesizer/LLVM/Storable/Process.hs b/src/Synthesizer/LLVM/Storable/Process.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Storable/Process.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeFamilies #-} +{- | +Functions on lazy storable vectors that are implemented using LLVM. +-} +module Synthesizer.LLVM.Storable.Process ( + makeArranger, + continuePacked, + ) where + +import qualified Synthesizer.LLVM.Frame.SerialVector.Code as Serial +import qualified Synthesizer.LLVM.Storable.Signal as SigStL +import qualified Synthesizer.CausalIO.Process as PIO +import qualified Synthesizer.Generic.Cut as CutG + +import qualified Data.StorableVector as SV +import qualified Data.StorableVector.Base as SVB + +import qualified Data.EventList.Relative.TimeBody as EventList +import qualified Data.EventList.Relative.TimeTime as EventListTT +import qualified Data.EventList.Relative.TimeMixed as EventListTM +import qualified Data.EventList.Absolute.TimeBody as AbsEventList + +import qualified LLVM.Extra.Multi.Value.Storable as Storable +import qualified LLVM.Extra.Multi.Value as MultiValue +import qualified LLVM.Extra.Arithmetic as A + +import qualified Type.Data.Num.Decimal as TypeNum + +import qualified Control.Arrow as Arr +import qualified Data.Foldable as Fold +import Foreign.Marshal.Array (advancePtr) + +import qualified System.Unsafe as Unsafe + +import qualified Number.NonNegative as NonNeg + +import NumericPrelude.Numeric +import NumericPrelude.Base + + + +{- +Same algorithm as in Synthesizer.Storable.Cut.arrangeEquidist +-} +{- | +The element vectors in the event lists +must fit into the length of the event list. +-} +makeArranger :: + (Arr.Arrow arrow, Storable.C a, MultiValue.Additive a) => + IO (arrow + (EventListTT.T NonNeg.Int (SV.Vector a)) + (SV.Vector a)) +makeArranger = do + mixer <- SigStL.makeMixer A.add + fill <- SigStL.fillBuffer A.zero + return $ Arr.arr $ \ now -> + let -- summation is done twice, for 'sz' and for 'xs' + sznn = EventListTT.duration now + sz = NonNeg.toNumber sznn + xs = + AbsEventList.toPairList $ + AbsEventList.mapTime NonNeg.toNumber $ + EventList.toAbsoluteEventList 0 $ + EventListTM.switchTimeR const now + in Unsafe.performIO $ + SVB.createAndTrim sz $ \dstPtr -> do + fill (fromIntegral sz) dstPtr + Fold.forM_ xs $ \(i,s) -> + SVB.withStartPtr s $ \srcPtr len -> + let llen = + if len <= sz-i + then fromIntegral len + else error "Process.arrange: chunk larger that event list" + in mixer llen srcPtr (advancePtr dstPtr i) + return sz + + +continuePacked :: + (CutG.Transform a, Storable.Vector b, TypeNum.Positive n) => + PIO.T a (SV.Vector (Serial.T n b)) -> + (b -> PIO.T a (SV.Vector (Serial.T n b))) -> + PIO.T a (SV.Vector (Serial.T n b)) +continuePacked proc0 proc1 = + PIO.continueChunk proc0 + (proc1 Arr.<<^ SV.last . SigStL.unpackStrict) diff --git a/src/Synthesizer/LLVM/Storable/Signal.hs b/src/Synthesizer/LLVM/Storable/Signal.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Storable/Signal.hs @@ -0,0 +1,280 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{- | +Functions on storable vectors that are implemented using LLVM. +-} +module Synthesizer.LLVM.Storable.Signal ( + unpackStrict, unpack, + unpackStereoStrict, unpackStereo, + makeReversePackedStrict, makeReversePacked, + continue, continuePacked, continuePackedGeneric, + fillBuffer, makeMixer, + makeArranger, + ) where + +import qualified Synthesizer.LLVM.Frame.SerialVector.Code as Serial + +import qualified Synthesizer.LLVM.Frame.StereoInterleaved as StereoVector +import qualified Synthesizer.LLVM.Frame.Stereo as Stereo + +import qualified Data.StorableVector.Lazy as SVL +import qualified Data.StorableVector as SV +import qualified Data.StorableVector.Base as SVB + +import qualified Data.EventList.Relative.TimeBody as EventList +import qualified Data.EventList.Relative.TimeMixed as EventListTM +import qualified Data.EventList.Absolute.TimeBody as AbsEventList +import qualified Number.NonNegative as NonNeg + +import qualified LLVM.DSL.Execution as Exec +import qualified LLVM.Extra.Multi.Value.Storable as Storable +import qualified LLVM.Extra.Multi.Value as MultiValue +import qualified LLVM.Core as LLVM + +import qualified Type.Data.Num.Decimal as TypeNum + +import Control.Monad.HT (void) + +import Foreign.Marshal.Array (advancePtr) +import Foreign.ForeignPtr (castForeignPtr) +import Foreign.Storable (Storable) +import Foreign.Ptr (Ptr) + +import qualified System.Unsafe as Unsafe + + +{- | +This function needs only constant time +in contrast to 'Synthesizer.LLVM.Parameterized.SignalPacked.unpack'. + +We cannot provide a 'pack' function +since the array size may not line up. +It would also need copying since the source data may not be aligned properly. +-} +unpackChunk :: + (Storable.C a, TypeNum.Positive n) => + SV.Vector (Serial.T n a) -> SV.Vector a +unpackChunk v = + let getDim :: + (TypeNum.Positive n) => + SV.Vector (Serial.T n a) -> TypeNum.Singleton n -> Int + getDim _ = TypeNum.integralFromSingleton + d = getDim v TypeNum.singleton + (fptr,s,l) = SVB.toForeignPtr v + in SVB.SV (castForeignPtr fptr) (s*d) (l*d) + + +unpackStrict :: + (TypeNum.Positive n, Storable.Vector a) => + SV.Vector (Serial.T n a) -> SV.Vector a +unpackStrict = unpackChunk + +unpack :: + (TypeNum.Positive n, Storable.Vector a) => + SVL.Vector (Serial.T n a) -> SVL.Vector a +unpack = SVL.fromChunks . map unpackChunk . SVL.chunks + + +unpackStereoStrict :: + (TypeNum.Positive n, Storable.C a) => + SV.Vector (StereoVector.T n a) -> SV.Vector (Stereo.T a) +unpackStereoStrict v = + let getDim :: + (TypeNum.Positive n) => + SV.Vector (StereoVector.T n a) -> TypeNum.Singleton n -> Int + getDim _ = TypeNum.integralFromSingleton + d = getDim v TypeNum.singleton + (fptr,s,l) = SVB.toForeignPtr v + in SVB.SV (castForeignPtr fptr) (s*d) (l*d) + +unpackStereo :: + (TypeNum.Positive n, Storable.C a) => + SVL.Vector (StereoVector.T n a) -> SVL.Vector (Stereo.T a) +unpackStereo = + SVL.fromChunks . map unpackStereoStrict . SVL.chunks + + +makeReverser :: + (Storable.C a, MultiValue.T a ~ value) => + (value -> LLVM.CodeGenFunction () value) -> + IO (Word -> Ptr a -> Ptr a -> IO ()) +makeReverser rev = + Exec.compile "reverse" $ + Exec.createFunction derefMixPtr "reverse" $ \ size ptrA ptrB -> do + sizeInt <- LLVM.bitcast size + ptrAEnd <- Storable.advancePtr sizeInt ptrA + void $ Storable.arrayLoop size ptrB ptrAEnd $ \ ptrBi ptrAj0 -> do + ptrAj1 <- Storable.decrementPtr ptrAj0 + flip Storable.store ptrBi + =<< rev + =<< Storable.load ptrAj1 + return ptrAj1 + +makeReversePackedStrict :: + (TypeNum.Positive n, Storable.Vector a, v ~ Serial.T n a) => + IO (SV.Vector v -> SV.Vector v) +makeReversePackedStrict = do + rev <- makeReverser Serial.reverse + return $ \v -> + Unsafe.performIO $ + SVB.withStartPtr v $ \ptrA len -> + SVB.create len $ \ptrB -> + rev (fromIntegral len) ptrA ptrB + +makeReversePacked :: + (TypeNum.Positive n, Storable.Vector a, v ~ Serial.T n a) => + IO (SVL.Vector v -> SVL.Vector v) +makeReversePacked = + fmap (\f -> SVL.fromChunks . reverse . map f . SVL.chunks) $ + makeReversePackedStrict + + +-- ToDo: move to synthesizer-core or storablevector +{- | +Append two signals where the second signal +gets the last value of the first signal as parameter. +If the first signal is empty +then there is no parameter for the second signal +and thus we simply return an empty signal in that case. +-} +continue :: + (Storable a) => + SVL.Vector a -> (a -> SVL.Vector a) -> SVL.Vector a +continue x y = + SVL.fromChunks $ + withLast SV.empty + (SVL.chunks x) + (SV.switchR [] $ \_ -> SVL.chunks . y) + +continuePacked :: + (TypeNum.Positive n, Storable.Vector a) => + SVL.Vector (Serial.T n a) -> + (a -> SVL.Vector (Serial.T n a)) -> + SVL.Vector (Serial.T n a) +continuePacked x y = + SVL.fromChunks $ + withLast SV.empty + (SVL.chunks x) + (SV.switchR [] (\_ -> SVL.chunks . y) . unpackStrict) + +{- +This function reduces the last chunk to size one, repacks that +and takes the last value. +It would be certainly more efficient to use +a single @Memory.load@, @extractelement@ and @store@ +instead of a loop of count 1. +However, this implementation is the simplest one, so far. +-} +{- | +Use this like + +> do unpackGeneric <- makeUnpackGenericStrict +> return (continuePackedGeneric unpackGeneric x y) +-} +continuePackedGeneric :: + (Storable v, Storable a) => + (SV.Vector v -> SV.Vector a) -> + SVL.Vector v -> (a -> SVL.Vector v) -> SVL.Vector v +continuePackedGeneric unpackGeneric x y = + SVL.fromChunks $ + withLast SV.empty + (SVL.chunks x) + (\lastChunk -> + SV.switchR [] (\_ -> SVL.chunks . y) $ unpackGeneric $ + SV.drop (SV.length lastChunk - 1) $ lastChunk) + + +-- ToDo: candidate for utility-ht +withLast :: a -> [a] -> (a -> [a]) -> [a] +withLast deflt x y = + foldr + (\a cont _ -> a : cont a) + y x deflt + + +foreign import ccall safe "dynamic" derefFillPtr :: + Exec.Importer (Word -> Ptr a -> IO ()) + +{- | +'fillBuffer' is not only more general than filling with zeros, +it also simplifies type inference. +-} +fillBuffer :: + (Storable.C a, MultiValue.T a ~ value) => + value -> IO (Word -> Ptr a -> IO ()) +fillBuffer x = + Exec.compile "constant" $ + Exec.createFunction derefFillPtr "constantfill" $ \ size ptr -> + Storable.arrayLoop size ptr () $ \ ptri () -> Storable.store x ptri + + +foreign import ccall safe "dynamic" derefMixPtr :: + Exec.Importer (Word -> Ptr a -> Ptr a -> IO ()) + +makeMixer :: + (Storable.C a, MultiValue.T a ~ value) => + (value -> value -> LLVM.CodeGenFunction () value) -> + IO (Word -> Ptr a -> Ptr a -> IO ()) +makeMixer add = + Exec.compile "mixer" $ + Exec.createFunction derefMixPtr "mix" $ \ size srcPtr dstPtr -> + void $ Storable.arrayLoop2 size srcPtr dstPtr () $ + \srcPtri dstPtri () -> do + y <- Storable.load srcPtri + Storable.modify (add y) dstPtri + + +addToBuffer :: + (Storable a) => + (Word -> Ptr a -> Ptr a -> IO ()) -> + Int -> Ptr a -> Int -> SVL.Vector a -> IO (Int, SVL.Vector a) +addToBuffer addChunkToBuffer len v start xs = + let (now,future) = SVL.splitAt (len - start) xs + go i [] = return i + go i (c:cs) = + SVB.withStartPtr c (\ptr l -> + addChunkToBuffer (fromIntegral l) ptr (advancePtr v i)) >> + go (i + SV.length c) cs + in fmap (flip (,) future) . go start . SVL.chunks $ now + + +{- +Same algorithm as in Synthesizer.Storable.Cut.arrangeEquidist +-} +makeArranger :: + (Storable.C a, MultiValue.Additive a) => + IO (SVL.ChunkSize -> + EventList.T NonNeg.Int (SVL.Vector a) -> + SVL.Vector a) +makeArranger = do + mixer <- makeMixer MultiValue.add + fill <- fillBuffer MultiValue.zero + return $ \ (SVL.ChunkSize sz) -> + let sznn = NonNeg.fromNumberMsg "arrange" sz + go acc evs = + let (now,future) = EventListTM.splitAtTime sznn evs + xs = + AbsEventList.toPairList $ + EventList.toAbsoluteEventList 0 $ + EventListTM.switchTimeR const now + (chunk,newAcc) = + Unsafe.performIO $ + SVB.createAndTrim' sz $ \ptr -> do + fill (fromIntegral sz) ptr + newAcc0 <- flip mapM acc $ addToBuffer mixer sz ptr 0 + newAcc1 <- flip mapM xs $ \(i,s) -> + addToBuffer mixer sz ptr (NonNeg.toNumber i) s + let (ends, suffixes) = unzip $ newAcc0++newAcc1 + {- if there are more events to come, + we must pad with zeros -} + len = + if EventList.null future + then foldl max 0 ends + else sz + return (0, len, + filter (not . SVL.null) suffixes) + in if SV.null chunk + then [] + else chunk : go newAcc future + in SVL.fromChunks . go [] diff --git a/src/Synthesizer/LLVM/Storable/Vector.hs b/src/Synthesizer/LLVM/Storable/Vector.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Storable/Vector.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE TypeFamilies #-} +module Synthesizer.LLVM.Storable.Vector where + +import qualified Data.StorableVector as SV +import qualified Data.StorableVector.Base as SVB + +import Foreign.Marshal.Array (advancePtr) +import Foreign.Storable (Storable) +import Foreign.ForeignPtr (ForeignPtr) +import Foreign.Ptr (Ptr) +import qualified System.Unsafe as Unsafe + + +unsafeToPointers :: (Storable a) => SV.Vector a -> (ForeignPtr a, Ptr a, Int) +unsafeToPointers v = + let (fp,s,l) = SVB.toForeignPtr v + in (fp, Unsafe.foreignPtrToPtr fp `advancePtr` s, l) diff --git a/src/Synthesizer/LLVM/Value.hs b/src/Synthesizer/LLVM/Value.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Value.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Synthesizer.LLVM.Value ( + T, decons, + tau, square, sqrt, + max, min, limit, fraction, + + (%==), (%/=), (%<), (%<=), (%>), (%>=), not, + (%&&), (%||), + (?), (??), + + lift0, lift1, lift2, lift3, + unlift0, unlift1, unlift2, unlift3, unlift4, unlift5, + constantValue, constant, + fromInteger', fromRational', + + Flatten(flattenCode, unfoldCode), Registers, + flatten, unfold, + flattenCodeTraversable, unfoldCodeTraversable, + flattenFunction, + ) where + +import LLVM.DSL.Value + +import qualified Synthesizer.LLVM.Frame.Stereo as Stereo () +import qualified Synthesizer.Basic.Phase as Phase + +import qualified Algebra.RealRing as RealRing + +import qualified Prelude as P () +import NumericPrelude.Base hiding (min, max, unzip, unzip3, not) + + +instance (RealRing.C a, Flatten a) => Flatten (Phase.T a) where + type Registers (Phase.T a) = Registers a + flattenCode s = flattenCode $ Phase.toRepresentative s + unfoldCode s = + -- could also be unsafeFromRepresentative + Phase.fromRepresentative $ unfoldCode s diff --git a/src/Synthesizer/LLVM/Wave.hs b/src/Synthesizer/LLVM/Wave.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Wave.hs @@ -0,0 +1,215 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeFamilies #-} +module Synthesizer.LLVM.Wave where + +import qualified Synthesizer.LLVM.Value as Value + +import qualified LLVM.Extra.Arithmetic as A + +import LLVM.Core (CodeGenFunction) + +import qualified Control.Monad.HT as M +import Control.Monad.HT ((<=<)) + +import NumericPrelude.Numeric +import NumericPrelude.Base hiding (replicate) + + + +saw :: + (A.PseudoRing a, A.IntegerConstant a) => + a -> CodeGenFunction r a +saw = + A.sub (A.fromInteger' 1) <=< + A.mul (A.fromInteger' 2) + +square :: + (A.PseudoRing a, A.IntegerConstant a, A.Fraction a) => + a -> CodeGenFunction r a +square = + A.sub (A.fromInteger' 1) <=< + A.mul (A.fromInteger' 2) <=< + A.truncate <=< + A.mul (A.fromInteger' 2) + +{- | +Discrete interpolation between triangle and square wave. +For exponent 1 we get a triangle wave. +The larger the exponent, the more we approach a square wave, +the.more computing is necessary. +-} +triangleSquarePower :: + (A.PseudoRing a, A.RationalConstant a, A.Real a) => + Integer -> a -> CodeGenFunction r a +triangleSquarePower n = Value.unlift1 $ \x -> + let y = 2-4*x + z = abs (1-abs y) + in (1-z^n)*signum y + +{- | +Continuous interpolation between triangle and square wave. +For factor 0 we get a square wave, +for factor 1 we get a triangle wave. +-} +triangleSquareRatio :: + (A.Field a, A.RationalConstant a, A.Real a) => + a -> a -> CodeGenFunction r a +triangleSquareRatio = Value.unlift2 $ \c x -> + let y = 2-4*x + z = abs (1-abs y) + in (1-z)/(1+(c-1)*z)*signum y + +triangle :: + (A.PseudoRing a, A.RationalConstant a, A.Fraction a) => + a -> CodeGenFunction r a +triangle = + flip A.sub (A.fromInteger' 1) <=< + A.abs <=< + flip A.sub (A.fromInteger' 2) <=< + A.mul (A.fromInteger' 4) <=< + A.incPhase (A.fromRational' 0.75) + +approxSine2 :: + (A.PseudoRing a, A.IntegerConstant a, A.Fraction a) => + a -> CodeGenFunction r a +approxSine2 t = do + x <- saw t + A.mul (A.fromInteger' 4) =<< + A.mul x =<< + A.sub (A.fromInteger' 1) =<< + A.abs x + +approxSine3 :: + (A.PseudoRing a, A.RationalConstant a, A.Fraction a) => + a -> CodeGenFunction r a +approxSine3 t = do + x <- triangle t + A.mul (A.fromRational' 0.5) =<< + A.mul x =<< + A.sub (A.fromInteger' 3) =<< + A.mul x x + +approxSine4 :: + (A.PseudoRing a, A.RationalConstant a, A.Real a) => + a -> CodeGenFunction r a +approxSine4 t = do + x <- saw t + ax <- A.abs x + sax <- A.sub (A.fromInteger' 1) ax + A.mul (A.fromRational' (16/5)) =<< + A.mul x =<< + A.mul sax =<< + A.add (A.fromInteger' 1) =<< + A.mul sax ax + +{- | +For the distortion factor @recip pi@ you get the closest approximation +to an undistorted cosine or sine. +We have chosen this scaling in order to stay with field operations. +-} +rationalApproxCosine1, rationalApproxSine1 :: + (A.Field a, A.RationalConstant a, A.Real a) => + a -> a -> CodeGenFunction r a +rationalApproxCosine1 k t = do + num2 <- + A.square =<< + A.mul k =<< + A.add (A.fromInteger' (-1)) =<< + A.mul (A.fromInteger' 2) t + den2 <- + A.square =<< + A.mul t =<< + A.sub (A.fromInteger' 1) t + M.liftJoin2 A.fdiv + (A.sub num2 den2) + (A.add num2 den2) + +rationalApproxSine1 k t = do + num <- + A.mul k =<< + A.add (A.fromInteger' (-1)) =<< + A.mul (A.fromInteger' 2) t + den <- + A.mul t =<< + A.sub (A.fromInteger' 1) t + M.liftJoin2 A.fdiv + (A.mul (A.fromInteger' (-2)) =<< A.mul num den) + (M.liftJoin2 A.add (A.square num) (A.square den)) + + +trapezoidSkew :: + (A.Field a, A.RationalConstant a, A.Real a) => + a -> a -> CodeGenFunction r a +trapezoidSkew p = + A.max (A.fromInteger' (-1)) <=< + A.min (A.fromInteger' 1) <=< + flip A.fdiv p <=< + A.sub (A.fromInteger' 1) <=< + A.mul (A.fromInteger' 2) + +{- | +> trapezoidSlope steepness = trapezoidSkew (recip steepness) +-} +trapezoidSlope :: + (A.PseudoRing a, A.RationalConstant a, A.Real a) => + a -> a -> CodeGenFunction r a +trapezoidSlope p = + A.max (A.fromInteger' (-1)) <=< + A.min (A.fromInteger' 1) <=< + A.mul p <=< + A.sub (A.fromInteger' 1) <=< + A.mul (A.fromInteger' 2) + +sine :: + (A.Transcendental a, A.RationalConstant a) => + a -> CodeGenFunction r a +sine t = + A.sin =<< A.mul t =<< Value.decons Value.tau + + + +{- | +This can be used for preprocessing the phase +in order to generate locally faster oscillating waves. +For example + +> triangle <=< replicate (valueOf 2.5) + +shrinks a triangle wave such that 2.5 periods fit into one. +-} +replicate :: + (A.PseudoRing a, A.RationalConstant a, A.Fraction a) => + a -> a -> CodeGenFunction r a +replicate k = + A.fraction <=< + A.mul k <=< + flip A.sub (A.fromRational' 0.5) <=< + A.incPhase (A.fromRational' 0.5) + +{- | +Preprocess the phase such that the first half of a wave +is expanded to one period and shifted by 90 degree. +E.g. + +> sine <=< halfEnvelope + +generates a sequence of sine bows that starts and ends with the maximum. +Such a signal can be used to envelope an oscillation +generated using 'replicate'. +-} +halfEnvelope :: + (A.PseudoRing a, A.RationalConstant a, A.Fraction a) => + a -> CodeGenFunction r a +halfEnvelope = + A.mul (A.fromRational' 0.5) <=< + A.incPhase (A.fromRational' 0.5) + +partial :: + (A.Fraction v, A.PseudoRing v, A.IntegerConstant v) => + (v -> CodeGenFunction r v) -> + Int -> + (v -> CodeGenFunction r v) +partial w n t = + w =<< + A.signedFraction =<< + A.mul t (A.fromInteger' (fromIntegral n)) diff --git a/synthesizer-llvm.cabal b/synthesizer-llvm.cabal new file mode 100644 --- /dev/null +++ b/synthesizer-llvm.cabal @@ -0,0 +1,526 @@ +Cabal-Version: 2.2 +Name: synthesizer-llvm +Version: 1.1.0.1 +License: GPL-3.0-only +License-File: LICENSE +Author: Henning Thielemann +Maintainer: Henning Thielemann +Homepage: http://www.haskell.org/haskellwiki/Synthesizer +Package-URL: http://code.haskell.org/synthesizer/llvm/ +Category: Sound, Music +Synopsis: Efficient signal processing using runtime compilation +Description: + Efficient signal processing + using runtime compilation and vector instructions. + It uses LLVM library, thus it is not bound to a specific CPU. + There are some example executables that you can build + with Cabal flag @buildExamples@: + . + * @synthi-llvm-render@: + Render a MIDI file into an audio file + using some arbitrary instruments. + . + * @synthi-llvm-alsa@: + A realtime software synthesizer + that receives MIDI events via ALSA + and in response plays tones via ALSA. + If you have no ALSA (or Linux at all), + then you can disable this example with @-f-alsa@. + . + * @synthi-llvm-jack@: + The same realtime software synthesizer using JACK. + If you have no JACK, + then you can disable this example with @-f-jack@. + . + * @synthi-llvm-example@: + Not very useful as an executable. + You should better load the according module into GHCi + and play around with it. + The module Synthesizer.LLVM.LAC2011 + should be especially useful for an introduction. +Stability: Experimental +Tested-With: GHC==7.4.2, GHC==7.6.3, GHC==7.8.4, GHC==7.10.3 +Tested-With: GHC==8.6.5, GHC==8.8.4, GHC==8.10.7 +Tested-With: GHC==9.2.2, GHC==9.4.7, GHC==9.6.3 +Build-Type: Simple +Extra-Source-Files: + Changes.md + +Flag buildExamples + description: Build example executables + default: False + +Flag alsa + description: Build ALSA synthesizer if examples are built + default: True + +Flag jack + description: Build JACK synthesizer if examples are built + default: False + +Source-Repository this + Tag: 1.1.0.1 + Type: darcs + Location: http://code.haskell.org/synthesizer/llvm/ + +Source-Repository head + Type: darcs + Location: http://code.haskell.org/synthesizer/llvm/ + + +Library + Build-Depends: + llvm-dsl >=0.1.1 && <0.2, + llvm-extra >=0.11 && <0.13, + llvm-tf >=9.0 && <17.1, + tfp >=1.0 && <1.1, + vault >=0.3 && <0.4, + synthesizer-core >=0.8 && <0.9, + synthesizer-midi >=0.6 && <0.7, + midi >=0.2.1 && <0.3, + storable-record >=0.0.3 && <0.1, + sox >=0.2 && <0.3, + storablevector >=0.2.6 && <0.3, + unsafe >=0.0 && <0.1, + numeric-prelude >=0.3 && <0.5, + non-negative >=0.1 && <0.2, + non-empty >=0.2.1 && <0.4, + event-list >=0.1 && <0.2, + pathtype >=0.8 && <0.9, + random >=1.0 && <1.3, + containers >=0.1 && <0.7, + transformers >=0.2 && <0.7, + semigroups >=0.1 && <1.0, + utility-ht >=0.0.15 && <0.1 + + Build-Depends: + -- base-4 needed for Control.Category + base >=4 && <5 + + Default-Language: Haskell98 + GHC-Options: -Wall + If impl(ghc>=7.0) + GHC-Options: -fwarn-unused-do-bind + CPP-Options: -DNoImplicitPrelude=RebindableSyntax + Default-Extensions: CPP + If impl(ghc<8.0) + GHC-Options: -fcontext-stack=1000 + Else + GHC-Options: -freduction-depth=1000 + + Hs-source-dirs: src + Exposed-Modules: + Synthesizer.LLVM.Generator.Signal + Synthesizer.LLVM.Generator.SignalPacked + Synthesizer.LLVM.Generator.Core + Synthesizer.LLVM.Generator.Source + Synthesizer.LLVM.Generator.Render + Synthesizer.LLVM.Storable.Signal + Synthesizer.LLVM.Storable.Process + Synthesizer.LLVM.Causal.Process + Synthesizer.LLVM.Causal.ProcessValue + Synthesizer.LLVM.Causal.ProcessPacked + Synthesizer.LLVM.Causal.Controlled + Synthesizer.LLVM.Causal.ControlledPacked + Synthesizer.LLVM.Causal.Exponential2 + Synthesizer.LLVM.Causal.FunctionalPlug + Synthesizer.LLVM.Causal.Functional + Synthesizer.LLVM.Causal.RingBufferForward + Synthesizer.LLVM.Causal.Helix + Synthesizer.LLVM.Causal.Render + Synthesizer.LLVM.Fold + Synthesizer.LLVM.Plug.Input + Synthesizer.LLVM.Plug.Output + Synthesizer.LLVM.Filter.Allpass + Synthesizer.LLVM.Filter.Butterworth + Synthesizer.LLVM.Filter.Chebyshev + Synthesizer.LLVM.Filter.ComplexFirstOrder + Synthesizer.LLVM.Filter.ComplexFirstOrderPacked + Synthesizer.LLVM.Filter.FirstOrder + Synthesizer.LLVM.Filter.SecondOrder + Synthesizer.LLVM.Filter.SecondOrderPacked + Synthesizer.LLVM.Filter.SecondOrderCascade + Synthesizer.LLVM.Filter.Moog + Synthesizer.LLVM.Filter.Universal + Synthesizer.LLVM.Filter.NonRecursive + Synthesizer.LLVM.Interpolation + Synthesizer.LLVM.Frame.SerialVector + Synthesizer.LLVM.Frame.SerialVector.Class + Synthesizer.LLVM.Frame.SerialVector.Code + Synthesizer.LLVM.Frame.SerialVector.Plain + Synthesizer.LLVM.Frame.StereoInterleaved + Synthesizer.LLVM.Frame.Stereo + Synthesizer.LLVM.Frame.Binary + Synthesizer.LLVM.Frame + Synthesizer.LLVM.Complex + Synthesizer.LLVM.Wave + Synthesizer.LLVM.MIDI + Synthesizer.LLVM.MIDI.BendModulation + Synthesizer.LLVM.Server.Packed.Instrument + Synthesizer.LLVM.Server.Scalar.Instrument + Synthesizer.LLVM.Server.CausalPacked.Instrument + Synthesizer.LLVM.Server.CausalPacked.InstrumentPlug + Synthesizer.LLVM.Server.CausalPacked.Speech + Synthesizer.LLVM.Server.CausalPacked.Common + Synthesizer.LLVM.Server.SampledSound + Synthesizer.LLVM.Server.Common + Synthesizer.LLVM.Server.CommonPacked + Synthesizer.LLVM.ConstantPiece + Synthesizer.LLVM.Value + + Other-Modules: + Synthesizer.LLVM.ForeignPtr + Synthesizer.LLVM.Random + Synthesizer.LLVM.EventIterator + Synthesizer.LLVM.Storable.Vector + Synthesizer.LLVM.Storable.ChunkIterator + Synthesizer.LLVM.Storable.LazySizeIterator + Synthesizer.LLVM.RingBuffer + Synthesizer.LLVM.Causal.Parametric + Synthesizer.LLVM.Causal.Private + Synthesizer.LLVM.Frame.StereoInterleavedCode + Synthesizer.LLVM.Generator.Extra + Synthesizer.LLVM.Generator.Private + Synthesizer.LLVM.Private.Render + Synthesizer.LLVM.Private + +Library server + If flag(buildExamples) + Build-Depends: + synthesizer-llvm, + + synthesizer-core, + synthesizer-midi, + midi, + storablevector, + numeric-prelude, + non-negative, + event-list, + shell-utility >=0.0 && <0.2, + pathtype, + optparse-applicative >=0.11 && <0.19, + containers, + utility-ht, + base + + Else + Buildable: False + + Default-Language: Haskell98 + GHC-Options: -Wall + If impl(ghc>=7.0) + GHC-Options: -fwarn-unused-do-bind + CPP-Options: -DNoImplicitPrelude=RebindableSyntax + Default-Extensions: CPP + Hs-Source-Dirs: server + Exposed-Modules: + Synthesizer.LLVM.Server.CausalPacked.Arrange + Synthesizer.LLVM.Server.OptionCommon + Synthesizer.LLVM.Server.Default + +Executable synthi-llvm-example + If flag(buildExamples) + Build-Depends: + server, + synthesizer-llvm, + + llvm-dsl, + llvm-extra, + llvm-tf, + tfp, + synthesizer-core, + sox, + storablevector, + numeric-prelude, + non-negative, + event-list, + random, + non-empty, + utility-ht, + pathtype, + unsafe, + base + Else + Buildable: False + Default-Language: Haskell98 + GHC-Options: -Wall + GHC-Prof-Options: -fprof-auto-exported + If impl(ghc>=7.0) + GHC-Options: -fwarn-unused-do-bind + CPP-Options: -DNoImplicitPrelude=RebindableSyntax + Default-Extensions: CPP + If impl(ghc<8.0) + GHC-Options: -fcontext-stack=1000 + Else + GHC-Options: -freduction-depth=1000 + Hs-Source-Dirs: example + Main-Is: Synthesizer/LLVM/Test.hs + Other-Modules: + Synthesizer.LLVM.LAC2011 + Synthesizer.LLVM.ExampleUtility + +Executable synthi-llvm-lndw + If flag(buildExamples) && flag(alsa) + Build-Depends: + synthesizer-llvm, + + llvm-dsl, + llvm-extra, + llvm-tf, + tfp, + synthesizer-core, + synthesizer-midi, + midi, + sox, + storablevector, + numeric-prelude, + non-negative, + event-list, + random, + containers, + transformers, + non-empty, + utility-ht, + pathtype, + + synthesizer-alsa >=0.5 && <0.6, + alsa-pcm >=0.6 && <0.7, + base + Else + Buildable: False + Default-Language: Haskell98 + GHC-Options: -Wall + GHC-Prof-Options: -fprof-auto-exported + If impl(ghc>=7.0) + GHC-Options: -fwarn-unused-do-bind + CPP-Options: -DNoImplicitPrelude=RebindableSyntax + Default-Extensions: CPP + If impl(ghc<8.0) + GHC-Options: -fcontext-stack=1000 + Else + GHC-Options: -freduction-depth=1000 + Hs-Source-Dirs: example + Main-Is: Synthesizer/LLVM/TestALSA.hs + Other-Modules: + Synthesizer.LLVM.LNdW2011 + Synthesizer.LLVM.ExampleUtility + +Executable synthi-llvm-alsa + If flag(buildExamples) && flag(alsa) + Build-Depends: + server, + synthesizer-llvm, + + unsafe, + llvm-dsl, + llvm-tf, + synthesizer-core, + synthesizer-midi, + midi, + storablevector, + numeric-prelude, + non-negative, + event-list, + pathtype, + optparse-applicative, + containers, + transformers, + utility-ht, + + synthesizer-alsa >=0.5 && <0.6, + midi-alsa >=0.2.1 && <0.3, + alsa-seq >=0.6 && <0.7, + alsa-pcm >=0.6 && <0.7, + base + Else + Buildable: False + Default-Language: Haskell98 + -- -threaded -debug + GHC-Options: -Wall + GHC-Options: -rtsopts + GHC-Prof-Options: -fprof-auto-exported + If impl(ghc>=7.0) + GHC-Options: -fwarn-unused-do-bind + CPP-Options: -DNoImplicitPrelude=RebindableSyntax + Default-Extensions: CPP + If impl(ghc<8.0) + GHC-Options: -fcontext-stack=1000 + Else + GHC-Options: -freduction-depth=1000 + Hs-Source-Dirs: alsa + Main-Is: Synthesizer/LLVM/Server.hs + Other-Modules: + Synthesizer.LLVM.Server.Packed.Test + Synthesizer.LLVM.Server.Packed.Run + Synthesizer.LLVM.Server.Scalar.Test + Synthesizer.LLVM.Server.Scalar.Run + Synthesizer.LLVM.Server.CausalPacked.Run + Synthesizer.LLVM.Server.CausalPacked.Test + Synthesizer.LLVM.Server.ALSA + Synthesizer.LLVM.Server.Option + +Executable synthi-llvm-jack + If flag(buildExamples) && flag(jack) + Build-Depends: + server, + synthesizer-llvm, + tfp, + + jack >=0.7 && <0.8, + + synthesizer-core, + synthesizer-midi, + midi, + storablevector, + non-negative, + random, + explicit-exception >=0.1.7 && <0.3, + event-list, + pathtype, + optparse-applicative, + transformers, + + base + + Else + Buildable: False + Default-Language: Haskell98 + -- -threaded -debug + GHC-Options: -Wall + GHC-Options: -rtsopts + GHC-Prof-Options: -fprof-auto-exported + If impl(ghc>=7.0) + GHC-Options: -fwarn-unused-do-bind + CPP-Options: -DNoImplicitPrelude=RebindableSyntax + Default-Extensions: CPP + Hs-Source-Dirs: jack + Main-Is: Synthesizer/LLVM/Server/JACK.hs + Other-Modules: + Synthesizer.LLVM.Server.Option + +Executable synthi-llvm-render + If flag(buildExamples) + Build-Depends: + server, + synthesizer-llvm, + + sox, + synthesizer-core, + midi, + storablevector, + non-negative, + event-list, + shell-utility, + pathtype, + optparse-applicative, + base + + Else + Buildable: False + Default-Language: Haskell98 + -- -threaded -debug + GHC-Options: -Wall + GHC-Options: -rtsopts + GHC-Prof-Options: -fprof-auto-exported + If impl(ghc>=7.0) + GHC-Options: -fwarn-unused-do-bind + CPP-Options: -DNoImplicitPrelude=RebindableSyntax + Default-Extensions: CPP + Hs-Source-Dirs: render + Main-Is: Synthesizer/LLVM/Server/Render.hs + Other-Modules: + Synthesizer.LLVM.Server.Option + +Executable synthi-llvm-sample + If flag(buildExamples) + Build-Depends: + gnuplot >=0.5 && <0.6, + server, + synthesizer-llvm, + synthesizer-core, + midi, + numeric-prelude, + storablevector, + pathtype, + utility-ht, + base + Else + Buildable: False + Default-Language: Haskell98 + GHC-Options: -Wall + If impl(ghc>=7.0) + GHC-Options: -fwarn-unused-do-bind + CPP-Options: -DNoImplicitPrelude=RebindableSyntax + Default-Extensions: CPP + If impl(ghc<8.0) + GHC-Options: -fcontext-stack=1000 + Else + GHC-Options: -freduction-depth=1000 + Hs-Source-Dirs: . + Main-Is: src/Synthesizer/LLVM/Server/SampledSoundAnalysis.hs + +Executable synthi-llvm-speech + If flag(buildExamples) + Build-Depends: + gnuplot >=0.5 && <0.6, + pathtype, + sox, + llvm-dsl, + synthesizer-llvm, + synthesizer-core, + numeric-prelude, + storablevector, + utility-ht, + base + Else + Buildable: False + Default-Language: Haskell98 + GHC-Options: -Wall + If impl(ghc>=7.0) + GHC-Options: -fwarn-unused-do-bind + CPP-Options: -DNoImplicitPrelude=RebindableSyntax + Default-Extensions: CPP + If impl(ghc<8.0) + GHC-Options: -fcontext-stack=1000 + Else + GHC-Options: -freduction-depth=1000 + Main-Is: src/Synthesizer/LLVM/Server/CausalPacked/SpeechExplore.hs + +Test-Suite synthi-llvm-test + Type: exitcode-stdio-1.0 + Build-Depends: + doctest-exitcode-stdio >=0.0 && <0.1, + synthesizer-llvm, + + llvm-dsl, + llvm-extra, + llvm-tf, + tfp, + synthesizer-core, + storablevector, + numeric-prelude, + random, + utility-ht, + + QuickCheck >=1 && <3, + unsafe, + base + Default-Language: Haskell98 + GHC-Options: -Wall + If impl(ghc>=7.0) + GHC-Options: -fwarn-unused-do-bind + CPP-Options: -DNoImplicitPrelude=RebindableSyntax + Default-Extensions: CPP + If impl(ghc<8.0) + GHC-Options: -fcontext-stack=1000 + Else + GHC-Options: -freduction-depth=1000 + Hs-Source-Dirs: testsuite + Main-Is: Test/Main.hs + Other-Modules: + Test.Synthesizer.LLVM.RingBufferForward + Test.Synthesizer.LLVM.Helix + Test.Synthesizer.LLVM.Filter + Test.Synthesizer.LLVM.Packed + Test.Synthesizer.LLVM.Utility + Test.Synthesizer.LLVM.Generator diff --git a/testsuite/Test/Main.hs b/testsuite/Test/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/Test/Main.hs @@ -0,0 +1,32 @@ +module Main where + +import qualified Test.Synthesizer.LLVM.RingBufferForward as RingBufferForward +import qualified Test.Synthesizer.LLVM.Helix as Helix +import qualified Test.Synthesizer.LLVM.Filter as Filter +import qualified Test.Synthesizer.LLVM.Packed as Packed + +import qualified LLVM.Core as LLVM + +import Control.Monad.IO.Class (liftIO) + +import Data.Tuple.HT (mapFst) + +import qualified Test.DocTest.Driver as DocTest + + +prefix :: String -> [(String, prop)] -> [(String, prop)] +prefix msg = + map (mapFst (\str -> msg ++ "." ++ str)) + +main :: IO () +main = do + LLVM.initializeNativeTarget + DocTest.run $ mapM_ + (\(name,prop) -> do + DocTest.printPrefix (name++": ") + DocTest.property =<< liftIO prop) $ + prefix "Helix" Helix.tests ++ + prefix "RingBufferForward" RingBufferForward.tests ++ + prefix "Filter" Filter.tests ++ + prefix "Packed" Packed.tests ++ + [] diff --git a/testsuite/Test/Synthesizer/LLVM/Filter.hs b/testsuite/Test/Synthesizer/LLVM/Filter.hs new file mode 100644 --- /dev/null +++ b/testsuite/Test/Synthesizer/LLVM/Filter.hs @@ -0,0 +1,535 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeFamilies #-} +module Test.Synthesizer.LLVM.Filter (tests) where + +import qualified Synthesizer.LLVM.Filter.ComplexFirstOrderPacked + as ComplexFilterP +import qualified Synthesizer.LLVM.Filter.ComplexFirstOrder as ComplexFilter +import qualified Synthesizer.LLVM.Filter.Allpass as Allpass +import qualified Synthesizer.LLVM.Filter.FirstOrder as FirstOrder +import qualified Synthesizer.LLVM.Filter.SecondOrder as SecondOrder +import qualified Synthesizer.LLVM.Filter.SecondOrderPacked as SecondOrderP +import qualified Synthesizer.LLVM.Filter.Moog as Moog +import qualified Synthesizer.LLVM.Filter.Universal as UniFilter +import qualified Synthesizer.LLVM.Filter.NonRecursive as FiltNR + +import qualified Synthesizer.Plain.Filter.Recursive.Allpass as AllpassCore +import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as FirstOrderCore +import qualified Synthesizer.Plain.Filter.Recursive.Universal as UniFilterCore +import qualified Synthesizer.Plain.Filter.Recursive.Moog as MoogCore +import qualified Synthesizer.Plain.Filter.Recursive.FirstOrderComplex + as ComplexFilterCore + +import qualified Synthesizer.LLVM.Frame.SerialVector.Code as Serial +import qualified Synthesizer.LLVM.Wave as Wave +import qualified Synthesizer.LLVM.Causal.Process as Causal +import qualified Synthesizer.LLVM.Generator.SignalPacked as SigPS +import qualified Synthesizer.LLVM.Generator.Render as Render +import qualified Synthesizer.LLVM.Generator.Core as Core +import qualified Synthesizer.LLVM.Generator.Signal as Sig +import Synthesizer.LLVM.Causal.Process (($<), ($*)) + +import Synthesizer.Plain.Filter.Recursive (Pole(Pole)) +import qualified Synthesizer.Interpolation.Module as Ip +import qualified Synthesizer.Causal.Interpolation as InterpC +import qualified Synthesizer.Causal.Filter.NonRecursive as FiltC +import qualified Synthesizer.Causal.Displacement as DispC +import qualified Synthesizer.Causal.Process as CausalS +import qualified Synthesizer.State.Displacement as DispS +import qualified Synthesizer.State.Oscillator as OsciS +import qualified Synthesizer.State.Signal as SigS +import qualified Synthesizer.Basic.Wave as WaveCore +import qualified Synthesizer.Basic.Phase as Phase + +import qualified Data.StorableVector.Lazy as SVL + +import qualified Test.Synthesizer.LLVM.Generator as Gen +import Test.Synthesizer.LLVM.Generator + (checkWithParam, arg, pair, withGenArgs) +import Test.Synthesizer.LLVM.Utility + (checkSimilarity, checkSimilarityState, + CheckSimilarity, CheckSimilarityState, + randomStorableVector, checkSimilarityPacked) + +import qualified Control.Category as Cat +import Control.Category ((.), (<<<)) +import Control.Arrow ((&&&), (^<<)) +import Control.Applicative (liftA2, (<$>)) + +import qualified LLVM.DSL.Expression as Expr +import LLVM.DSL.Expression (Exp) + +import qualified LLVM.Extra.Multi.Value as MultiValue +import qualified LLVM.Extra.Arithmetic as A +import qualified LLVM.Extra.Memory as Memory + +import qualified Type.Data.Num.Decimal as TypeNum +import Type.Data.Num.Decimal (D4) +import Type.Base.Proxy (Proxy) + +import qualified Number.Complex as Complex +import qualified Synthesizer.LLVM.Frame.Stereo as Stereo + +import qualified System.Random as Rnd +import Data.Word (Word32) + +import qualified Test.QuickCheck as QC + +import NumericPrelude.Numeric +import NumericPrelude.Base hiding ((.)) + + +type SimFloat = CheckSimilarity Float +type SimStateFloat = CheckSimilarityState Float +type VectorValue = Serial.Value D4 Float + +signalLength :: Int +signalLength = 10000 + + +limitFloat :: SVL.Vector Float -> SVL.Vector Float +limitFloat = SVL.take signalLength + +{- +limitStereoFloat :: SVL.Vector (Stereo.T Float) -> SVL.Vector (Stereo.T Float) +limitStereoFloat = SVL.take signalLength +-} + + +lfoSine :: + (Memory.C a, Expr.Aggregate ae a) => + (Exp Float -> ae) -> + Exp Float -> + Sig.T a +lfoSine f reduct = + Sig.interpolateConstant reduct $ + (Causal.map f . Causal.mapExponential 2 0.01 $* + Sig.osci Wave.sine 0 (reduct * (0.1/44100))) + +allpassControl :: + (TypeNum.Natural n) => + Proxy n -> + Exp Float -> + Sig.T (Allpass.CascadeParameter n (MultiValue.T Float)) +allpassControl order = + lfoSine (Allpass.flangerParameter order) + +allpassPhaserCausal, allpassPhaserPipeline :: + Exp Float -> + Sig.T (MultiValue.T Float) -> + Sig.T (MultiValue.T Float) +allpassPhaserCausal reduct xs = + Allpass.phaser + $< allpassControl TypeNum.d16 reduct + $* xs + +allpassPhaserPipeline reduct xs = + let order = TypeNum.d16 + in (Sig.drop (TypeNum.integralFromProxy order)) $ + (Allpass.phaserPipeline + $< allpassControl order reduct + $* xs) + + +genOsci :: QC.Gen (Float, Float) +genOsci = pair (Gen.choose (0.001, 0.01)) (Gen.choose (0, 0.99)) + +genOsciReduct :: QC.Gen ((Float, Float), Float) +genOsciReduct = pair genOsci (Gen.choose (10, 100)) + +genOsciReductPacked :: QC.Gen ((Float, Float), Float) +genOsciReductPacked = pair genOsci (arg $ (4*) <$> QC.choose (1, 25)) + +allpassPipeline :: Gen.Test ((Float,Float), Float) SimFloat +allpassPipeline = + withGenArgs genOsciReduct $ + let tone (freq,phase) = Sig.osci Wave.triangle phase freq + in checkSimilarity 1e-2 limitFloat + (\(freqPhase, reduct) -> + allpassPhaserCausal reduct $ tone freqPhase) + (\(freqPhase, reduct) -> + allpassPhaserPipeline reduct $ tone freqPhase) + + + +{- | +Shrink control signal in time +since we can only handle one control parameter per vector chunk. +-} +applyPacked :: + (Memory.C c) => + Causal.T (c, VectorValue) VectorValue -> + Sig.T c -> + Sig.T VectorValue -> + Sig.T VectorValue +applyPacked proc cs xs = + proc + $< Sig.interpolateConstant + (recip $ TypeNum.integralFromProxy TypeNum.d4 :: Exp Float) cs + $* xs + + +allpassPhaserPacked :: + Exp Float -> + Sig.T VectorValue -> + Sig.T VectorValue +allpassPhaserPacked reduct = + applyPacked Allpass.phaserPacked + (allpassControl TypeNum.d16 reduct) + +allpassPacked :: Gen.Test ((Float,Float), Float) SimFloat +allpassPacked = + withGenArgs genOsciReductPacked $ + let tone (freq,phase) = Sig.osci Wave.triangle phase freq + toneP (freq,phase) = SigPS.osci Wave.triangle phase freq + in checkSimilarityPacked 1e-2 limitFloat + (\(freqPhase, reduct) -> allpassPhaserCausal reduct $ tone freqPhase) + (\(freqPhase, reduct) -> allpassPhaserPacked reduct $ toneP freqPhase) + + +interpolateConstant :: Float -> SigS.T a -> SigS.T a +interpolateConstant reduct xs = + CausalS.apply (InterpC.relative Ip.constant 0 xs) $ + SigS.repeat $ recip reduct + + +{-# INLINE lfoSineCore #-} +lfoSineCore :: + (Float -> a) -> + Float -> + SigS.T a +lfoSineCore f reduct = + interpolateConstant reduct $ + SigS.map f $ + DispS.mapExponential 2 0.01 $ + OsciS.static WaveCore.sine zero (reduct * 0.1/44100) + +{-# INLINE allpassPhaserCore #-} +allpassPhaserCore :: + Float -> + SigS.T Float -> + SigS.T Float +allpassPhaserCore reduct = + let order = 16 + in CausalS.apply $ + FiltC.amplify 0.5 <<< + DispC.mix <<< + ((CausalS.applyFst (AllpassCore.cascadeCausal order) $ + lfoSineCore (AllpassCore.flangerParameter order) reduct) + &&& + Cat.id) + +allpassCore :: Gen.Test ((Float,Float), Float) SimStateFloat +allpassCore = + withGenArgs genOsciReduct $ + let tone (freq,phase) = Sig.osci Wave.triangle phase freq + toneS (freq,phase) = + OsciS.static WaveCore.triangle + (Phase.fromRepresentative phase) freq + in checkSimilarityState 1e-2 limitFloat + (\(freqPhase, reduct) -> allpassPhaserCausal reduct $ tone freqPhase) + (\(freqPhase, reduct) -> allpassPhaserCore reduct $ toneS freqPhase) + + + +diracImpulse :: Sig.T (MultiValue.T Float) +diracImpulse = Causal.delay1 one $* Sig.constant zero + +firstOrderConstant :: + Exp Float -> + Sig.T (MultiValue.T Float) -> + Sig.T (MultiValue.T Float) +firstOrderConstant cutOff xs = + FirstOrder.lowpassCausal + $< Sig.constant (FirstOrderCore.parameter cutOff) + $* xs + +firstOrderExponential :: Gen.Test Float SimFloat +firstOrderExponential = + withGenArgs (Gen.choose (0.001, 0.01)) $ + let gain cutOff = exp(-2*pi*cutOff) + in checkSimilarity 1e-2 limitFloat + (\cutOff -> + Causal.amplify (recip (1 - gain cutOff)) $* + firstOrderConstant cutOff diracImpulse) + (\cutOff -> Core.exponential (gain cutOff) one) + +firstOrderCausal :: + Exp Float -> + Sig.T (MultiValue.T Float) -> + Sig.T (MultiValue.T Float) +firstOrderCausal reduct xs = + FirstOrder.lowpassCausal + $< lfoSine FirstOrder.parameter reduct + $* xs + +{-# INLINE firstOrderCore #-} +firstOrderCore :: + Float -> + SigS.T Float -> + SigS.T Float +firstOrderCore reduct = + CausalS.apply $ + CausalS.applyFst FirstOrderCore.lowpassCausal $ + lfoSineCore FirstOrderCore.parameter reduct + +firstOrder :: Gen.Test ((Float,Float), Float) SimStateFloat +firstOrder = + withGenArgs genOsciReduct $ + let tone (freq,phase) = Sig.osci Wave.triangle phase freq + toneS (freq,phase) = + OsciS.static WaveCore.triangle + (Phase.fromRepresentative phase) freq + in checkSimilarityState 1e-2 limitFloat + (\(freqPhase, reduct) -> firstOrderCausal reduct $ tone freqPhase) + (\(freqPhase, reduct) -> firstOrderCore reduct $ toneS freqPhase) + +firstOrderCausalPacked :: + Exp Float -> + Sig.T VectorValue -> + Sig.T VectorValue +firstOrderCausalPacked reduct = + applyPacked + FirstOrder.lowpassCausalPacked + (lfoSine FirstOrder.parameter reduct) + +firstOrderPacked :: Gen.Test ((Float,Float), Float) SimFloat +firstOrderPacked = + withGenArgs genOsciReductPacked $ + let tone (freq,phase) = Sig.osci Wave.triangle phase freq + toneP (freq,phase) = SigPS.osci Wave.triangle phase freq + in checkSimilarityPacked 1e-2 limitFloat + (\(freqPhase, reduct) -> + firstOrderCausal reduct $ tone freqPhase) + (\(freqPhase, reduct) -> + firstOrderCausalPacked reduct $ toneP freqPhase) + + +secondOrderCausal :: + Exp Float -> + Sig.T (MultiValue.T Float) -> + Sig.T (MultiValue.T Float) +secondOrderCausal reduct xs = + SecondOrder.causal + $< lfoSine (SecondOrder.bandpassParameter 10) reduct + $* xs + +secondOrderCausalPacked :: + Exp Float -> + Sig.T VectorValue -> + Sig.T VectorValue +secondOrderCausalPacked reduct = + applyPacked SecondOrder.causalPacked + (lfoSine (SecondOrder.bandpassParameter 10) reduct) + +secondOrderPacked :: Gen.Test ((Float,Float), Float) SimFloat +secondOrderPacked = + withGenArgs genOsciReductPacked $ + let tone (freq,phase) = Sig.osci Wave.triangle phase freq + toneP (freq,phase) = SigPS.osci Wave.triangle phase freq + in checkSimilarityPacked 1e-2 limitFloat + (\(freqPhase, reduct) -> + secondOrderCausal reduct $ tone freqPhase) + (\(freqPhase, reduct) -> + secondOrderCausalPacked reduct $ toneP freqPhase) + +secondOrderCausalPacked2 :: + Exp Float -> + Sig.T (MultiValue.T Float) -> + Sig.T (MultiValue.T Float) +secondOrderCausalPacked2 reduct xs = + SecondOrderP.causal + $< lfoSine (SecondOrderP.bandpassParameter 10) reduct + $* xs + +secondOrderPacked2 :: Gen.Test ((Float,Float), Float) SimFloat +secondOrderPacked2 = + withGenArgs genOsciReduct $ + let tone (freq,phase) = Sig.osci Wave.triangle phase freq + in checkSimilarity 1e-2 limitFloat + (\(freqPhase, reduct) -> + secondOrderCausal reduct $ tone freqPhase) + (\(freqPhase, reduct) -> + secondOrderCausalPacked2 reduct $ tone freqPhase) + + +{- +limitUniFilter :: + SVL.Vector (UniFilterCore.Result Float) -> + SVL.Vector (UniFilterCore.Result Float) +limitUniFilter = SVL.take signalLength +-} + +universalCausal :: + Exp Float -> + Sig.T (MultiValue.T Float) -> + Sig.T (UniFilter.Result (MultiValue.T Float)) +universalCausal reduct xs = + UniFilter.causal + $< lfoSine (UniFilter.parameter 10) reduct + $* xs + +{-# INLINE universalCore #-} +universalCore :: + Float -> + SigS.T Float -> + SigS.T (UniFilterCore.Result Float) +universalCore reduct = + CausalS.apply $ + CausalS.applyFst UniFilterCore.causal $ + lfoSineCore (UniFilterCore.parameter . Pole 10) reduct + +universal :: Gen.Test ((Float,Float), Float) SimStateFloat +universal = + withGenArgs genOsciReduct $ + let tone (freq,phase) = Sig.osci Wave.triangle phase freq + toneS (freq,phase) = + OsciS.static WaveCore.triangle + (Phase.fromRepresentative phase) freq + in checkSimilarityState 1e-2 limitFloat + (\(freqPhase, reduct) -> + fmap UniFilter.lowpass $ + universalCausal reduct $ tone freqPhase) + (\(freqPhase, reduct) -> + SigS.map UniFilterCore.lowpass $ + universalCore reduct $ toneS freqPhase) +{- + checkSimilarityState 1e-2 limitUniFilter + (universalCausal reduct tone) + (\p -> universalCore (Param.get reduct p) (toneS p)) +-} + + +moogCausal :: + (TypeNum.Natural n) => + Proxy n -> + Exp Float -> + Sig.T (MultiValue.T Float) -> + Sig.T (MultiValue.T Float) +moogCausal order reduct xs = + Moog.causal + $< lfoSine (Moog.parameter order 10) reduct + $* xs + +{-# INLINE moogCore #-} +moogCore :: + Int -> + Float -> + SigS.T Float -> + SigS.T Float +moogCore order reduct = + CausalS.apply $ + CausalS.applyFst (MoogCore.lowpassCausal order) $ + lfoSineCore (MoogCore.parameter order . Pole 10) reduct + +moog :: Gen.Test ((Float,Float), Float) SimStateFloat +moog = + withGenArgs genOsciReduct $ + let order = TypeNum.d6 + tone (freq,phase) = Sig.osci Wave.triangle phase freq + toneS (freq,phase) = + OsciS.static WaveCore.triangle + (Phase.fromRepresentative phase) freq + in checkSimilarityState 1e-2 limitFloat + (\(freqPhase, reduct) -> + moogCausal order reduct $ tone freqPhase) + (\(freqPhase, reduct) -> + moogCore (TypeNum.integralFromProxy order) reduct $ + toneS freqPhase) + + +complexCausal :: + Exp Float -> + Sig.T (MultiValue.T Float) -> + Sig.T (Stereo.T (MultiValue.T Float)) +complexCausal reduct xs = + ComplexFilter.causal + $< lfoSine (ComplexFilter.parameter 10) reduct + $* ((\x -> Stereo.cons x A.zero) <$> xs) + +complexCausalPacked :: + Exp Float -> + Sig.T (MultiValue.T Float) -> + Sig.T (Stereo.T (MultiValue.T Float)) +complexCausalPacked reduct xs = + ComplexFilterP.causal + $< lfoSine (ComplexFilterP.parameter 10) reduct + $* ((\x -> Stereo.cons x A.zero) <$> xs) + +complexPacked :: Gen.Test ((Float,Float), Float) SimFloat +complexPacked = + withGenArgs genOsciReduct $ + let tone (freq,phase) = Sig.osci Wave.triangle phase freq + in checkSimilarity 1e-2 limitFloat + (\(freqPhase, reduct) -> + fmap Stereo.left $ + complexCausal reduct $ tone freqPhase) + (\(freqPhase, reduct) -> + fmap Stereo.left $ + complexCausalPacked reduct $ tone freqPhase) + +{-# INLINE complexCore #-} +complexCore :: + Float -> + SigS.T Float -> + SigS.T (Stereo.T Float) +complexCore reduct = + CausalS.apply $ + (\x -> Stereo.cons (Complex.real x) (Complex.imag x)) ^<< + CausalS.applyFst ComplexFilterCore.causal + (lfoSineCore (ComplexFilterCore.parameter . Pole 10) reduct) + +complex :: Gen.Test ((Float,Float), Float) SimStateFloat +complex = + withGenArgs genOsciReduct $ + let tone (freq,phase) = Sig.osci Wave.triangle phase freq + toneS (freq,phase) = + OsciS.static WaveCore.triangle + (Phase.fromRepresentative phase) freq + in checkSimilarityState 1e-2 limitFloat + (\(freqPhase, reduct) -> + fmap Stereo.left $ + complexCausal reduct $ tone freqPhase) + (\(freqPhase, reduct) -> + SigS.map ((0.1*) . Stereo.left) $ + complexCore reduct $ toneS freqPhase) +{- + in checkSimilarityState 1e-2 limitStereoFloat + (complexCausal reduct tone) + (\p -> complexCore (Param.get reduct p) (toneS p)) +-} + + +convolvePacked :: Gen.Test ((Int,Rnd.StdGen), Word32) SimFloat +convolvePacked = + withGenArgs + (pair + (arg $ liftA2 (,) (QC.choose (1,20)) (Rnd.mkStdGen <$> QC.arbitrary)) + Gen.arbitrary) + $ + fmap + (\f chunkSize (rnd, seed) -> + f chunkSize + (Render.buffer $ randomStorableVector (-1,1::Float) rnd, seed)) + $ + checkSimilarityPacked 1e-3 limitFloat + (\(mask, seed) -> FiltNR.convolve mask $* Sig.noise seed 1) + (\(mask, seed) -> FiltNR.convolvePacked mask $* SigPS.noise seed 1) + + +tests :: [(String, IO QC.Property)] +tests = + ("secondOrderPacked", checkWithParam secondOrderPacked) : + ("secondOrderPacked2", checkWithParam secondOrderPacked2) : + ("firstOrderExponential", checkWithParam firstOrderExponential) : + ("firstOrder", checkWithParam firstOrder) : + ("firstOrderPacked", checkWithParam firstOrderPacked) : + ("universal", checkWithParam universal) : + ("allpassPacked", checkWithParam allpassPacked) : + ("allpassPipeline", checkWithParam allpassPipeline) : + ("allpassCore", checkWithParam allpassCore) : + ("moog", checkWithParam moog) : + ("complexPacked", checkWithParam complexPacked) : + ("complex", checkWithParam complex) : + ("convolvePacked", checkWithParam convolvePacked) : + [] diff --git a/testsuite/Test/Synthesizer/LLVM/Generator.hs b/testsuite/Test/Synthesizer/LLVM/Generator.hs new file mode 100644 --- /dev/null +++ b/testsuite/Test/Synthesizer/LLVM/Generator.hs @@ -0,0 +1,45 @@ +module Test.Synthesizer.LLVM.Generator where + + +import Data.StorableVector.Lazy (ChunkSize) + +import System.Random (Random) + +import Control.Category (id) +import Control.Applicative (liftA2, liftA3) + +import qualified Test.QuickCheck as QC + +import Prelude hiding (id) + + +type T f p a = QC.Gen p + +type Param p = (->) p + +arg :: QC.Gen a -> QC.Gen a +arg = id + +arbitrary :: (QC.Arbitrary a) => QC.Gen a +arbitrary = QC.arbitrary + +choose :: (Random a) => (a,a) -> QC.Gen a +choose = QC.choose + + +pair :: QC.Gen a -> QC.Gen b -> QC.Gen (a,b) +pair = liftA2 (,) + +triple :: QC.Gen a -> QC.Gen b -> QC.Gen c -> QC.Gen (a,b,c) +triple = liftA3 (,,) + +withGenArgs :: QC.Gen p -> (IO (ChunkSize -> p -> test)) -> Test p test +withGenArgs = (,) + + +type Test p test = (QC.Gen p, IO (ChunkSize -> p -> test)) + +checkWithParam :: (Show p, QC.Testable test) => Test p test -> IO QC.Property +checkWithParam (gen, test) = do + f <- test + return $ QC.property (QC.forAll gen $ flip f) diff --git a/testsuite/Test/Synthesizer/LLVM/Helix.hs b/testsuite/Test/Synthesizer/LLVM/Helix.hs new file mode 100644 --- /dev/null +++ b/testsuite/Test/Synthesizer/LLVM/Helix.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +module Test.Synthesizer.LLVM.Helix (tests) where + +import qualified Synthesizer.LLVM.Causal.Helix as Helix +import qualified Synthesizer.LLVM.Causal.Functional as Func +import qualified Synthesizer.LLVM.Causal.Process as Causal +import qualified Synthesizer.LLVM.Generator.Render as Render +import qualified Synthesizer.LLVM.Generator.Source as Source +import qualified Synthesizer.LLVM.Generator.Signal as Sig +import qualified Synthesizer.LLVM.Interpolation as Interpolation +import Synthesizer.LLVM.Causal.Functional (($&), (&|&)) +import Synthesizer.LLVM.Causal.Process (($*)) + +import qualified Data.StorableVector.Lazy as SVL +import Data.StorableVector.Lazy (ChunkSize) + +import Test.Synthesizer.LLVM.Generator (checkWithParam) +import Test.Synthesizer.LLVM.Utility + (CheckSimilarity, checkSimilarity, + genRandomVectorParam, randomStorableVectorLoop) + +import qualified LLVM.DSL.Expression as Expr +import LLVM.DSL.Expression (Exp) + +import qualified LLVM.Extra.Multi.Value as MultiValue + +import Foreign.Storable (Storable) + +import qualified System.Random as Rnd +import Data.Word (Word32) + +import Control.Applicative (liftA2) + +-- import qualified Graphics.Gnuplot.Simple as Gnuplot +import qualified Test.QuickCheck as QC + +import qualified Algebra.Ring as Ring +import NumericPrelude.Numeric +import NumericPrelude.Base + + +type SimFloat = CheckSimilarity Float + +signalLength :: Int +signalLength = 500 + + +limitFloat :: (Storable a) => SVL.Vector a -> SVL.Vector a +limitFloat = SVL.take signalLength + + +randomSpeed :: (Int, Rnd.StdGen) -> SVL.Vector Float +randomSpeed = randomStorableVectorLoop (0,10) + +randomPhase :: (Int, Rnd.StdGen) -> SVL.Vector Float +randomPhase = randomStorableVectorLoop (0,1) + +genStaticDynamic :: + QC.Gen (((Int, Rnd.StdGen), (Int, Rnd.StdGen)), (Float, Word32)) +genStaticDynamic = + liftA2 (,) + (liftA2 (,) genRandomVectorParam genRandomVectorParam) + (liftA2 (,) (QC.choose (1,32)) QC.arbitrary) + +staticDynamic :: + IO (ChunkSize -> + (((Int, Rnd.StdGen), (Int, Rnd.StdGen)), (Float, Word32)) -> SimFloat) +staticDynamic = + let len :: (Ring.C a) => a + len = 1000 + noise :: Exp Word32 -> Sig.T (MultiValue.T Float) + noise seed = Sig.noise seed 1 + + static, dynamic :: + ((Sig.T (MultiValue.T Float), Sig.T (MultiValue.T Float)), + Exp Float, + (Exp Word32, Exp (Source.StorableVector Float))) -> + Func.T inp (MultiValue.T Float) + static ((speedSig, phaseSig), period, (_, noiseSig)) = + Helix.static Interpolation.linear Interpolation.linear + (Expr.roundToIntFast period) period noiseSig + $& + Func.fromSignal (Causal.integrate zero $* speedSig) + &|& + Func.fromSignal phaseSig + + dynamic ((speedSig, phaseSig), period, (noiseParam, _)) = + Helix.dynamic Interpolation.linear Interpolation.linear + (Expr.roundToIntFast period) period + (Causal.take len $* noise noiseParam) + $& + Func.fromSignal speedSig + &|& + Func.fromSignal phaseSig + + in liftA2 + (\noiseSig f chunkSize + ((speedParam, phaseParam), (period, noiseParam)) -> + f chunkSize + ((randomSpeed speedParam, randomPhase phaseParam), + period, + (noiseParam, Render.buffer (noiseSig len noiseParam)))) + (Render.run noise) + (checkSimilarity 5e-3 limitFloat + (Func.compileSignal . static) + (Func.compileSignal . dynamic)) + +{- +plot :: IO () +plot = do + render <- staticDynamic + case render (SVL.chunkSize 1) + (((76, Rnd.mkStdGen 0),(84, Rnd.mkStdGen 23)),(8.901705,11)) of + CheckSimilarity _tol xs ys -> + Gnuplot.plotLists [] [SVL.unpack xs, SVL.unpack ys] + >> + Gnuplot.plotList [] (zipWith (-) (SVL.unpack xs) (SVL.unpack ys)) +-} + + +tests :: [(String, IO QC.Property)] +tests = + ("staticDynamic", checkWithParam (genStaticDynamic, staticDynamic)) : + [] diff --git a/testsuite/Test/Synthesizer/LLVM/Packed.hs b/testsuite/Test/Synthesizer/LLVM/Packed.hs new file mode 100644 --- /dev/null +++ b/testsuite/Test/Synthesizer/LLVM/Packed.hs @@ -0,0 +1,210 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module Test.Synthesizer.LLVM.Packed (tests) where + +import qualified Test.Synthesizer.LLVM.Generator as Gen +import Test.Synthesizer.LLVM.Generator + (Test, checkWithParam, arg, pair, withGenArgs) +import Test.Synthesizer.LLVM.Utility + (checkSimilarity, checkEquality, + CheckSimilarity, CheckEquality, checkSimilarityPacked) + +import qualified Synthesizer.LLVM.Wave as Wave +import LLVM.DSL.Expression (Exp) + +import Type.Data.Num.Decimal (D4) +import qualified Type.Data.Num.Decimal as TypeNum + +import qualified Synthesizer.LLVM.Frame.SerialVector.Plain as SerialPlain +import qualified Synthesizer.LLVM.Frame.SerialVector.Code as SerialCode +import qualified Synthesizer.LLVM.Generator.SignalPacked as SigPS +import qualified Synthesizer.LLVM.Generator.Core as SigCore +import qualified Synthesizer.LLVM.Generator.Signal as Sig +import qualified Synthesizer.LLVM.Causal.Exponential2 as Exp +import qualified Synthesizer.LLVM.Causal.Process as Causal +import Synthesizer.LLVM.Causal.Process (($*)) + +import qualified Synthesizer.LLVM.Storable.Signal as SigStL +import qualified Data.StorableVector.Lazy as SVL +import Data.StorableVector.Lazy (ChunkSize) + +import Control.Arrow ((<<<)) +import Control.Applicative ((<$>)) + +import Data.Word (Word, Word32) + +import qualified Test.QuickCheck as QC + +import qualified Algebra.Ring as Ring + +import NumericPrelude.Numeric +import NumericPrelude.Base + + +type SimFloat = CheckSimilarity Float +type VectorValue = SerialCode.Value D4 Float + +signalLength :: Int +signalLength = 10000 + + +limitFloat :: SVL.Vector Float -> SVL.Vector Float +limitFloat = SVL.take signalLength + + +withDur :: (Ring.C a) => IO (ChunkSize -> a -> b) -> Test a b +withDur = + withGenArgs (arg (fromIntegral <$> QC.choose (signalLength, 2*signalLength))) + +{- +limitPackedFloat :: + SVL.Vector (SerialPlain.T D4 Float) -> SVL.Vector (SerialPlain.T D4 Float) +limitPackedFloat = SVL.take (div signalLength 4) +-} + +constant :: Test Float SimFloat +constant = + withGenArgs (Gen.choose (-1, 1)) $ + checkSimilarityPacked 1e-3 limitFloat + (\y -> Sig.constant y) (\y -> SigPS.constant y) + +ramp :: Test Float SimFloat +ramp = + withDur $ + checkSimilarityPacked 1e-3 limitFloat + (\dur -> Sig.rampInf dur) (\dur -> SigPS.rampInf dur) + +parabolaFadeIn :: Test Float SimFloat +parabolaFadeIn = + withDur $ + checkSimilarityPacked 1e-3 limitFloat + (\dur -> Sig.parabolaFadeInInf dur) + (\dur -> SigPS.parabolaFadeInInf dur) + +parabolaFadeOut :: Test Float SimFloat +parabolaFadeOut = + withDur $ + checkSimilarityPacked 1e-3 limitFloat + (\dur -> Sig.parabolaFadeOutInf dur) + (\dur -> SigPS.parabolaFadeOutInf dur) + +parabolaFadeInMap :: Test Word SimFloat +parabolaFadeInMap = + withDur $ + checkSimilarity 1e-3 limitFloat + (\dur -> Sig.parabolaFadeIn dur) + (\dur -> Sig.parabolaFadeInMap dur) + +parabolaFadeOutMap :: Test Word SimFloat +parabolaFadeOutMap = + withDur $ + checkSimilarity 1e-3 limitFloat + (\dur -> Sig.parabolaFadeOut dur) + (\dur -> Sig.parabolaFadeOutMap dur) + + +genExp :: QC.Gen (Float, Float) +genExp = pair (Gen.choose (1000,10000)) (Gen.choose (-1,1)) + +exponential2 :: Test (Float,Float) SimFloat +exponential2 = + withGenArgs genExp $ + checkSimilarityPacked 1e-3 limitFloat + (\(halfLife,start) -> Sig.exponential2 halfLife start) + (\(halfLife,start) -> SigPS.exponential2 halfLife start) + +exponential2Static :: Test (Float,Float) SimFloat +exponential2Static = + withGenArgs genExp $ + checkSimilarity 1e-3 limitFloat + (\(halfLife,start) -> Sig.exponential2 halfLife start) + (\(halfLife,start) -> + Exp.causal start <<< + Causal.map Exp.parameterPlain $* + Sig.constant halfLife) + +exponential2PackedStatic :: Test (Float,Float) SimFloat +exponential2PackedStatic = + withGenArgs genExp $ + checkSimilarity 1e-3 (limitFloat . SigStL.unpack) + (\(halfLife,start) -> + SigPS.exponential2 halfLife start :: Sig.T VectorValue) + (\(halfLife,start) -> + Exp.causalPacked start <<< + Causal.map Exp.parameterPackedExp $* + Sig.constant halfLife) + +exponential2Controlled :: Test ((Float,Float), (Float,Float)) SimFloat +exponential2Controlled = + withGenArgs + (pair genExp + (pair (Gen.choose (0.0001, 0.001)) (Gen.choose (0, 0.99 :: Float)))) $ + + let lfo halfLife freq phase = + Causal.mapExponential 2 halfLife $* + Sig.osci Wave.approxSine2 phase freq + in checkSimilarityPacked 1e-3 limitFloat + (-- 'freq' is the LFO frequency measured at vector-rate + \((halfLife,start), (freq,phase)) -> + Exp.causal start <<< + Causal.map Exp.parameterPlain $* + Sig.interpolateConstant + (TypeNum.integralFromProxy TypeNum.d4 :: Exp Float) + (lfo halfLife freq phase)) + (\((halfLife,start), (freq,phase)) -> + Exp.causalPacked start <<< + Causal.map Exp.parameterPackedExp $* lfo halfLife freq phase) + +osci :: Test (Float,Float) SimFloat +osci = + withGenArgs + (pair + (Gen.choose (0.001, 0.01)) + (Gen.choose (0, 0.99))) $ + checkSimilarityPacked 1e-2 limitFloat + (\(freq,phase) -> Sig.osci Wave.approxSine2 phase freq) + (\(freq,phase) -> SigPS.osci Wave.approxSine2 phase freq) + + + +limitWord32 :: SVL.Vector Word32 -> SVL.Vector Word32 +limitWord32 = SVL.take signalLength + +limitPackedWord32 :: + SVL.Vector (SerialPlain.T D4 Word32) -> SVL.Vector (SerialPlain.T D4 Word32) +limitPackedWord32 = SVL.take (div signalLength 4) + + +noise :: IO (ChunkSize -> Word32 -> CheckEquality Word32) +noise = + checkEquality limitWord32 SigCore.noise SigCore.noiseAlt + +noiseVector :: + IO (ChunkSize -> Word32 -> CheckEquality (SerialPlain.T D4 Word32)) +noiseVector = + checkEquality limitPackedWord32 SigPS.noiseCore SigPS.noiseCoreAlt + +noiseScalarVector :: + IO (ChunkSize -> Word32 -> CheckEquality (SerialPlain.T D4 Word32)) +noiseScalarVector = + checkEquality limitPackedWord32 + SigPS.noiseCore + (SigPS.packSmall . SigCore.noise) + + +tests :: [(String, IO QC.Property)] +tests = + ("constant", checkWithParam constant) : + ("ramp", checkWithParam ramp) : + ("parabolaFadeIn", checkWithParam parabolaFadeIn) : + ("parabolaFadeOut", checkWithParam parabolaFadeOut) : + ("parabolaFadeInMap", checkWithParam parabolaFadeInMap) : + ("parabolaFadeOutMap", checkWithParam parabolaFadeOutMap) : + ("exponential2", checkWithParam exponential2) : + ("exponential2Static", checkWithParam exponential2Static) : + ("exponential2PackedStatic", checkWithParam exponential2PackedStatic) : + ("exponential2Controlled", checkWithParam exponential2Controlled) : + ("osci", checkWithParam osci) : + ("noise", QC.property <$> noise) : + ("noiseVector", QC.property <$> noiseVector) : + ("noiseScalarVector", QC.property <$> noiseScalarVector) : + [] diff --git a/testsuite/Test/Synthesizer/LLVM/RingBufferForward.hs b/testsuite/Test/Synthesizer/LLVM/RingBufferForward.hs new file mode 100644 --- /dev/null +++ b/testsuite/Test/Synthesizer/LLVM/RingBufferForward.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module Test.Synthesizer.LLVM.RingBufferForward (tests) where + +import qualified Synthesizer.LLVM.Causal.RingBufferForward as RingBuffer +import qualified Synthesizer.LLVM.Causal.Process as Causal +import qualified Synthesizer.LLVM.Generator.Signal as Sig +import Synthesizer.LLVM.Causal.Process (($*)) + +import qualified Data.StorableVector.Lazy as SVL + +import qualified Test.Synthesizer.LLVM.Generator as Gen +import Test.Synthesizer.LLVM.Generator + (Test, checkWithParam, arg, pair, triple, withGenArgs) +import Test.Synthesizer.LLVM.Utility + (CheckEquality, CheckEquality2, checkEquality, checkEquality2, + genRandomVectorParam, randomStorableVectorLoop) + +import qualified Control.Arrow as Arrow +import Control.Arrow ((<<^)) +import Control.Applicative ((<$>)) + +import qualified LLVM.DSL.Expression as Expr + +import qualified LLVM.Extra.Multi.Value as MultiValue + +import Foreign.Storable (Storable) + +import qualified System.Random as Rnd +import Data.Word (Word, Word32) + +import qualified Test.QuickCheck as QC + +import NumericPrelude.Numeric +import NumericPrelude.Base + + +type EquFloat = CheckEquality Float + +signalLength :: Int +signalLength = 10000 + + +limitFloat :: (Storable a) => SVL.Vector a -> SVL.Vector a +limitFloat = SVL.take signalLength + + +trackId :: Test (Word, Word32) EquFloat +trackId = + withGenArgs (pair (Gen.choose (1,1000)) Gen.arbitrary) $ + let noise seed = Sig.noise seed 1 + in checkEquality limitFloat + (\(_bufferSize, seed) -> noise seed) + (\(bufferSize, seed) -> + RingBuffer.mapIndex zero + $* RingBuffer.track bufferSize (noise seed)) + +trackTail :: Test (Word, Word32) EquFloat +trackTail = + withGenArgs (pair (Gen.choose (2,1000)) Gen.arbitrary) $ + let noise seed = Sig.noise seed 1 + in checkEquality limitFloat + (\(_bufferSize, seed) -> Sig.tail $ noise seed) + (\(bufferSize, seed) -> + RingBuffer.mapIndex one + $* RingBuffer.track bufferSize (noise seed)) + +trackDrop :: Test (Word, Word32) EquFloat +trackDrop = + withGenArgs (pair (Gen.choose (0,1000)) Gen.arbitrary) $ + let noise seed = Sig.noise seed 1 + in checkEquality limitFloat + (\(n, seed) -> Sig.drop n $ noise seed) + (\(n, seed) -> + RingBuffer.mapIndex n $* RingBuffer.track (n+1) (noise seed)) + +randomSkips :: (Int, Rnd.StdGen) -> SVL.Vector Word +randomSkips = randomStorableVectorLoop (0,10) + +trackSkip :: Test ((Int, Rnd.StdGen), Word32) EquFloat +trackSkip = + withGenArgs (pair (arg genRandomVectorParam) Gen.arbitrary) $ + let noise seed = Sig.noise seed 1 + in (\f chunkSize (sk, seed) -> f chunkSize (randomSkips sk, seed)) + <$> + checkEquality limitFloat + (\(skips, seed) -> Causal.skip (noise seed) $* skips) + (\(skips, seed) -> + RingBuffer.mapIndex one + $* (RingBuffer.trackSkip 1 (noise seed) $* skips)) + +trackSkip1 :: Test (Word, Word32) EquFloat +trackSkip1 = + let bufferSize = 1000 + in withGenArgs + (pair + (Gen.choose (0, fromIntegral bufferSize - 1)) + Gen.arbitrary) $ + + let noise seed = Sig.noise seed 1 + in checkEquality limitFloat + (\(k, seed) -> + RingBuffer.mapIndex k $* + RingBuffer.track (Expr.cons bufferSize) (noise seed)) + (\(k, seed) -> + RingBuffer.mapIndex k $* + (RingBuffer.trackSkip (Expr.cons bufferSize) (noise seed) + $* 1)) + +trackSkipHold :: + Test ((Int, Rnd.StdGen), Word, Word32) (CheckEquality2 Bool Float) +trackSkipHold = + let bufferSize = 1000 + in withGenArgs + (triple + (arg genRandomVectorParam) + (Gen.choose (0, fromIntegral bufferSize - 1)) + Gen.arbitrary) $ + + let noise seed = Sig.noise seed 1 + in (\f chunkSize (sk, k, seed) -> + f chunkSize (randomSkips sk, k, seed)) + <$> + checkEquality2 limitFloat limitFloat + (\(skips, k, seed) -> + (,) (MultiValue.cons True) <$> + (RingBuffer.mapIndex k $* + (RingBuffer.trackSkip (Expr.cons bufferSize) (noise seed) + $* skips))) + (\(skips, k, seed) -> + (Arrow.second (RingBuffer.mapIndex k) + <<^ (\((b,_s),buf) -> (b,buf))) + $* + (RingBuffer.trackSkipHold (Expr.cons bufferSize) (noise seed) + $* skips)) + +{- +To do: + +test that trackSkipHold returns False forever after it has returned False once. +-} + + +tests :: [(String, IO QC.Property)] +tests = + ("trackId", checkWithParam trackId) : + ("trackTail", checkWithParam trackTail) : + ("trackDrop", checkWithParam trackDrop) : + ("trackSkip", checkWithParam trackSkip) : + ("trackSkip1", checkWithParam trackSkip1) : + ("trackSkipHold", checkWithParam trackSkipHold) : + [] diff --git a/testsuite/Test/Synthesizer/LLVM/Utility.hs b/testsuite/Test/Synthesizer/LLVM/Utility.hs new file mode 100644 --- /dev/null +++ b/testsuite/Test/Synthesizer/LLVM/Utility.hs @@ -0,0 +1,198 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +module Test.Synthesizer.LLVM.Utility where + +import qualified Synthesizer.LLVM.Causal.Render as CausalRender +import qualified Synthesizer.LLVM.Generator.Render as Render +import qualified Synthesizer.LLVM.Generator.SignalPacked as SigPS +import qualified Synthesizer.LLVM.Generator.Signal as Sig +import qualified Synthesizer.LLVM.Frame.SerialVector.Code as SerialCode +import Synthesizer.LLVM.Causal.Process () + +import qualified Synthesizer.CausalIO.Process as PIO +import qualified Synthesizer.Causal.Class as CausalClass +import qualified Synthesizer.Generic.Signal as SigG +import qualified Synthesizer.State.Signal as SigS +import qualified Synthesizer.Zip as Zip + +import Control.Monad (liftM, liftM2) +import Control.Applicative ((<$>)) + +import qualified Data.StorableVector.Lazy as SVL +import qualified Data.StorableVector as SV +import Data.StorableVector.Lazy (ChunkSize) +import Foreign.Storable (Storable) + +import qualified LLVM.Extra.Multi.Value.Storable as Storable +import qualified LLVM.Extra.Multi.Value as MultiValue + +import qualified Type.Data.Num.Decimal as TypeNum + +import System.Random (Random, randomRs, StdGen, mkStdGen) + +import Data.Tuple.HT (mapPair) + +import qualified Test.QuickCheck as QC + +import qualified System.Unsafe as Unsafe + +import qualified Algebra.RealRing as RealRing +import qualified Algebra.Absolute as Absolute + +import NumericPrelude.Numeric +import NumericPrelude.Base + + +genRandomVectorParam :: QC.Gen (Int, StdGen) +genRandomVectorParam = + liftM2 (,) (QC.choose (1,100)) (mkStdGen <$> QC.arbitrary) + +randomStorableVector :: + (Storable a, Random a) => + (a, a) -> (Int, StdGen) -> SV.Vector a +randomStorableVector range (len, seed) = + fst $ SV.packN len $ randomRs range seed + +randomStorableVectorLoop :: + (Storable a, Random a) => + (a, a) -> (Int, StdGen) -> SVL.Vector a +randomStorableVectorLoop range param = + SVL.cycle $ SVL.fromChunks [randomStorableVector range param] + + +render :: + (Render.RunArg p) => + (Storable.C a, MultiValue.T a ~ al) => + (SVL.Vector a -> sig) -> + (Render.DSLArg p -> Sig.T al) -> IO (ChunkSize -> p -> sig) +render limit sig = + fmap (\func chunkSize -> limit . func chunkSize) $ Render.run sig + +render2 :: + (Render.RunArg p) => + (Storable.C a, MultiValue.T a ~ al) => + (Storable.C b, MultiValue.T b ~ bl) => + ((SVL.Vector a, SVL.Vector b) -> sig) -> + (Render.DSLArg p -> Sig.T (al, bl)) -> IO (ChunkSize -> p -> sig) +render2 limit sig = do + proc <- CausalRender.run (CausalClass.fromSignal . sig) + return $ \(SVL.ChunkSize chunkSize) p -> + limit . mapPair (SVL.fromChunks, SVL.fromChunks) . + unzip . map (\(Zip.Cons a b) -> (a,b)) $ + Unsafe.performIO (PIO.runCont (proc p)) (const []) + (repeat $ SigG.LazySize chunkSize) + + +data CheckSimilarityState a = + CheckSimilarityState a (SVL.Vector a) (SigS.T a) + +instance (Storable a, Ord a, Absolute.C a) => + QC.Testable (CheckSimilarityState a) where + property (CheckSimilarityState tol xs ys) = + QC.property $ + SigS.foldR (&&) True $ + -- dangerous, since shortened signals would be tolerated + SigS.zipWith (\x y -> abs(x-y) < tol) + (SigS.fromStorableSignal xs) ys + +{-# INLINE checkSimilarityState #-} +checkSimilarityState :: + (Render.RunArg p) => + (RealRing.C a, Storable.C a, MultiValue.T a ~ av) => + a -> + (SVL.Vector a -> SVL.Vector a) -> + (Render.DSLArg p -> Sig.T av) -> + (p -> SigS.T a) -> + IO (ChunkSize -> p -> CheckSimilarityState a) +checkSimilarityState tol limit gen0 sig1 = + liftM + (\sig0 chunkSize p -> + CheckSimilarityState tol (sig0 chunkSize p) (sig1 p)) + (render limit gen0) + + +data CheckSimilarity a = + CheckSimilarity a (SVL.Vector a) (SVL.Vector a) + +instance + (Storable a, Ord a, Absolute.C a) => + QC.Testable (CheckSimilarity a) where + property (CheckSimilarity tol xs ys) = + QC.property $ + SigS.foldR (&&) True $ + -- dangerous, since shortened signals would be tolerated + SigS.zipWith (\x y -> abs(x-y) < tol) + (SigS.fromStorableSignal xs) + (SigS.fromStorableSignal ys) + +{-# INLINE checkSimilarity #-} +checkSimilarity :: + (Render.RunArg p) => + (RealRing.C b, Storable.C b, + Storable.C a, MultiValue.T a ~ av) => + b -> + (SVL.Vector a -> SVL.Vector b) -> + (Render.DSLArg p -> Sig.T av) -> + (Render.DSLArg p -> Sig.T av) -> + IO (ChunkSize -> p -> CheckSimilarity b) +checkSimilarity tol limit gen0 gen1 = + liftM2 + (\sig0 sig1 chunkSize p -> + CheckSimilarity tol (sig0 chunkSize p) (sig1 chunkSize p)) + (render limit gen0) + (render limit gen1) + +checkSimilarityPacked :: + (Render.RunArg p) => + Float -> + (SVL.Vector Float -> SVL.Vector Float) -> + (Render.DSLArg p -> Sig.T (MultiValue.T Float)) -> + (Render.DSLArg p -> Sig.T (SerialCode.Value TypeNum.D4 Float)) -> + IO (ChunkSize -> p -> CheckSimilarity Float) +checkSimilarityPacked tol limit scalar vector = + checkSimilarity tol limit scalar (SigPS.unpack . vector) + + +{- | +Instead of testing on equality immediately +we use this interim data type. +This allows us to inspect the signals that are compared. +-} +data CheckEqualityGen a = CheckEqualityGen a a + +type CheckEquality a = CheckEqualityGen (SVL.Vector a) +type CheckEquality2 a b = CheckEqualityGen (SVL.Vector a, SVL.Vector b) + +instance (Eq a) => QC.Testable (CheckEqualityGen a) where + property (CheckEqualityGen x y) = QC.property (x==y) + +checkEquality :: + (Render.RunArg p) => + (Eq a, Storable.C a, MultiValue.T a ~ av) => + (SVL.Vector a -> SVL.Vector a) -> + (Render.DSLArg p -> Sig.T av) -> + (Render.DSLArg p -> Sig.T av) -> + IO (ChunkSize -> p -> CheckEquality a) +checkEquality limit gen0 gen1 = + liftM2 + (\sig0 sig1 chunkSize p -> + CheckEqualityGen (sig0 chunkSize p) (sig1 chunkSize p)) + (render limit gen0) + (render limit gen1) + +checkEquality2 :: + (Render.RunArg p) => + (Eq a, Storable.C a, MultiValue.T a ~ al) => + (Eq b, Storable.C b, MultiValue.T b ~ bl) => + (SVL.Vector a -> SVL.Vector a) -> + (SVL.Vector b -> SVL.Vector b) -> + (Render.DSLArg p -> Sig.T (al,bl)) -> + (Render.DSLArg p -> Sig.T (al,bl)) -> + IO (ChunkSize -> p -> CheckEquality2 a b) +checkEquality2 limitA limitB gen0 gen1 = + liftM2 + (\sig0 sig1 chunkSize p -> + CheckEqualityGen (sig0 chunkSize p) (sig1 chunkSize p)) + (render2 (mapPair (limitA, limitB)) gen0) + (render2 (mapPair (limitA, limitB)) gen1)