packages feed

synthesizer-llvm (empty) → 1.1.0.1

raw patch · 105 files changed

Files

+ Changes.md view
@@ -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.
+ LICENSE view
@@ -0,0 +1,674 @@+                    GNU GENERAL PUBLIC LICENSE+                       Version 3, 29 June 2007++ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.++                            Preamble++  The GNU 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.++    <one line to give the program's name and a brief idea of what it does.>+    Copyright (C) <year>  <name of author>++    This program is free software: you can redistribute it and/or modify+    it under the terms of the GNU General Public License as published by+    the Free Software Foundation, either version 3 of the License, or+    (at your option) any later version.++    This program is distributed in the hope that it will be useful,+    but WITHOUT ANY WARRANTY; without even the implied warranty of+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+    GNU General Public License for more details.++    You should have received a copy of the GNU General Public License+    along with this program.  If not, see <http://www.gnu.org/licenses/>.++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:++    <program>  Copyright (C) <year>  <name of author>+    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+<http://www.gnu.org/licenses/>.++  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+<http://www.gnu.org/philosophy/why-not-lgpl.html>.
+ Setup.lhs view
@@ -0,0 +1,3 @@+#! /usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ alsa/Synthesizer/LLVM/Server.hs view
@@ -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"
+ alsa/Synthesizer/LLVM/Server/ALSA.hs view
@@ -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+      }
+ alsa/Synthesizer/LLVM/Server/CausalPacked/Run.hs view
@@ -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
+ alsa/Synthesizer/LLVM/Server/CausalPacked/Test.hs view
@@ -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
+ alsa/Synthesizer/LLVM/Server/Option.hs view
@@ -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"
+ alsa/Synthesizer/LLVM/Server/Packed/Run.hs view
@@ -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))
+ alsa/Synthesizer/LLVM/Server/Packed/Test.hs view
@@ -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
+ alsa/Synthesizer/LLVM/Server/Scalar/Run.hs view
@@ -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]))
+ alsa/Synthesizer/LLVM/Server/Scalar/Test.hs view
@@ -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+
+ example/Synthesizer/LLVM/ExampleUtility.hs view
@@ -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
+ example/Synthesizer/LLVM/LAC2011.hs view
@@ -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)
+ example/Synthesizer/LLVM/LNdW2011.hs view
@@ -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))
+ example/Synthesizer/LLVM/Test.hs view
@@ -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
+ example/Synthesizer/LLVM/TestALSA.hs view
@@ -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
+ jack/Synthesizer/LLVM/Server/JACK.hs view
@@ -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
+ jack/Synthesizer/LLVM/Server/Option.hs view
@@ -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"
+ render/Synthesizer/LLVM/Server/Option.hs view
@@ -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"
+ render/Synthesizer/LLVM/Server/Render.hs view
@@ -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
+ server/Synthesizer/LLVM/Server/CausalPacked/Arrange.hs view
@@ -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])
+ server/Synthesizer/LLVM/Server/Default.hs view
@@ -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"
+ server/Synthesizer/LLVM/Server/OptionCommon.hs view
@@ -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<n && n<=maxInt) "positive")+      (OP.short 'r' <>+       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<n && n<=maxInt) "positive")+      (OP.short 'b' <>+       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)
+ src/Synthesizer/LLVM/Causal/Controlled.hs view
@@ -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
+ src/Synthesizer/LLVM/Causal/ControlledPacked.hs view
@@ -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)
+ src/Synthesizer/LLVM/Causal/Exponential2.hs view
@@ -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))
+ src/Synthesizer/LLVM/Causal/Functional.hs view
@@ -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)
+ src/Synthesizer/LLVM/Causal/FunctionalPlug.hs view
@@ -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)
+ src/Synthesizer/LLVM/Causal/Helix.hs view
@@ -0,0 +1,622 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE RebindableSyntax #-}+{- |+<http://arxiv.org/abs/0911.5171>+-}+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
+ src/Synthesizer/LLVM/Causal/Parametric.hs view
@@ -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
+ src/Synthesizer/LLVM/Causal/Private.hs view
@@ -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
+ src/Synthesizer/LLVM/Causal/Process.hs view
@@ -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
+ src/Synthesizer/LLVM/Causal/ProcessPacked.hs view
@@ -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
+ src/Synthesizer/LLVM/Causal/ProcessValue.hs view
@@ -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)
+ src/Synthesizer/LLVM/Causal/Render.hs view
@@ -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
+ src/Synthesizer/LLVM/Causal/RingBufferForward.hs view
@@ -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
+ src/Synthesizer/LLVM/Complex.hs view
@@ -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
+ src/Synthesizer/LLVM/ConstantPiece.hs view
@@ -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
+ src/Synthesizer/LLVM/EventIterator.hs view
@@ -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))
+ src/Synthesizer/LLVM/Filter/Allpass.hs view
@@ -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
+ src/Synthesizer/LLVM/Filter/Butterworth.hs view
@@ -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
+ src/Synthesizer/LLVM/Filter/Chebyshev.hs view
@@ -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
+ src/Synthesizer/LLVM/Filter/ComplexFirstOrder.hs view
@@ -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
+ src/Synthesizer/LLVM/Filter/ComplexFirstOrderPacked.hs view
@@ -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)
+ src/Synthesizer/LLVM/Filter/FirstOrder.hs view
@@ -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)
+ src/Synthesizer/LLVM/Filter/Moog.hs view
@@ -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
+ src/Synthesizer/LLVM/Filter/NonRecursive.hs view
@@ -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))
+ src/Synthesizer/LLVM/Filter/SecondOrder.hs view
@@ -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.+-}
+ src/Synthesizer/LLVM/Filter/SecondOrderCascade.hs view
@@ -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, ())
+ src/Synthesizer/LLVM/Filter/SecondOrderPacked.hs view
@@ -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)
+ src/Synthesizer/LLVM/Filter/Universal.hs view
@@ -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.+-}
+ src/Synthesizer/LLVM/Fold.hs view
@@ -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)
+ src/Synthesizer/LLVM/ForeignPtr.hs view
@@ -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
+ src/Synthesizer/LLVM/Frame.hs view
@@ -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)
+ src/Synthesizer/LLVM/Frame/Binary.hs view
@@ -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
+ src/Synthesizer/LLVM/Frame/SerialVector.hs view
@@ -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
+ src/Synthesizer/LLVM/Frame/SerialVector/Class.hs view
@@ -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
+ src/Synthesizer/LLVM/Frame/SerialVector/Code.hs view
@@ -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
+ src/Synthesizer/LLVM/Frame/SerialVector/Plain.hs view
@@ -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
+ src/Synthesizer/LLVM/Frame/Stereo.hs view
@@ -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
+ src/Synthesizer/LLVM/Frame/StereoInterleaved.hs view
@@ -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
+ src/Synthesizer/LLVM/Frame/StereoInterleavedCode.hs view
@@ -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)
+ src/Synthesizer/LLVM/Generator/Core.hs view
@@ -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)
+ src/Synthesizer/LLVM/Generator/Extra.hs view
@@ -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
+ src/Synthesizer/LLVM/Generator/Private.hs view
@@ -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
+ src/Synthesizer/LLVM/Generator/Render.hs view
@@ -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)
+ src/Synthesizer/LLVM/Generator/Signal.hs view
@@ -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)
+ src/Synthesizer/LLVM/Generator/SignalPacked.hs view
@@ -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+<http://perilsofparallel.blogspot.com/2008/09/larrabee-vs-nvidia-mimd-vs-simd.html>+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
+ src/Synthesizer/LLVM/Generator/Source.hs view
@@ -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 ())
+ src/Synthesizer/LLVM/Interpolation.hs view
@@ -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)
+ src/Synthesizer/LLVM/MIDI.hs view
@@ -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))
+ src/Synthesizer/LLVM/MIDI/BendModulation.hs view
@@ -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
+ src/Synthesizer/LLVM/Plug/Input.hs view
@@ -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.+-}
+ src/Synthesizer/LLVM/Plug/Output.hs view
@@ -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)
+ src/Synthesizer/LLVM/Private.hs view
@@ -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, ()))
+ src/Synthesizer/LLVM/Private/Render.hs view
@@ -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
+ src/Synthesizer/LLVM/Random.hs view
@@ -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.+<http://www.softpanorama.org/Algorithms/random_generators.shtml>+-}+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<modulus+      then x+      else x-modulus+++An alternative approach would be to still multiply @let p = factor*seed@ exactly,+then do an approximate division @let q = approxdiv p modulus@,+then compute @p - q*modulus@ and+do a final adjustment in order to fix rounding errors.+The approximate division could be done by a floating point multiplication+or an integer multiplication with some shifting.+But in the end we will need at least the same number of multiplications+as in the approach that is implemented here.+-}+nextVector ::+   (TypeNum.Positive n) =>+   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
+ src/Synthesizer/LLVM/RingBuffer.hs view
@@ -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 ()
+ src/Synthesizer/LLVM/Server/CausalPacked/Common.hs view
@@ -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))
+ src/Synthesizer/LLVM/Server/CausalPacked/Instrument.hs view
@@ -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
+ src/Synthesizer/LLVM/Server/CausalPacked/InstrumentPlug.hs view
@@ -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)
+ src/Synthesizer/LLVM/Server/CausalPacked/Speech.hs view
@@ -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])
+ src/Synthesizer/LLVM/Server/CausalPacked/SpeechExplore.hs view
@@ -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
+ src/Synthesizer/LLVM/Server/Common.hs view
@@ -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
+ src/Synthesizer/LLVM/Server/CommonPacked.hs view
@@ -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
+ src/Synthesizer/LLVM/Server/Packed/Instrument.hs view
@@ -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)
+ src/Synthesizer/LLVM/Server/SampledSound.hs view
@@ -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
+ src/Synthesizer/LLVM/Server/SampledSoundAnalysis.hs view
@@ -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.<b &&& c.<b ==> abs ((a-c) / (a - 2*b + c)) .<= 1+Q.E.D.++Precondition: a>=0, b>=0, c>=0, a<b, c<b:++2*c  <  2*b+c  <  2*b - c+c-a  <  2*b - a - c++=> 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)
+ src/Synthesizer/LLVM/Server/Scalar/Instrument.hs view
@@ -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
+ src/Synthesizer/LLVM/Storable/ChunkIterator.hs view
@@ -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)
+ src/Synthesizer/LLVM/Storable/LazySizeIterator.hs view
@@ -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))
+ src/Synthesizer/LLVM/Storable/Process.hs view
@@ -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)
+ src/Synthesizer/LLVM/Storable/Signal.hs view
@@ -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 []
+ src/Synthesizer/LLVM/Storable/Vector.hs view
@@ -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)
+ src/Synthesizer/LLVM/Value.hs view
@@ -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
+ src/Synthesizer/LLVM/Wave.hs view
@@ -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))
+ synthesizer-llvm.cabal view
@@ -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 <haskell@henning-thielemann.de>+Maintainer:     Henning Thielemann <haskell@henning-thielemann.de>+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
+ testsuite/Test/Main.hs view
@@ -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 +++      []
+ testsuite/Test/Synthesizer/LLVM/Filter.hs view
@@ -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) :+   []
+ testsuite/Test/Synthesizer/LLVM/Generator.hs view
@@ -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)
+ testsuite/Test/Synthesizer/LLVM/Helix.hs view
@@ -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)) :+   []
+ testsuite/Test/Synthesizer/LLVM/Packed.hs view
@@ -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) :+   []
+ testsuite/Test/Synthesizer/LLVM/RingBufferForward.hs view
@@ -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) :+   []
+ testsuite/Test/Synthesizer/LLVM/Utility.hs view
@@ -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)