packages feed

synthesizer-llvm 0.2.0.1 → 0.3

raw patch · 69 files changed

+9678/−3982 lines, 69 filesdep +filepathdep +llvmdep +midi-alsadep −llvm-htdep ~containersdep ~llvm-extradep ~midi

Dependencies added: filepath, llvm, midi-alsa, vault

Dependencies removed: llvm-ht

Dependency ranges changed: containers, llvm-extra, midi, numeric-prelude, synthesizer-alsa, synthesizer-core

Files

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>.
src/Synthesizer/LLVM/ALSA/BendModulation.hs view
@@ -4,119 +4,82 @@ {-# LANGUAGE FlexibleContexts #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {- |-Various LLVM related instances of the BendModulation type.+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.ALSA.BendModulation where--import Synthesizer.PiecewiseConstant.ALSA.MIDI-   (BendModulation(BendModulation), )+module Synthesizer.LLVM.ALSA.BendModulation (+   BM.T(..),+   BM.deflt,+   BM.shift,+   ) where +import qualified Synthesizer.MIDIValue.BendModulation as BM  import qualified LLVM.Extra.Vector as Vector import qualified LLVM.Extra.Class as Class-import qualified LLVM.Extra.Representation as Rep+import qualified LLVM.Extra.Memory as Memory import qualified LLVM.Extra.Control as C import qualified LLVM.Util.Loop as Loop import qualified LLVM.Core as LLVM -import Foreign.Storable (Storable(sizeOf, alignment, peek, poke), )-import Foreign.Storable.Traversable as Store--import qualified Control.Applicative as App-import qualified Data.Foldable as Fold-import qualified Data.Traversable as Trav--import Control.Applicative (Applicative, (<*>), pure, liftA2, )+import Control.Applicative (liftA2, ) import qualified Data.TypeLevel.Num as TypeNum  ---- 'fmap' is lazy which is important for the Store functions-instance Functor BendModulation where-   {-# INLINE fmap #-}-   fmap f ~(BendModulation b m) = BendModulation (f b) (f m)---- useful for defining Additive instance-instance Applicative BendModulation where-   {-# INLINE pure #-}-   pure a = BendModulation a a-   {-# INLINE (<*>) #-}-   ~(BendModulation fb fm) <*> ~(BendModulation b m) =-      BendModulation (fb b) (fm m)--instance Fold.Foldable BendModulation where-   {-# INLINE foldMap #-}-   foldMap = Trav.foldMapDefault---- this allows for kinds of generic programming-instance Trav.Traversable BendModulation where-   {-# INLINE sequenceA #-}-   sequenceA ~(BendModulation b m) =-      liftA2 BendModulation b m---instance (Storable a) => Storable (BendModulation a) where-   {-# INLINE sizeOf #-}-   sizeOf = Store.sizeOf-   {-# INLINE alignment #-}-   alignment = Store.alignment-   {-# INLINE peek #-}-   peek = Store.peekApplicative-   {-# INLINE poke #-}-   poke = Store.poke---instance (Class.Zero a) => Class.Zero (BendModulation a) where+instance (Class.Zero a) => Class.Zero (BM.T a) where    zeroTuple = Class.zeroTuplePointed -instance (LLVM.ValueTuple a) => LLVM.ValueTuple (BendModulation a) where+{-+instance (LLVM.ValueTuple a) => LLVM.ValueTuple (BM.T a) where    buildTuple f = Class.buildTupleTraversable (LLVM.buildTuple f) -instance LLVM.IsTuple a => LLVM.IsTuple (BendModulation a) where+instance LLVM.IsTuple a => LLVM.IsTuple (BM.T a) where    tupleDesc = Class.tupleDescFoldable+-} -instance (LLVM.Undefined a) => LLVM.Undefined (BendModulation a) where+instance (Class.Undefined a) => Class.Undefined (BM.T a) where    undefTuple = Class.undefTuplePointed -instance (C.Select a) => C.Select (BendModulation a) where+instance (C.Select a) => C.Select (BM.T a) where    select = C.selectTraversable +{- instance LLVM.CmpRet a b =>-      LLVM.CmpRet (BendModulation a) (BendModulation b) where+      LLVM.CmpRet (BM.T a) (BM.T b) where+-} -instance LLVM.MakeValueTuple h l =>-      LLVM.MakeValueTuple (BendModulation h) (BendModulation l) where+instance Class.MakeValueTuple h l =>+      Class.MakeValueTuple (BM.T h) (BM.T l) where    valueTupleOf = Class.valueTupleOfFunctor  memory ::-   (Rep.Memory l s, LLVM.IsSized s ss) =>-   Rep.MemoryRecord r (LLVM.Struct (s, (s, ()))) (BendModulation l)+   (Memory.C l s, LLVM.IsSized s ss) =>+   Memory.Record r (LLVM.Struct (s, (s, ()))) (BM.T l) memory =-   liftA2 BendModulation-      (Rep.memoryElement (\(BendModulation b _) -> b) TypeNum.d0)-      (Rep.memoryElement (\(BendModulation _ m) -> m) TypeNum.d1)+   liftA2 BM.Cons+      (Memory.element BM.bend  TypeNum.d0)+      (Memory.element BM.depth TypeNum.d1)  instance-      (Rep.Memory l s, LLVM.IsSized s ss) =>-      Rep.Memory (BendModulation l) (LLVM.Struct (s, (s, ()))) where-   load = Rep.loadRecord memory-   store = Rep.storeRecord memory-   decompose = Rep.decomposeRecord memory-   compose = Rep.composeRecord memory+      (Memory.C l s, LLVM.IsSized s ss) =>+      Memory.C (BM.T l) (LLVM.Struct (s, (s, ()))) where+   load = Memory.loadRecord memory+   store = Memory.storeRecord memory+   decompose = Memory.decomposeRecord memory+   compose = Memory.composeRecord memory  -instance (Loop.Phi a) => Loop.Phi (BendModulation a) where+instance (Loop.Phi a) => Loop.Phi (BM.T a) where    phis = Class.phisTraversable    addPhis = Class.addPhisFoldable   instance (Vector.ShuffleMatch n v) =>-      Vector.ShuffleMatch n (BendModulation v) where+      Vector.ShuffleMatch n (BM.T v) where    shuffleMatch = Vector.shuffleMatchTraversable  instance (Vector.Access n a v) =>-      Vector.Access n (BendModulation a) (BendModulation v) where+      Vector.Access n (BM.T a) (BM.T v) where    insert  = Vector.insertTraversable    extract = Vector.extractTraversable
src/Synthesizer/LLVM/ALSA/MIDI.hs view
@@ -6,65 +6,32 @@ module Synthesizer.LLVM.ALSA.MIDI (    module Synthesizer.LLVM.ALSA.MIDI,    Gen.applyModulation,-   PC.BendModulation(PC.BendModulation),    ) where -import Synthesizer.EventList.ALSA.MIDI-          (Program, Channel, Filter, Note,-           {--           LazyTime, Controller,-           getControllerEvents, getSlice,-           maybePitchBend, maybeChannelPressure,-           -} ) import qualified Synthesizer.Generic.ALSA.MIDI as Gen-import qualified Synthesizer.PiecewiseConstant.ALSA.MIDI as PC--- import qualified Synthesizer.MIDIValue as MV-import Synthesizer.LLVM.ALSA.BendModulation ()+import qualified Synthesizer.LLVM.ALSA.BendModulation as BM  import Synthesizer.LLVM.CausalParameterized.Process (($>), )--- import Synthesizer.LLVM.Parameterized.Signal (($#), ) import qualified Synthesizer.LLVM.Parameterized.SignalPacked as SigPS import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP import qualified Synthesizer.LLVM.Parameterized.Signal as SigP-import qualified Synthesizer.LLVM.Storable.Signal as SigStL import qualified Synthesizer.LLVM.Parameter as Param import qualified Synthesizer.LLVM.Wave as Wave-import qualified Synthesizer.LLVM.Sample as Sample  import qualified LLVM.Extra.ScalarOrVector as SoV import qualified LLVM.Extra.Vector as Vector-import qualified LLVM.Extra.Representation as Rep+import qualified LLVM.Extra.Memory as Memory import qualified LLVM.Extra.Arithmetic as A+import qualified LLVM.Extra.Class as Class import qualified LLVM.Core as LLVM  import qualified Data.TypeLevel.Num as TypeNum -import qualified Synthesizer.Generic.Cut        as CutG--import qualified Synthesizer.Storable.Signal      as SigSt-import qualified Data.StorableVector.Lazy         as SVL--{--import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg--import qualified Data.EventList.Relative.TimeTime  as EventListTT-import qualified Data.EventList.Relative.MixedTime as EventListMT-import qualified Data.EventList.Relative.BodyTime  as EventListBT--}- import Foreign.Storable (Storable, ) -{--import qualified Numeric.NonNegative.Class   as NonNeg-import qualified Numeric.NonNegative.Wrapper as NonNegW-import qualified Numeric.NonNegative.Chunky  as NonNegChunky--}--import qualified Algebra.Transcendental as Trans import qualified Algebra.RealField      as RealField--- import qualified Algebra.Field          as Field import qualified Algebra.Ring           as Ring-import qualified Algebra.Additive       as Additive+-- import qualified Algebra.Additive       as Additive  import Control.Arrow (second, (<<<), (<<^), ) import Control.Monad ({- liftM, -} liftM2, )@@ -77,8 +44,8 @@ {- {-# INLINE piecewiseConstantInit #-} piecewiseConstantInit ::-   (Storable y, LLVM.MakeValueTuple y yl,-    Rep.Memory yl ym, LLVM.IsSized ym ys) =>+   (Storable y, Class.MakeValueTuple y yl,+    Memory.C yl ym, LLVM.IsSized ym ys) =>    y -> EventListTT.T LazyTime y -> SigP.T p yl piecewiseConstantInit initial evs =    SigP.piecewiseConstant $#@@ -88,8 +55,8 @@  {-# INLINE controllerLinear #-} controllerLinear ::-   (Field.C y, Storable y, LLVM.MakeValueTuple y yl,-    Rep.Memory yl ym, LLVM.IsSized ym ys) =>+   (Field.C y, Storable y, Class.MakeValueTuple y yl,+    Memory.C yl ym, LLVM.IsSized ym ys) =>    Channel -> Controller ->    (y,y) -> y ->    Filter (SigP.T p yl)@@ -101,8 +68,8 @@  {-# INLINE controllerExponential #-} controllerExponential ::-   (Trans.C y, Storable y, LLVM.MakeValueTuple y yl,-    Rep.Memory yl ym, LLVM.IsSized ym ys) =>+   (Trans.C y, Storable y, Class.MakeValueTuple y yl,+    Memory.C yl ym, LLVM.IsSized ym ys) =>    Channel -> Controller ->    (y,y) -> y ->    Filter (SigP.T p yl)@@ -119,8 +86,8 @@ -} {-# INLINE pitchBend #-} pitchBend ::-   (Trans.C y, Storable y, LLVM.MakeValueTuple y yl,-    Rep.Memory yl ym, LLVM.IsSized ym ys) =>+   (Trans.C y, Storable y, Class.MakeValueTuple y yl,+    Memory.C yl ym, LLVM.IsSized ym ys) =>    Channel ->    y -> y ->    Filter (SigP.T p yl)@@ -132,8 +99,8 @@  {-# INLINE channelPressure #-} channelPressure ::-   (Trans.C y, Storable y, LLVM.MakeValueTuple y yl,-    Rep.Memory yl ym, LLVM.IsSized ym ys) =>+   (Trans.C y, Storable y, Class.MakeValueTuple y yl,+    Memory.C yl ym, LLVM.IsSized ym ys) =>    Channel ->    y -> y ->    Filter (SigP.T p yl)@@ -148,7 +115,7 @@    (Ring.C a, LLVM.IsConst a,     RealField.C y, Trans.C y,     LLVM.IsConst y, SoV.Fraction y, SoV.Replicate a y,-    Storable y, LLVM.MakeValueTuple y (LLVM.Value y), LLVM.IsSized y ys) =>+    Storable y, Class.MakeValueTuple y (LLVM.Value y), LLVM.IsSized y ys) =>    Channel ->    Int -> y -> y -> y ->    Filter (SigP.T p (LLVM.Value y))@@ -169,11 +136,12 @@  frequencyFromBendModulation ::    (Ring.C a, LLVM.IsConst a,-    Ring.C y, Additive.C y, LLVM.IsConst y, LLVM.IsSized y size,-    Storable y, LLVM.MakeValueTuple y (LLVM.Value y),+    Ring.C y, LLVM.IsConst y,+    Memory.FirstClass y ym, LLVM.IsSized y ysize, LLVM.IsSized ym ymsize,+    Storable y, Class.MakeValueTuple y (LLVM.Value y),     SoV.Fraction y, SoV.Replicate a y) =>    Param.T p y ->-   CausalP.T p (PC.BendModulation (LLVM.Value y)) (LLVM.Value y)+   CausalP.T p (BM.T (LLVM.Value y)) (LLVM.Value y) frequencyFromBendModulation speed =    CausalP.envelope    <<<@@ -181,17 +149,20 @@       (CausalP.mapSimple (A.add (SoV.replicateOf 1)) <<< CausalP.envelope          $> SigP.osciSimple Wave.approxSine2 zero speed)    <<^-   (\(PC.BendModulation b m) -> (b,m))+   (\(BM.Cons b m) -> (b,m))   frequencyFromBendModulationPacked ::    (RealField.C a, LLVM.IsConst a, LLVM.IsFloating a,-    Storable a, LLVM.MakeValueTuple a (LLVM.Value a), LLVM.IsSized a size,-    Vector.Real a, SoV.Replicate a (LLVM.Vector n a), LLVM.IsPowerOf2 n,-    TypeNum.Mul n size vsize, TypeNum.Pos vsize) =>+    Memory.FirstClass a am, LLVM.IsSized a asize, LLVM.IsSized am amsize,+    LLVM.IsPrimitive am,+    Storable a, Class.MakeValueTuple a (LLVM.Value a),+    Vector.Real a, SoV.Replicate a (LLVM.Vector n a), TypeNum.Pos n,+    TypeNum.Mul n asize vsize, TypeNum.Pos vsize,+    TypeNum.Mul n amsize vmsize, TypeNum.Pos vmsize) =>    Param.T p a ->    CausalP.T p-      (PC.BendModulation (LLVM.Value a))+      (BM.T (LLVM.Value a))       (LLVM.Value (LLVM.Vector n a)) frequencyFromBendModulationPacked speed =    CausalP.envelope@@ -201,90 +172,5 @@          $> SigPS.osciSimple Wave.approxSine2 zero speed)    <<<    CausalP.mapSimple-      (\(PC.BendModulation b m) ->+      (\(BM.Cons b m) ->          liftM2 (,) (SoV.replicate b) (SoV.replicate m))----type Instrument y yv = Gen.Instrument y (SigSt.T yv)-type Bank y yv = Gen.Bank y (SigSt.T yv)---{-# INLINE sequenceCore #-}-sequenceCore ::-   (Storable yv, Sample.Additive value,-    LLVM.MakeValueTuple yv value, Rep.Memory value struct) =>-   SigSt.ChunkSize ->-   Channel ->-   Program ->-   Gen.Modulator Note (SigSt.T yv) ->-   Filter (SigSt.T yv)-sequenceCore chunkSize =-   Gen.sequenceCore (SigStL.arrange chunkSize)---{-# INLINE sequence #-}-sequence ::-   (Storable yv, Trans.C y, Sample.Additive value,-    LLVM.MakeValueTuple yv value, Rep.Memory value struct) =>-   SigSt.ChunkSize ->-   Channel ->-   Instrument y yv ->-   Filter (SigSt.T yv)-sequence chunkSize =-   Gen.sequence (SigStL.arrange chunkSize)---{-# INLINE sequenceModulated #-}-sequenceModulated ::-   (CutG.Transform ctrl, CutG.NormalForm ctrl,-    Storable yv, Trans.C y, Sample.Additive value,-    LLVM.MakeValueTuple yv value, Rep.Memory value struct) =>-   SigSt.ChunkSize ->-   ctrl ->-   Channel ->-   (ctrl -> Instrument y yv) ->-   Filter (SigSt.T yv)-sequenceModulated chunkSize =-   Gen.sequenceModulated (SigStL.arrange chunkSize)---{-# INLINE sequenceMultiModulated #-}-sequenceMultiModulated ::-   (Storable yv, Trans.C y, Sample.Additive value,-    LLVM.MakeValueTuple yv value, Rep.Memory value struct) =>-   SigSt.ChunkSize ->-   Channel ->-   instrument ->-   Gen.Modulator (instrument, Note) (Instrument y yv, Note) ->-   Filter (SigSt.T yv)-sequenceMultiModulated chunkSize =-   Gen.sequenceMultiModulated (SigStL.arrange chunkSize)---{-# INLINE sequenceMultiProgram #-}-sequenceMultiProgram ::-   (Storable yv, Trans.C y, Sample.Additive value,-    LLVM.MakeValueTuple yv value, Rep.Memory value struct) =>-   SigSt.ChunkSize ->-   Channel ->-   Program ->-   [Instrument y yv] ->-   Filter (SigSt.T yv)-sequenceMultiProgram chunkSize =-   Gen.sequenceMultiProgram (SigStL.arrange chunkSize)---{-# INLINE sequenceModulatedMultiProgram #-}-sequenceModulatedMultiProgram ::-   (CutG.Transform ctrl, CutG.NormalForm ctrl,-    Storable yv, Trans.C y, Sample.Additive value,-    LLVM.MakeValueTuple yv value, Rep.Memory value struct) =>-   SigSt.ChunkSize ->-   ctrl ->-   Channel ->-   Program ->-   [ctrl -> Instrument y yv] ->-   Filter (SigSt.T yv)-sequenceModulatedMultiProgram chunkSize =-   Gen.sequenceModulatedMultiProgram (SigStL.arrange chunkSize)
+ src/Synthesizer/LLVM/Alloc.hs view
@@ -0,0 +1,108 @@+{- |+Provide allocation functions with correct alignment.+GHC's functions are wrong until at least GHC-6.12.3.+-}+module Synthesizer.LLVM.Alloc (+   malloc, free,+   mallocArray, freeArray,+   F.alloca, F.with,+   ) where+{- reexport alloca and with, since they work correctly in GHC-6.12.3 -}++import qualified Foreign as F+import Foreign.Storable (Storable, sizeOf, alignment, )+import Foreign.Ptr (Ptr, minusPtr, plusPtr, nullPtr, )++import qualified Synthesizer.LLVM.Debug.Storable as Debug+++{-+Copied from storable-record:FixedArray+-}+{-# INLINE roundUp #-}+roundUp :: Int -> Int -> Int+roundUp m x = x + mod (-x) m++{-+{-# INLINE roundDown #-}+roundDown :: Int -> Int -> Int+roundDown m x = x - mod x m+-}++{-# INLINE sizeOfArray #-}+sizeOfArray :: Storable a => Int -> a -> Int+sizeOfArray n x =+   n * roundUp (alignment x) (sizeOf x)++{-+diffClip :: Int -> Int -> Int+-- this implementation also works for unsigned types+diffClip x y = x - min x y+-- diffClip x y = max 0 (x-y)+-}++defaultMallocAlign :: Int+defaultMallocAlign = 8+++seekPointer :: Int -> Ptr a -> Ptr b+seekPointer size ptr =+   alignPointer (alignment nullPtr) (plusPtr ptr size)++alignPointer :: Int -> Ptr a -> Ptr b+alignPointer align ptr =+   plusPtr nullPtr $+   roundUp align $+   minusPtr ptr nullPtr++{- |+> mallocBytes align size+-}+mallocBytes :: Storable a => a -> Int -> IO (Ptr a)+mallocBytes a size =+   Debug.traceMalloc a size =<<+   if mod defaultMallocAlign (alignment a) == 0+     then F.mallocBytes size+     else do+        let align = alignment a+            {- pessimistic but safe -}+            ptrOffset = size + alignment nullPtr+            {- This should be optimal and I think it is also correct,+               but better safe than sorry.+            common = gcd align (alignment nullPtr)+            ptrOffset = roundUp common size + alignment nullPtr - common+            -}+            padSize = align - gcd defaultMallocAlign align+        allocPtr <- F.mallocBytes (padSize + ptrOffset + sizeOf nullPtr)+        let alignedPtr = alignPointer align allocPtr+        F.poke (seekPointer size alignedPtr) allocPtr+        return alignedPtr++peekMock :: Ptr a -> a+peekMock _ = error "auxiliary object for free functions"++freeBytes :: Storable a => a -> Int -> Ptr a -> IO ()+freeBytes a size ptr =+   F.free =<<+   if mod defaultMallocAlign (alignment a) == 0+     then return ptr+     else F.peek $ seekPointer size ptr++malloc :: (Storable a) => IO (Ptr a)+malloc =+   case error "auxiliary object for LLVM.Alloc.malloc" of+      mock -> mallocBytes mock (sizeOf mock)++free :: (Storable a) => Ptr a -> IO ()+free ptr =+   freeBytes (peekMock ptr) (sizeOf (peekMock ptr)) ptr+++mallocArray :: (Storable a) => Int -> IO (Ptr a)+mallocArray n =+   case error "auxiliary object for LLVM.Alloc.mallocArray" of+      mock -> mallocBytes mock (sizeOfArray n mock)++freeArray :: (Storable a) => Int -> Ptr a -> IO ()+freeArray n ptr =+   freeBytes (peekMock ptr) (sizeOfArray n (peekMock ptr)) ptr
src/Synthesizer/LLVM/Causal/Process.hs view
@@ -1,20 +1,19 @@ {-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ForeignFunctionInterface #-} module Synthesizer.LLVM.Causal.Process where  import qualified Synthesizer.LLVM.Simple.Signal as Sig-import qualified LLVM.Extra.Representation as Rep-import qualified Synthesizer.LLVM.Sample as Sample+import qualified Synthesizer.LLVM.Frame as Frame import qualified Synthesizer.LLVM.Execution as Exec++import qualified LLVM.Extra.Arithmetic as A import qualified LLVM.Extra.MaybeContinuation as Maybe+import qualified LLVM.Extra.ForeignPtr as ForeignPtr+import qualified LLVM.Extra.Memory as Memory -- import qualified LLVM.Extra.Control as U+import LLVM.Extra.Class (MakeValueTuple, )  import qualified Data.StorableVector.Lazy as SVL import qualified Data.StorableVector as SV@@ -22,14 +21,15 @@  import qualified Synthesizer.LLVM.Frame.Stereo as Stereo -import LLVM.Core+import LLVM.Core as LLVM import LLVM.Util.Loop (Phi, ) import LLVM.ExecutionEngine (simpleFunction, )  import qualified Control.Arrow    as Arr import qualified Control.Category as Cat-import Control.Arrow ((^<<), (<<<), (<<^), )+import Control.Arrow ((<<<), (^<<), (&&&), ) import Control.Monad (liftM2, liftM3, )+import Control.Applicative (Applicative, pure, (<*>), )  import Data.Word (Word32, ) import Foreign.Storable (Storable, )@@ -38,7 +38,10 @@ import Control.Exception (bracket, ) import System.IO.Unsafe (unsafePerformIO, unsafeInterleaveIO, ) -import Data.Tuple.HT (swap, )+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.Numeric import NumericPrelude.Base hiding (and, map, zip, zipWith, )@@ -46,7 +49,7 @@  data T a b =    forall state packed size ioContext.-      (Rep.Memory state packed, IsSized packed size) =>+      (Memory.C state packed, IsSized packed size) =>       Cons (forall r c.             (Phi c) =>             ioContext ->@@ -62,7 +65,7 @@                -- finalization from IO monad  simple ::-   (Rep.Memory state packed, IsSized packed size) =>+   (Memory.C state packed, IsSized packed size) =>    (forall r c.     (Phi c) =>     a -> state -> Maybe.T r c (b, state)) ->@@ -81,9 +84,9 @@    start    createIOContext deleteIOContext -fromSignal :: Sig.T a -> T () a+fromSignal :: Sig.T b -> T a b fromSignal (Sig.Cons next start createIOContext deleteIOContext) = Cons-   (\ioContext () -> next ioContext)+   (\ioContext _ -> next ioContext)    start    createIOContext deleteIOContext @@ -95,7 +98,7 @@    mapAccum (\a s -> fmap (flip (,) s) $ f a) (return ())  mapAccum ::-   (Rep.Memory state packed, IsSized packed size) =>+   (Memory.C state packed, IsSized packed size) =>    (forall r.     a -> state -> CodeGenFunction r (b, state)) ->    (forall r. CodeGenFunction r state) ->@@ -103,7 +106,12 @@ mapAccum next =    simple (\a s -> Maybe.lift $ next a s) +zipWith ::+   (forall r. a -> b -> CodeGenFunction r c) ->+   T (a,b) c+zipWith f = map (uncurry f) + apply ::    T a b -> Sig.T a -> Sig.T b apply proc sig =@@ -111,11 +119,11 @@  feedFst :: Sig.T a -> T b (a,b) feedFst sig =-   first (fromSignal sig) <<^ (\b -> ((),b))+   fromSignal sig &&& Cat.id  feedSnd :: Sig.T a -> T b (b,a) feedSnd sig =-   swap ^<< feedFst sig+   Cat.id &&& fromSignal sig   applyFst :: T (a,b) c -> Sig.T a -> T b c@@ -165,44 +173,64 @@    first = first  -mix ::-   (IsArithmetic a) =>-   T (Value a, Value a) (Value a)-mix = map (uncurry Sample.mixMono) -mixStereo ::-   (IsArithmetic a) =>-   T (Stereo.T (Value a), Stereo.T (Value a)) (Stereo.T (Value a))-mixStereo = map (uncurry Sample.mixStereo)+instance Functor (T a) where+   fmap = (^<<) +instance Applicative (T a) where+   pure x = Arr.arr (const x)+   f <*> x = uncurry ($) ^<< f&&&x ++instance (A.Additive b) => Additive.C (T a b) where+   zero = pure A.zero+   negate x = map A.neg <<< x+   x + y = zipWith A.add <<< x&&&y+   x - y = zipWith A.sub <<< x&&&y++instance (A.PseudoRing b, A.IntegerConstant b) => Ring.C (T a b) where+   one = pure A.one+   fromInteger n = pure (A.fromInteger' n)+   x * y = zipWith A.mul <<< x&&&y++instance (A.Field b, A.RationalConstant b) => Field.C (T a b) where+   fromRational' x = pure (A.fromRational' $ Ratio.toRational98 x)+   x / y = zipWith A.fdiv <<< x&&&y+++mix ::+   (A.Additive a) =>+   T (a, a) a+mix = zipWith Frame.mix++ envelope ::-   (IsArithmetic a) =>-   T (Value a, Value a) (Value a)-envelope = map (uncurry Sample.amplifyMono)+   (A.PseudoRing a) =>+   T (a, a) a+envelope = zipWith Frame.amplifyMono  envelopeStereo ::-   (IsArithmetic a) =>-   T (Value a, Stereo.T (Value a)) (Stereo.T (Value a))-envelopeStereo = map (uncurry Sample.amplifyStereo)+   (A.PseudoRing a) =>+   T (a, Stereo.T a) (Stereo.T a)+envelopeStereo = zipWith Frame.amplifyStereo  amplify ::    (IsArithmetic a, IsConst a) =>    a -> T (Value a) (Value a) amplify x =-   map (Sample.amplifyMono (valueOf x))+   map (Frame.amplifyMono (valueOf x))  amplifyStereo ::    (IsArithmetic a, IsConst a) =>    a -> T (Stereo.T (Value a)) (Stereo.T (Value a)) amplifyStereo x =-   map (Sample.amplifyStereo (valueOf x))+   map (Frame.amplifyStereo (valueOf x))    applyStorable ::-   (Storable a, MakeValueTuple a valueA, Rep.Memory valueA structA,-    Storable b, MakeValueTuple b valueB, Rep.Memory valueB structB) =>+   (Storable a, MakeValueTuple a valueA, Memory.C valueA structA,+    Storable b, MakeValueTuple b valueB, Memory.C valueB structB) =>    T valueA valueB -> SV.Vector a -> SV.Vector b applyStorable (Cons next start createIOContext deleteIOContext) as =    unsafePerformIO $@@ -211,19 +239,19 @@    SVB.createAndTrim len $ \ bPtr -> do       fill <-          simpleFunction $-         createFunction ExternalLinkage $ \ size alPtr blPtr -> do+         createNamedFunction ExternalLinkage "fillprocessblock" $ \ size alPtr blPtr -> do             s <- start ioContext             (pos,_) <- Maybe.arrayLoop2 size alPtr blPtr s $                   \ aPtri bPtri s0 -> do-               a <- Maybe.lift $ Rep.load aPtri+               a <- Maybe.lift $ Memory.load aPtri                (b,s1) <- next ioContext a s0-               Maybe.lift $ Rep.store b bPtri+               Maybe.lift $ Memory.store b bPtri                return s1             ret (pos :: Value Word32)       fmap (fromIntegral :: Word32 -> Int) $          fill (fromIntegral len)-            (Rep.castStorablePtr aPtr)-            (Rep.castStorablePtr bPtr)+            (Memory.castStorablePtr aPtr)+            (Memory.castStorablePtr bPtr)   foreign import ccall safe "dynamic" derefStartPtr ::@@ -238,9 +266,9 @@   compileChunky ::-   (Rep.Memory aValue aStruct,-    Rep.Memory bValue bStruct,-    Rep.Memory state stateStruct,+   (Memory.C aValue aStruct,+    Memory.C bValue bStruct,+    Memory.C state stateStruct,     IsSized stateStruct stateSize) =>    (forall r.     aValue -> state ->@@ -253,24 +281,23 @@ compileChunky next start =    Exec.compileModule $       liftM3 (,,)-         (createFunction ExternalLinkage $+         (createNamedFunction ExternalLinkage "startprocess" $           do-             -- FIXME: size computation in LLVM currently does not work for structs!-             pptr <- Rep.malloc-             flip Rep.store pptr =<< start+             pptr <- LLVM.malloc+             flip Memory.store pptr =<< start              ret pptr)-         (createFunction ExternalLinkage $-          \ pptr -> Rep.free pptr >> ret ())-         (createFunction ExternalLinkage $+         (createNamedFunction ExternalLinkage "stopprocess" $+          \ pptr -> LLVM.free pptr >> ret ())+         (createNamedFunction ExternalLinkage "fillprocess" $           \ sptr loopLen aPtr bPtr -> do-             sInit <- Rep.load sptr+             sInit <- Memory.load sptr              (pos,sExit) <- Maybe.arrayLoop2 loopLen aPtr bPtr sInit $                    \ aPtri bPtri s0 -> do-                a <- Maybe.lift $ Rep.load aPtri+                a <- Maybe.lift $ Memory.load aPtri                 (b,s1) <- next a s0-                Maybe.lift $ Rep.store b bPtri+                Maybe.lift $ Memory.store b bPtri                 return s1-             Rep.store sExit sptr+             Memory.store sExit sptr              ret (pos :: Value Word32))  @@ -287,8 +314,8 @@ But this way is disallowed for foreign finalizers. -} runStorableChunky ::-   (Storable a, MakeValueTuple a valueA, Rep.Memory valueA structA,-    Storable b, MakeValueTuple b valueB, Rep.Memory valueB structB) =>+   (Storable a, MakeValueTuple a valueA, Memory.C valueA structA,+    Storable b, MakeValueTuple b valueB, Memory.C valueB structB) =>    T valueA valueB -> IO (SVL.Vector a -> SVL.Vector b) runStorableChunky       (Cons next start createIOContext deleteIOContext) = do@@ -302,10 +329,10 @@    that we are after,    but it is unsafe to treat a FunPtr as a Ptr or ForeignPtr.    -}-   ioContextPtr <- Rep.newForeignPtr (deleteIOContext ioContext) False+   ioContextPtr <- ForeignPtr.new (deleteIOContext ioContext) False     return $ \sig -> SVL.fromChunks $ unsafePerformIO $ do-      statePtr <- Rep.newForeignPtrInit stopFunc startFunc+      statePtr <- ForeignPtr.newInit stopFunc startFunc       let go xt =              unsafeInterleaveIO $              case xt of@@ -316,8 +343,8 @@                       SVB.createAndTrim size $                          fmap (fromIntegral :: Word32 -> Int) .                          derefChunkPtr fill sptr (fromIntegral size)-                            (Rep.castStorablePtr aPtr) .-                         Rep.castStorablePtr+                            (Memory.castStorablePtr aPtr) .+                         Memory.castStorablePtr                    touchForeignPtr ioContextPtr                    (if SV.length v > 0                       then fmap (v:)@@ -329,8 +356,8 @@   applyStorableChunky ::-   (Storable a, MakeValueTuple a valueA, Rep.Memory valueA structA,-    Storable b, MakeValueTuple b valueB, Rep.Memory valueB structB) =>+   (Storable a, MakeValueTuple a valueA, Memory.C valueA structA,+    Storable b, MakeValueTuple b valueB, Memory.C valueB structB) =>    T valueA valueB -> SVL.Vector a -> SVL.Vector b applyStorableChunky      (Cons next start createIOContext deleteIOContext) sig =@@ -339,14 +366,14 @@       (startFunc, stopFunc, fill) <-          compileChunky (next ioContext) (start ioContext) -      statePtr <- Rep.newForeignPtrInit stopFunc startFunc+      statePtr <- ForeignPtr.newInit stopFunc startFunc       {-       This is a dummy pointer, that we need for correct finalization.       Concerning the live time the FunPtr 'fill' also has the live time       that we are after,       but it is unsafe to treat a FunPtr as a Ptr or ForeignPtr.       -}-      ioContextPtr <- Rep.newForeignPtr (deleteIOContext ioContext) False+      ioContextPtr <- ForeignPtr.new (deleteIOContext ioContext) False        let go xt =              unsafeInterleaveIO $@@ -358,8 +385,8 @@                       SVB.createAndTrim size $                          fmap (fromIntegral :: Word32 -> Int) .                          derefChunkPtr fill sptr (fromIntegral size)-                            (Rep.castStorablePtr aPtr) .-                         Rep.castStorablePtr+                            (Memory.castStorablePtr aPtr) .+                         Memory.castStorablePtr                    touchForeignPtr ioContextPtr                    (if SV.length v > 0                       then fmap (v:)
src/Synthesizer/LLVM/CausalParameterized/Controlled.hs view
@@ -24,15 +24,16 @@  import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP import qualified Synthesizer.LLVM.Parameterized.Signal as SigP-import qualified LLVM.Extra.Representation as Rep-import qualified LLVM.Extra.Vector as Vector import qualified Synthesizer.LLVM.Parameter as Param -import qualified Synthesizer.LLVM.Simple.Value as Value+import qualified LLVM.Extra.Memory as Memory+import qualified LLVM.Extra.ScalarOrVector as SoV+import qualified LLVM.Extra.Vector as Vector+import qualified LLVM.Extra.Class as Class  import qualified LLVM.Core as LLVM import LLVM.Core-   (Value, Vector, IsArithmetic, IsFloating, IsConst, IsSized, IsFirstClass, )+   (Value, IsFloating, IsConst, IsSized, )  import qualified Synthesizer.LLVM.Frame.Stereo as Stereo @@ -41,9 +42,10 @@  import Foreign.Storable (Storable, ) -import qualified Algebra.Field as Field-import qualified Algebra.Module as Module+-- import qualified Algebra.Field as Field+-- import qualified Algebra.Module as Module import qualified Algebra.Ring as Ring+import qualified Algebra.Additive as Additive   {- |@@ -57,12 +59,11 @@  processCtrlRate ::    (C parameter a b,-    Rep.Memory parameter struct,-    IsSized struct ss,+    Memory.C parameter struct, IsSized struct ss,+    Memory.FirstClass r rm, IsSized r rs, IsSized rm rmsize,     Ring.C r, IsFloating r, Storable r, IsConst r,-    LLVM.MakeValueTuple r (Value r),-    LLVM.CmpRet r Bool,-    IsSized r rs) =>+    Class.MakeValueTuple r (Value r),+    LLVM.CmpRet r Bool) =>    Param.T p r ->    (Param.T p r -> SigP.T p parameter) ->    CausalP.T p a b@@ -77,32 +78,34 @@ -}  instance-   (Ring.C a, Module.C (Value.T a) (Value.T v),-    IsFirstClass a, IsSized a as, IsConst a, IsArithmetic a,-    IsFirstClass v, IsSized v vs, IsConst v, IsArithmetic v) =>+   (SoV.PseudoModule a v, SoV.IntegerConstant a,+    Memory.FirstClass a am, IsSized a as, IsSized am ams,+    Memory.FirstClass v vm, IsSized v vs, IsSized vm vms) =>       C (Filt1.Parameter (Value a))         (Value v) (Filt1.Result (Value v)) where    process = Filt1.causalP  instance-   (Ring.C a, Module.C (Value.T a) (Value.T v),-    IsFirstClass a, IsSized a as, IsConst a, IsArithmetic a,-    IsFirstClass v, IsSized v vs, IsConst v, IsArithmetic v) =>+   (SoV.PseudoModule a v, SoV.IntegerConstant a,+    Memory.FirstClass a am, IsSized a as, IsSized am ams,+    Memory.FirstClass v vm, IsSized v vs, IsSized vm vms) =>       C (Filt2.Parameter (Value a))         (Value v) (Value v) where    process = Filt2.causalP  instance-   (Field.C a, IsConst a, Vector.Arithmetic a,-    IsSized (Vector TypeNum.D4 a) as) =>+   (Vector.Arithmetic a, SoV.RationalConstant a,+    Memory.C (Value (Filt2P.State a)) am, IsSized am size {-,+    Memory.FirstClass a am, IsSized (Vector TypeNum.D4 a) as,+    IsSized am ams, LLVM.IsPrimitive am -}) =>       C (Filt2P.Parameter a)         (Value a) (Value a) where    process = Filt2P.causalP  instance-   (Ring.C a, Module.C (Value.T a) (Value.T v),-    IsFirstClass a, IsSized a as, IsConst a, IsArithmetic a,-    IsFirstClass v, IsSized v vs, IsConst v, IsArithmetic v,+   (SoV.PseudoModule a v, SoV.IntegerConstant a,+    Memory.FirstClass a am, IsSized a as, IsSized am ams,+    Memory.FirstClass v vm, IsSized v vs, IsSized vm vms,     TypeSet.Nat n,     TypeNum.Mul n LLVM.UnknownSize paramSize, TypeSet.Pos paramSize) =>       C (Cascade.ParameterValue n a)@@ -111,17 +114,17 @@   instance-   (Field.C a, Module.C (Value.T a) (Value.T v),-    IsFirstClass a, IsSized a as, IsConst a, IsArithmetic a,-    IsFirstClass v, IsSized v vs, IsConst v, IsArithmetic v) =>+   (SoV.PseudoModule a v, SoV.RationalConstant a,+    Memory.FirstClass a am, IsSized a as, IsSized am ams,+    Memory.FirstClass v vm, IsSized v vs, IsSized vm vms) =>       C (Allpass.Parameter (Value a))         (Value v) (Value v) where    process = Allpass.causalP  instance-   (Field.C a, Module.C (Value.T a) (Value.T v),-    IsFirstClass a, IsSized a as, IsConst a, IsArithmetic a,-    IsFirstClass v, IsSized v vs, IsConst v, IsArithmetic v,+   (SoV.PseudoModule a v, SoV.RationalConstant a,+    Memory.FirstClass a am, IsSized a as, IsSized am ams,+    Memory.FirstClass v vm, IsSized v vs, IsSized vm vms,     TypeNum.Nat n) =>       C (Allpass.CascadeParameter n (Value a))         (Value v) (Value v) where@@ -129,11 +132,12 @@   instance-   (Module.C a v, Module.C (Value.T a) (Value.T v),-    IsFirstClass a, IsSized a as, IsConst a, IsArithmetic a,-    IsFirstClass v, IsSized v vs, IsConst v, IsArithmetic v,-    LLVM.MakeValueTuple a (Value a),-    LLVM.MakeValueTuple v (Value v),+   (SoV.PseudoModule a v, SoV.IntegerConstant a,+    Additive.C v, IsConst v,+    Memory.FirstClass a am, IsSized a as, IsSized am ams,+    Memory.FirstClass v vm, IsSized v vs, IsSized vm vms,+    Class.MakeValueTuple a (Value a),+    Class.MakeValueTuple v (Value v),     Storable v,     TypeSet.Nat n) =>       C (Moog.Parameter n (Value a))@@ -142,22 +146,28 @@   instance-   (Field.C a, Module.C (Value.T a) (Value.T v),-    IsFirstClass a, IsSized a as, IsConst a, IsArithmetic a,-    IsFirstClass v, IsSized v vs, IsConst v, IsArithmetic v) =>+   (SoV.PseudoModule a v, SoV.RationalConstant a,+    Memory.FirstClass a am, IsSized a as, IsSized am ams,+    Memory.FirstClass v vm, IsSized v vs, IsSized vm vms) =>       C (UniFilter.Parameter (Value a))         (Value v) (UniFilter.Result (Value v)) where    process = UniFilter.causalP  instance-   (IsFirstClass a, IsSized a sa, IsConst a, IsFloating a) =>+   (IsFloating a, SoV.RationalConstant a,+    Memory.FirstClass a am, IsSized a sa, IsSized am ams) =>       C (ComplexFilt.Parameter (Value a))         (Stereo.T (Value a)) (Stereo.T (Value a)) where    process = ComplexFilt.causalP  instance-   (IsConst a, Vector.Arithmetic a,+   (Vector.Arithmetic a, IsConst a,+    Memory.C (Value (Filt2P.State a)) am, IsSized am size) =>+{-+   (Memory.FirstClass a am, Vector.Arithmetic a, LLVM.IsPrimitive am,+    IsSized am ams,     IsSized (Vector TypeNum.D4 a) as) =>+-}       C (ComplexFiltPack.Parameter a)         (Stereo.T (Value a)) (Stereo.T (Value a)) where    process = ComplexFiltPack.causalP
src/Synthesizer/LLVM/CausalParameterized/ControlledPacked.hs view
@@ -22,14 +22,16 @@ import qualified Synthesizer.LLVM.CausalParameterized.ProcessPacked as CausalPS import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP import qualified Synthesizer.LLVM.Parameterized.Signal as SigP-import qualified LLVM.Extra.Representation as Rep-import qualified LLVM.Extra.Vector as Vector import qualified Synthesizer.LLVM.Parameter as Param+import qualified LLVM.Extra.Memory as Memory+import qualified LLVM.Extra.ScalarOrVector as SoV+import qualified LLVM.Extra.Vector as Vector+import qualified LLVM.Extra.Class as Class  import qualified LLVM.Core as LLVM import LLVM.Core-   (Value, Vector, IsArithmetic, IsFloating, IsConst, IsSized,-    IsFirstClass, IsPrimitive, IsPowerOf2, )+   (Value, IsArithmetic, IsFloating, IsConst, IsSized,+    Vector, IsPrimitive, )  import qualified Data.TypeLevel.Num      as TypeNum import qualified Data.TypeLevel.Num.Sets as TypeSet@@ -39,8 +41,9 @@ import Control.Arrow ((<<<), first, )  import qualified Algebra.Field as Field-import qualified Algebra.Module as Module-import qualified Algebra.Ring as Ring+-- import qualified Algebra.Module as Module+-- import qualified Algebra.Ring as Ring+import qualified Algebra.Additive as Additive  import NumericPrelude.Numeric import NumericPrelude.Base@@ -58,11 +61,11 @@    (C parameter av bv,     Vector.Access n a av,     Vector.Access n b bv,-    Rep.Memory parameter struct, IsSized struct ss,-    Field.C r, IsFloating r, Storable r, IsConst r,-    LLVM.MakeValueTuple r (Value r),-    LLVM.CmpRet r Bool,-    IsSized r rs) =>+    Memory.C parameter struct, IsSized struct ss,+    Field.C r, Storable r, IsFloating r,+    Memory.FirstClass r rm, IsSized r rs, IsSized rm rms, IsConst r,+    Class.MakeValueTuple r (Value r),+    LLVM.CmpRet r Bool) =>    Param.T p r ->    (Param.T p r -> SigP.T p parameter) ->    CausalP.T p av bv@@ -86,41 +89,48 @@ -}  instance-   (Ring.C a, IsArithmetic a, IsPrimitive a,-    IsFirstClass a, IsConst a, IsSized a as,-    IsPowerOf2 n) =>+   (IsArithmetic a, SoV.IntegerConstant a,+    Memory.FirstClass a am, IsSized a as, IsSized am ams,+    TypeNum.Pos n, IsPrimitive a) =>       C (Filt1.Parameter (Value a))         (Value (Vector n a)) (Filt1.Result (Value (Vector n a))) where    process = Filt1.causalPackedP  instance-   (Ring.C a, IsFirstClass a, IsArithmetic a, IsConst a,-    IsPowerOf2 n, IsPrimitive a, IsSized a as,-    TypeNum.Mul n as vas, TypeNum.Pos vas) =>+   (IsArithmetic a, SoV.IntegerConstant a,+    Memory.FirstClass a am, IsSized a as, IsSized am ams,+    TypeNum.Pos n, IsPrimitive a, IsPrimitive am,+    TypeNum.Mul n as vas, TypeNum.Pos vas,+    TypeNum.Mul n ams vams, TypeNum.Pos vams) =>       C (Filt2.Parameter (Value a))         (Value (Vector n a)) (Value (Vector n a)) where    process = Filt2.causalPackedP  instance-   (Ring.C a, IsPrimitive a, IsSized a as, IsConst a,-    IsArithmetic a, TypeSet.Nat n,+   (IsArithmetic a, SoV.IntegerConstant a, IsPrimitive a, IsPrimitive am,+    Memory.FirstClass a am, IsSized a as, IsSized am ams,+    TypeSet.Nat n,     TypeNum.Mul n LLVM.UnknownSize paramSize, TypeSet.Pos paramSize,-    IsPowerOf2 d, TypeNum.Mul d as vas, TypeSet.Pos vas) =>+    TypeNum.Pos d,+    TypeNum.Mul d as vas, TypeSet.Pos vas,+    TypeNum.Mul d ams vams, TypeSet.Pos vams) =>       C (Cascade.ParameterValue n a)         (Value (Vector d a)) (Value (Vector d a)) where    process = Cascade.causalPackedP   instance-   (Ring.C a, IsFirstClass a, IsArithmetic a, IsConst a,-    IsPowerOf2 n, IsPrimitive a, IsSized a as) =>+   (IsArithmetic a, SoV.IntegerConstant a,+    Memory.FirstClass a am, IsSized a as, IsSized am ams,+    TypeNum.Pos n, IsPrimitive a, IsPrimitive am) =>       C (Allpass.Parameter (Value a))         (Value (Vector n a)) (Value (Vector n a)) where    process = Allpass.causalPackedP  instance-   (Field.C a, IsFirstClass a, IsArithmetic a, IsConst a,-    IsPowerOf2 d, IsPrimitive a, IsSized a as,+   (IsArithmetic a, SoV.RationalConstant a,+    Memory.FirstClass a am, IsSized a as, IsSized am ams,+    TypeNum.Pos d, IsPrimitive a,     TypeNum.Nat n) =>       C (Allpass.CascadeParameter n (Value a))         (Value (Vector d a)) (Value (Vector d a)) where@@ -128,9 +138,10 @@   instance-   (Module.C a a, IsFirstClass a, IsArithmetic a, IsConst a,-    LLVM.MakeValueTuple a (Value a), Storable a,-    IsPowerOf2 d, IsPrimitive a, IsSized a as,+   (SoV.PseudoModule a a, SoV.IntegerConstant a, Additive.C a,+    Memory.FirstClass a am, IsSized a as, IsSized am ams,+    Class.MakeValueTuple a (Value a), Storable a,+    TypeNum.Pos d, IsPrimitive a,     TypeNum.Nat n) =>       C (Moog.Parameter n (Value a))         (Value (Vector d a)) (Value (Vector d a)) where@@ -140,8 +151,9 @@   instance-   (Field.C a, IsFirstClass a, IsArithmetic a, IsConst a,-    IsPowerOf2 d, IsPrimitive a, IsSized a as) =>+   (SoV.PseudoModule a a, SoV.RationalConstant a,+    Memory.FirstClass a am, IsSized a as, IsSized am ams,+    TypeNum.Pos d, IsPrimitive a) =>       C (UniFilter.Parameter (Value a))         (Value (Vector d a)) (UniFilter.Result (Value (Vector d a))) where    process =
+ src/Synthesizer/LLVM/CausalParameterized/Functional.hs view
@@ -0,0 +1,213 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE Rank2Types #-}+module Synthesizer.LLVM.CausalParameterized.Functional (+   T,+   lift,+   ($&), (&|&),+   compile,+   ) where++import qualified Synthesizer.LLVM.CausalParameterized.Process as Causal++import qualified LLVM.Extra.MaybeContinuation as Maybe+import qualified LLVM.Extra.Memory as Memory+import qualified LLVM.Extra.Arithmetic as A++import qualified LLVM.Core as LLVM+import LLVM.Extra.Class (MakeValueTuple, )+import LLVM.Util.Loop (Phi, )+import LLVM.Core (CodeGenFunction, IsSized, )++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 Control.Monad.Trans.State as State+import qualified Control.Monad.Trans.Class as Trans+import Control.Monad.Trans.State (StateT, )++import qualified Data.Vault as Vault+import Data.Vault (Vault, )+import qualified Control.Category as Cat+import Control.Arrow (Arrow, (>>^), (&&&), arr, first, )+import Control.Category (Category, (.), )+import Control.Monad (liftM2, )+import Control.Applicative (Applicative, (<*>), pure, )++import Foreign.Storable (Storable, )++import System.IO.Unsafe (unsafePerformIO, )++import Prelude hiding ((.), )+++newtype T p inp out = Cons (Code p inp out)+++-- | similar to @Causal.T p a b@+data Code p a b =+   forall state packed size ioContext+        startParamTuple startParamValue startParamPacked startParamSize+        nextParamTuple  nextParamValue  nextParamPacked  nextParamSize.+      (Storable startParamTuple,+       Storable nextParamTuple,+       MakeValueTuple startParamTuple startParamValue,+       MakeValueTuple nextParamTuple  nextParamValue,+       Memory.C startParamValue startParamPacked,+       Memory.C nextParamValue  nextParamPacked,+       LLVM.IsSized startParamPacked startParamSize,+       LLVM.IsSized nextParamPacked  nextParamSize,+       Memory.C state packed,+       IsSized packed size) =>+   Code+      (forall r c.+       (Phi c) =>+       nextParamValue ->+       a -> state ->+       StateT Vault (Maybe.T r c) (b, state))+          -- compute next value+      (forall r.+       startParamValue ->+       CodeGenFunction r state)+          -- initial state+      (p -> IO (ioContext, (nextParamTuple, startParamTuple)))+          {- initialization from IO monad+          This will be run within unsafePerformIO,+          so no observable In/Out actions please!+          -}+      (ioContext -> IO ())+          -- finalization from IO monad, also run within unsafePerformIO++++instance Category (Code p) where+   id = arr id+   Code nextB startB createIOContextB deleteIOContextB .+      Code nextA startA createIOContextA deleteIOContextA = Code+         (\(paramA, paramB) a (sa0,sb0) ->+            do (b,sa1) <- nextA paramA a sa0+               (c,sb1) <- nextB paramB b sb0+               return (c, (sa1,sb1)))+         (\(paramA, paramB) ->+            liftM2 (,)+               (startA paramA)+               (startB paramB))+         (\p -> do+            (ca,(nextParamA,startParamA)) <- createIOContextA p+            (cb,(nextParamB,startParamB)) <- createIOContextB p+            return ((ca,cb),+               ((nextParamA,  nextParamB),+                (startParamA, startParamB))))+         (\(ca,cb) ->+            deleteIOContextA ca >>+            deleteIOContextB cb)++instance Arrow (Code p) where+   arr f = Code+      (\ _p a state -> return (f a, state))+      (const $ return ())+      (const $ return ((),((),())))+      (const $ return ())+   first (Code next start create delete) = Code+      (\ioContext (b,d) sa0 ->+         do (c,sa1) <- next ioContext b sa0+            return ((c,d), sa1))+      start create delete+++{-+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 p) where+   id = tagUnique Cat.id+   Cons a . Cons b = tagUnique (a . b)++instance Arrow (T p) where+   arr f = tagUnique $ arr f+   first (Cons a) = tagUnique $ first a+-}++instance Functor (T p inp) where+   fmap f (Cons x) =+      tagUnique $ x >>^ f++instance Applicative (T p inp) where+   pure a = tagUnique $ arr (const a)+   f <*> x = fmap (uncurry ($))  $  f &|& x+++instance (A.Additive b) => Additive.C (T p a b) where+   zero = lift Additive.zero+   negate x = Causal.mapSimple A.neg $& x+   x + y = Causal.zipWithSimple A.add $& x&|&y+   x - y = Causal.zipWithSimple A.sub $& x&|&y++instance (A.PseudoRing b, A.IntegerConstant b) => Ring.C (T p a b) where+   one = pure A.one+   fromInteger n = pure (A.fromInteger' n)+   x * y = Causal.zipWithSimple A.mul $& x&|&y++instance (A.Field b, A.RationalConstant b) => Field.C (T p a b) where+   fromRational' x = pure (A.fromRational' $ Ratio.toRational98 x)+   x / y = Causal.zipWithSimple A.fdiv $& x&|&y+++infixr 0 $&++($&) :: Causal.T p b c -> T p a b -> T p a c+f $& (Cons b) =+   tagUnique $  liftCode f . b+++infixr 3 &|&++(&|&) :: T p a b -> T p a c -> T p a (b,c)+Cons b &|& Cons c =+   tagUnique $  b &&& c+++liftCode :: Causal.T p inp out -> Code p inp out+liftCode (Causal.Cons next start create delete) =+   Code+      (\p a state -> Trans.lift (next p a state))+      start create delete++lift :: Causal.T p inp out -> T p inp out+lift = tagUnique . liftCode++tag :: Vault.Key out -> Code p inp out -> T p inp out+tag key (Code next start create delete) =+   Cons $+   Code+      (\p a s0 -> do+         mb <- State.gets (Vault.lookup key)+         case mb of+            Just b -> return (b,s0)+            Nothing -> do+               bs@(b,_) <- next p a s0+               State.modify (Vault.insert key b)+               return bs)+      start create delete++-- dummy for debugging+_tag :: Vault.Key out -> Code p inp out -> T p inp out+_tag _ = Cons++tagUnique :: Code p inp out -> T p inp out+tagUnique code =+   unsafePerformIO $+   fmap (flip tag code) Vault.newKey++initialize :: Code p inp out -> Causal.T p inp out+initialize (Code next start create delete) =+   Causal.Cons+      (\p a state -> State.evalStateT (next p a state) Vault.empty)+      start create delete++compile :: T p inp out -> Causal.T p inp out+compile (Cons code) = initialize code
src/Synthesizer/LLVM/CausalParameterized/Process.hs view
@@ -5,20 +5,25 @@ {-# LANGUAGE ForeignFunctionInterface #-} module Synthesizer.LLVM.CausalParameterized.Process (    T(Cons), simple,-   mapAccum, map, mapSimple,+   fromSignal, toSignal,+   mapAccum, map, mapSimple, zipWithSimple,    apply, compose, first,    feedFst, feedSnd,-   take, integrate,+   loop, take, takeWhile, integrate,    module Synthesizer.LLVM.CausalParameterized.Process    ) where  import Synthesizer.LLVM.CausalParameterized.ProcessPrivate+import qualified Synthesizer.LLVM.Plug.Input as PIn+import qualified Synthesizer.LLVM.Plug.Output as POut import qualified Synthesizer.LLVM.Parameter as Param+import qualified Synthesizer.CausalIO.Process as PIO  import Synthesizer.LLVM.Parameterized.Signal (($#), )+import qualified Synthesizer.LLVM.RingBuffer as RingBuffer import qualified Synthesizer.LLVM.Parameterized.Signal as Sig import qualified Synthesizer.LLVM.Frame.Stereo as Stereo-import qualified Synthesizer.LLVM.Sample as Sample+import qualified Synthesizer.LLVM.Frame as Frame import qualified Synthesizer.LLVM.Execution as Exec import qualified Synthesizer.LLVM.Simple.Value as Value @@ -26,27 +31,31 @@ import qualified Data.StorableVector as SV import qualified Data.StorableVector.Base as SVB +import qualified Synthesizer.Generic.Cut as Cut import qualified Synthesizer.Plain.Modifier as Modifier  import qualified LLVM.Extra.ScalarOrVector as SoV import qualified LLVM.Extra.Vector as Vector import qualified LLVM.Extra.MaybeContinuation as Maybe-import qualified LLVM.Extra.Representation as Rep+import qualified LLVM.Extra.ForeignPtr as ForeignPtr+import qualified LLVM.Extra.Memory as Memory import qualified LLVM.Extra.Control as C import qualified LLVM.Extra.Class as Class import qualified LLVM.Extra.Arithmetic as A+import LLVM.Extra.Class (MakeValueTuple, Undefined, undefTuple, ) +import LLVM.Util.Loop (Phi, ) import LLVM.Core as LLVM import Data.TypeLevel.Num (D2, )+import Data.TypeLevel.Num.Ops ((:<:), ) import qualified Data.TypeLevel.Num as TypeNum-import qualified Data.TypeLevel.Num.Sets as Sets  import qualified Control.Monad.HT as M import qualified Control.Arrow    as Arr import qualified Control.Category as Cat import Control.Monad.Trans.State (runState, state, evalState, )-import Control.Arrow ((<<<), (>>>), (&&&), )-import Control.Monad (liftM2, liftM3, )+import Control.Arrow (arr, (<<<), (>>>), (&&&), )+import Control.Monad (liftM2, liftM3, when, ) import Control.Applicative (liftA2, )  import System.Random (Random, RandomGen, randomR, )@@ -57,11 +66,12 @@ import qualified Algebra.Additive as Additive  import Data.Function.HT (nest, )+import Data.Tuple.HT (swap, ) import Data.Word (Word32, ) import Foreign.Storable.Tuple () import Foreign.Storable (Storable, poke, )-import qualified Foreign.Marshal.Array as Array-import qualified Foreign.Marshal.Alloc as Alloc+import qualified Synthesizer.LLVM.Alloc as Alloc+import qualified Foreign.Marshal.Utils as AllocUtil import Foreign.ForeignPtr (withForeignPtr, ) import Foreign.Ptr (FunPtr, ) import Control.Exception (bracket, )@@ -69,8 +79,11 @@  import qualified Data.List as List +import qualified Synthesizer.LLVM.Debug.Storable as DebugSt+import qualified Synthesizer.LLVM.Debug.Counter as DebugCnt+ import NumericPrelude.Numeric-import NumericPrelude.Base hiding (and, iterate, map, zip, zipWith, take, )+import NumericPrelude.Base hiding (and, iterate, map, zip, zipWith, take, takeWhile, )   infixl 0 $<, $>, $*, $<#, $>#, $*#@@ -98,60 +111,32 @@ -} ($*#) ::    (Storable ah, MakeValueTuple ah a,-    Rep.Memory a am, IsSized am as) =>+    Memory.C a am, IsSized am as) =>    T p a b -> ah -> Sig.T p b proc $*# x = proc $* (Sig.constant $# x)  ($<#) ::    (Storable ah, MakeValueTuple ah a,-    Rep.Memory a am, IsSized am as) =>+    Memory.C a am, IsSized am as) =>    T p (a,b) c -> ah -> T p b c proc $<# x = proc $< (Sig.constant $# x)  ($>#) ::    (Storable bh, MakeValueTuple bh b,-    Rep.Memory b bm, IsSized bm bs) =>+    Memory.C b bm, IsSized bm bs) =>    T p (a,b) c -> bh -> T p a c proc $># x = proc $> (Sig.constant $# x)   mapAccumSimple ::-   (Rep.Memory s struct, IsSized struct sa) =>+   (Memory.C s struct, IsSized struct sa) =>    (forall r. a -> s -> CodeGenFunction r (b,s)) ->    (forall r. CodeGenFunction r s) ->    T p a b mapAccumSimple f s =    mapAccum (\() -> f) (\() -> s) (return ()) (return ()) -{- |-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 ::-   (Storable ch,-    MakeValueTuple ch c,-    Rep.Memory c cp,-    IsSized cp cs) =>-   Param.T p ch -> T p (a,c) (b,c) -> T p a b-loop initial (Cons next start createIOContext deleteIOContext) =-   Cons-      (\p a0 (c0,s0) -> do-         ((b1,c1), s1) <- next p (a0,c0) s0-         return (b1,(c1,s1)))-      (\(i,p) -> fmap ((,) (Param.value initial i)) $ start p)-      (\p -> do-         (ctx,(nextParam,startParam)) <- createIOContext p-         return (ctx,-            (nextParam, (Param.get initial p, startParam))))-      deleteIOContext-- -- cf. synthesizer-core:Causal.Process, can be defined for any arrow {-# INLINE replicateControlled #-} replicateControlled :: Int -> T p (c,x) x -> T p (c,x) x@@ -165,7 +150,7 @@ feedbackControlled ::    (Storable ch,     MakeValueTuple ch c,-    Rep.Memory c cp,+    Memory.C c cp,     IsSized cp cs) =>    Param.T p ch ->    T p ((ctrl,a),c) b -> T p (ctrl,b) c -> T p (ctrl,a) b@@ -176,7 +161,7 @@  fromModifier ::    (Value.Flatten ah al, Value.Flatten bh bl, Value.Flatten ch cl,-    Value.Flatten sh sl, Rep.Memory sl sp, IsSized sp ss) =>+    Value.Flatten sh sl, Memory.C sl sp, IsSized sp ss) =>    Modifier.Simple sh ch ah bh -> T p (cl,al) bl fromModifier (Modifier.Simple initial step) =    mapAccumSimple@@ -215,9 +200,9 @@    T p (Value (Vector D2 a)) (Value (Vector D2 b)) ->    T p (Stereo.T (Value a)) (Stereo.T (Value b)) stereoFromVector proc =-   mapSimple Sample.stereoFromVector <<<+   mapSimple Frame.stereoFromVector <<<    proc <<<-   mapSimple Sample.vectorFromStereo+   mapSimple Frame.vectorFromStereo   vectorize ::@@ -237,7 +222,7 @@ vectorizeSize n proc =    foldl       (\acc i -> replaceChannel i proc acc)-      (Arr.arr (const $ LLVM.undefTuple)) $+      (Arr.arr (const $ undefTuple)) $    List.take (TypeNum.toInt n) [0 ..]  {- |@@ -249,69 +234,92 @@    Int -> T p a b -> T p va vb -> T p va vb replaceChannel i channel proc =    let li = valueOf $ fromIntegral i-   in  mapSimple (uncurry (Vector.insert li)) <<<+   in  zipWithSimple (Vector.insert li) <<<           (channel <<< mapSimple (Vector.extract li)) &&&           proc +{- |+Read the i-th element from each array.+-}+arrayElement ::+   (IsFirstClass a, LLVM.GetValue (LLVM.Array dim a) index a,+    TypeNum.Nat index, TypeNum.Nat dim, index :<: dim) =>+   index -> T p (Value (LLVM.Array dim a)) (Value a)+arrayElement i =+   mapSimple (\array -> LLVM.extractvalue array i) -zipWithSimple ::-   (forall r. a -> b -> CodeGenFunction r c) ->-   T p (a,b) c-zipWithSimple f =-   mapSimple (uncurry f)+{- |+Read the i-th element from an aggregate type.+-}+element ::+   (IsFirstClass a, LLVM.GetValue agg index a) =>+   index -> T p (Value agg) (Value a)+element i =+   mapSimple (\array -> LLVM.extractvalue array i) ++{- |+You may also use '(+)'.+-} mix ::-   (IsArithmetic a) =>-   T p (Value a, Value a) (Value a)+   (A.Additive a) =>+   T p (a, a) a mix =-   zipWithSimple Sample.mixMono--mixStereo ::-   (IsArithmetic a) =>-   T p (Stereo.T (Value a), Stereo.T (Value a)) (Stereo.T (Value a))-mixStereo =-   zipWithSimple Sample.mixStereo+   zipWithSimple Frame.mix  +{- |+You may also use '(+)' and a 'Sig.constant' signal or a number literal.+-} raise ::    (IsArithmetic a, Storable a,+    Memory.FirstClass a am, IsSized am amsize,     MakeValueTuple a (Value a), IsSized a size) =>    Param.T p a -> T p (Value a) (Value a) raise =-   map Sample.mixMono+   map Frame.mix  +{- |+You may also use '(*)'.+-} envelope ::-   (IsArithmetic a) =>-   T p (Value a, Value a) (Value a)+   (A.PseudoRing a) =>+   T p (a, a) a envelope =-   zipWithSimple Sample.amplifyMono+   zipWithSimple Frame.amplifyMono  envelopeStereo ::-   (IsArithmetic a) =>-   T p (Value a, Stereo.T (Value a)) (Stereo.T (Value a))+   (A.PseudoRing a) =>+   T p (a, Stereo.T a) (Stereo.T a) envelopeStereo =-   zipWithSimple Sample.amplifyStereo+   zipWithSimple Frame.amplifyStereo +{- |+You may also use '(*)' and a 'Sig.constant' signal or a number literal.+-} amplify ::    (IsArithmetic a, Storable a,-    MakeValueTuple a (Value a), IsFirstClass a, IsSized a size) =>+    Memory.FirstClass a am, IsSized am amsize,+    MakeValueTuple a (Value a), IsSized a size) =>    Param.T p a -> T p (Value a) (Value a) amplify =-   map Sample.amplifyMono+   map Frame.amplifyMono  amplifyStereo ::    (IsArithmetic a, Storable a,-    MakeValueTuple a (Value a), IsFirstClass a, IsSized a size) =>+    Memory.FirstClass a am, IsSized am amsize,+    MakeValueTuple a (Value a), IsSized a size) =>    Param.T p a -> T p (Stereo.T (Value a)) (Stereo.T (Value a)) amplifyStereo =-   map Sample.amplifyStereo+   map Frame.amplifyStereo    mapLinear ::    (IsArithmetic a, Storable a,-    MakeValueTuple a (Value a), IsFirstClass a, IsSized a size) =>+    Memory.FirstClass a am, IsSized am amsize,+    MakeValueTuple a (Value a), IsSized a size) =>    Param.T p a -> Param.T p a -> T p (Value a) (Value a) mapLinear depth center =    map@@ -320,7 +328,8 @@  mapExponential ::    (Trans.C a, IsFloating a, IsConst a, Storable a,-    MakeValueTuple a (Value a), IsFirstClass a, IsSized a size) =>+    Memory.FirstClass a am, IsSized am amsize,+    MakeValueTuple a (Value a), IsSized a size) =>    Param.T p a -> Param.T p a -> T p (Value a) (Value a) mapExponential depth center =    map@@ -339,11 +348,12 @@ that shall be used both for an oscillator and a frequency filter. -} quantizeLift ::-   (Rep.Memory b struct, IsSized struct size,+   (Memory.C b struct, IsSized struct size,     Ring.C c,     IsFloating c, CmpRet c Bool,     Storable c, MakeValueTuple c (Value c),-    IsConst c, IsFirstClass c, IsSized c sc) =>+    Memory.FirstClass c cm, IsSized cm cmsize,+    IsConst c, IsSized c sc) =>    Param.T p c ->    T p a b ->    T p a b@@ -354,12 +364,12 @@          Maybe.fromBool $          C.whileLoop             (valueOf True, bState0)-            (\(cont1, (_, ss1)) ->-               and cont1 =<< A.fcmp FPOLE ss1 (value LLVM.zero))-            (\(_,((_,state01), ss1)) ->+            (\(cont1, (_, ss0)) ->+               and cont1 =<< A.fcmp FPOLE ss0 (value LLVM.zero))+            (\(_,((_,state01), ss0)) ->                Maybe.toBool $ liftM2 (,)                   (next parameter a0 state01)-                  (Maybe.lift $ A.add ss1 (Param.value k kl)))+                  (Maybe.lift $ A.add ss0 (Param.value k kl)))        ss2 <- Maybe.lift $ A.sub ss1 (valueOf Ring.one)       return (b1, ((b1,state1),ss2)))@@ -378,36 +388,36 @@ thus we use 'SoV.addToPhase' which supports that. -} osciCore ::-   (IsFirstClass t, IsSized t size,-    SoV.Fraction t, IsConst t,-    Additive.C t) =>+   (Memory.FirstClass t tm, IsSized t size, IsSized tm tmsize,+    IsConst t, SoV.Fraction t, Additive.C t) =>    T p (Value t, Value t) (Value t) osciCore =-   mapSimple (uncurry SoV.addToPhase) <<<+   zipWithSimple SoV.addToPhase <<<    Arr.second       (mapAccumSimple          (\a s -> do             b <- SoV.incPhase a s             return (s,b))          (return (valueOf Additive.zero)))+-- this is in principle equivalent to mapAccumSimple,+-- but needs more type constraints+--      (loop Additive.zero (arr snd &&& zipWithSimple SoV.incPhase))  osciSimple ::-   (IsFirstClass t, IsSized t size,-    SoV.Fraction t, IsConst t,-    Additive.C t) =>+   (Memory.FirstClass t tm, IsSized t size, IsSized tm tmsize,+    IsConst t, SoV.Fraction t, Additive.C t) =>    (forall r. Value t -> CodeGenFunction r y) ->    T p (Value t, Value t) y osciSimple wave =    mapSimple wave <<< osciCore  shapeModOsci ::-   (IsFirstClass t, IsSized t size,-    SoV.Fraction t, IsConst t,-    Additive.C t) =>+   (Memory.FirstClass t tm, IsSized t size, IsSized tm tmsize,+    IsConst t, SoV.Fraction t, Additive.C t) =>    (forall r. c -> Value t -> CodeGenFunction r y) ->    T p (c, (Value t, Value t)) y shapeModOsci wave =-   mapSimple (uncurry wave) <<< Arr.second osciCore+   zipWithSimple wave <<< Arr.second osciCore   @@ -419,44 +429,14 @@ delay ::    (Storable a,     MakeValueTuple a al,-    Rep.Memory al ap,+    Memory.C al ap,     IsSized ap as) =>    Param.T p a -> Param.T p Int -> T p al al delay initial time =-   let time32 = fmap (fromIntegral :: Int -> Word32) time in-   Cons-      (\(size,ptr) a0 (remain0,ptri0) -> Maybe.lift $ do-         Rep.store a0 ptri0-         cont <- A.icmp IntNE remain0 (valueOf 0)-         (remain1,ptri1) <--            C.ifThenSelect cont (Param.value time32 size, ptr)-               (liftM2 (,)-                  (A.dec remain0)-                  (A.advanceArrayElementPtr ptri0))-         a1 <- Rep.load ptri1-         return (a1, (remain1,ptri1)))-      (\(x, (size,ptr)) -> do-         size1 <- A.inc (Param.value time32 size)-         -- cf. LLVM.Storable.Signal.fill-         C.arrayLoop size1 ptr () $ \ ptri () ->-            Rep.store (Param.value initial x) ptri >> return ()-         return (size,ptr))-      (\p -> do-         let size = Param.get time p-             x = Param.get initial p-         {--         We allocate one element more than necessary-         in order to simplify handling of delay time zero-         -}-         ptr <- Array.mallocArray (size+1)-         let param =-               (fromIntegral size :: Word32,-                Rep.castStorablePtr (ptrAsTypeOf ptr x))-         return (ptr, (param, (x, param))))-      Alloc.free+   mapSimple RingBuffer.oldest+   <<<+   RingBuffer.track initial time -ptrAsTypeOf :: Ptr a -> a -> Ptr a-ptrAsTypeOf p _ = p  {- | Delay by one sample.@@ -474,26 +454,30 @@ delay1 ::    (Storable a,     MakeValueTuple a al,-    Rep.Memory al ap,+    Memory.C al ap,     IsSized ap as) =>    Param.T p a -> T p al al-delay1 initial = simple-   (\() a s -> return (s,a))-   return-   (return ())-   initial+delay1 initial =+   loop initial (arr swap)  +differentiate ::+   (A.Additive al,+    Storable a,+    MakeValueTuple a al,+    Memory.C al ap,+    IsSized ap as) =>+   Param.T p a -> T p al al+differentiate initial =+   Cat.id - delay1 initial+ {- | Delay time must be greater than zero! -} comb ::-   (Ring.C a,-    Storable a,-    IsArithmetic a,-    MakeValueTuple a (Value a),-    IsFirstClass a,-    IsSized a as) =>+   (Ring.C a, Storable a,+    IsArithmetic a, MakeValueTuple a (Value a),+    Memory.FirstClass a am, IsSized a asize, IsSized am amsize) =>    Param.T p a -> Param.T p Int ->    T p (Value a) (Value a) comb gain time =@@ -502,29 +486,33 @@           (delay z (subtract 1 time) >>> amplify gain)))  combStereo ::-   (Ring.C a,-    Storable a,-    IsArithmetic a,-    MakeValueTuple a (Value a),-    IsFirstClass a,-    IsSized a as) =>+   (Ring.C a, Storable a,+    IsArithmetic a, MakeValueTuple a (Value a),+    Memory.FirstClass a am, IsSized a asize, IsSized am amsize) =>    Param.T p a -> Param.T p Int ->    T p (Stereo.T (Value a)) (Stereo.T (Value a)) combStereo gain time =    let z = Additive.zero `asTypeOf` (liftA2 Stereo.cons gain gain)-   in  loop z (mixStereo >>> (Cat.id &&&+   in  loop z (mix >>> (Cat.id &&&           (delay z (subtract 1 time) >>> amplifyStereo gain))) +{- |+Example: apply a stereo reverb to a mono sound.++> traverse+>    (\seed -> reverb (Random.mkStdGen seed) 16 (0.92,0.98) (200,1000))+>    (Stereo.cons 42 23)+-} reverb ::-   (Field.C a, Random a,-    Storable a, IsArithmetic a,-    MakeValueTuple a (Value a), IsFirstClass a, IsSized a as,+   (Field.C a, Random a, Storable a,+    IsArithmetic a, MakeValueTuple a (Value a),+    Memory.FirstClass a am, IsSized a asize, IsSized am amsize,     RandomGen g) =>    g -> Int -> (a,a) -> (Int,Int) ->    T p (Value a) (Value a) reverb rnd num gainRange timeRange =    amplify (return (recip (fromIntegral num))) <<<-   (foldl (\proc chan -> mix <<< (proc &&& chan)) Cat.id $+   (foldl (+) Cat.id $     List.take num $     List.map (\(g,t) -> comb $# g $# t) $     flip evalState rnd $@@ -561,7 +549,7 @@ -} pipeline ::    (Vector.Access n a v, Class.Zero v,-    Rep.Memory v vp, IsSized vp s) =>+    Memory.C v vp, IsSized vp s) =>    T p v v -> T p a a pipeline (Cons next start createIOContext deleteIOContext) = Cons    (\param a0 (v0,s0) -> do@@ -595,11 +583,12 @@ The shrinking factor must be non-negative. -} frequencyModulationLinear ::-   (-- Rep.Memory a struct, IsSized struct size,+   (-- Memory.C a struct, IsSized struct size,     Ring.C a,     IsFloating a, CmpRet a Bool,     Storable a, MakeValueTuple a (Value a),-    IsConst a, IsFirstClass a, IsSized a sa) =>+    Memory.FirstClass a am, IsSized a asize, IsSized am amsize,+    IsConst a) =>    Sig.T p (Value a) -> T p (Value a) (Value a) frequencyModulationLinear       (Sig.Cons next start createIOContext deleteIOContext) =@@ -642,7 +631,7 @@ -} trigger ::    (Storable a, MakeValueTuple a al, C.Select al,-    Rep.Memory al as, IsSized as asize) =>+    Memory.C al as, IsSized as asize) =>    Param.T p a ->    Sig.T p al ->    T p (Value Bool) al@@ -680,23 +669,23 @@    Exec.Importer (Ptr param -> Word32 -> Ptr a -> Ptr b -> IO Word32)  runStorable ::-   (Storable a, MakeValueTuple a valueA, Rep.Memory valueA structA,-    Storable b, MakeValueTuple b valueB, Rep.Memory valueB structB) =>+   (Storable a, MakeValueTuple a valueA, Memory.C valueA structA,+    Storable b, MakeValueTuple b valueB, Memory.C valueB structB) =>    T p valueA valueB ->    IO (p -> SV.Vector a -> SV.Vector b) runStorable (Cons next start createIOContext deleteIOContext) = do    fill <-       fmap derefFillPtr $       Exec.compileModule $-      createFunction ExternalLinkage $+      createNamedFunction ExternalLinkage "fillprocessblock" $       \paramPtr size alPtr blPtr -> do-         (nextParam,startParam) <- Rep.load paramPtr+         (nextParam,startParam) <- Memory.load paramPtr          s <- start startParam          (pos,_) <- Maybe.arrayLoop2 size alPtr blPtr s $                \ aPtri bPtri s0 -> do-            a <- Maybe.lift $ Rep.load aPtri+            a <- Maybe.lift $ Memory.load aPtri             (b,s1) <- next nextParam a s0-            Maybe.lift $ Rep.store b bPtri+            Maybe.lift $ Memory.store b bPtri             return s1          ret (pos :: Value Word32) @@ -706,17 +695,16 @@       \ (_,params) ->          SVB.withStartPtr as $ \ aPtr len ->          SVB.createAndTrim len $ \ bPtr ->-         Alloc.alloca $ \paramPtr ->-            poke paramPtr params >>-            (fmap fromIntegral $-               fill (Rep.castStorablePtr paramPtr)-                  (fromIntegral len)-                  (Rep.castStorablePtr aPtr)-                  (Rep.castStorablePtr bPtr))+         Alloc.with params $ \paramPtr ->+         fmap fromIntegral $+            fill (Memory.castStorablePtr paramPtr)+               (fromIntegral len)+               (Memory.castStorablePtr aPtr)+               (Memory.castStorablePtr bPtr)  applyStorable ::-   (Storable a, MakeValueTuple a valueA, Rep.Memory valueA structA,-    Storable b, MakeValueTuple b valueB, Rep.Memory valueB structB) =>+   (Storable a, MakeValueTuple a valueA, Memory.C valueA structA,+    Storable b, MakeValueTuple b valueB, Memory.C valueB structB) =>    T p valueA valueB ->    p -> SV.Vector a -> SV.Vector b applyStorable gen = unsafePerformIO $ runStorable gen@@ -729,12 +717,12 @@   compileChunky ::-   (Rep.Memory valueA structA,-    Rep.Memory valueB structB,-    Rep.Memory state stateStruct,+   (Memory.C valueA structA,+    Memory.C valueB structB,+    Memory.C state stateStruct,     IsSized    stateStruct stateSize,-    Rep.Memory startParamValue startParamStruct,-    Rep.Memory nextParamValue  nextParamStruct,+    Memory.C startParamValue startParamStruct,+    Memory.C nextParamValue  nextParamStruct,     IsSized    startParamStruct startParamSize,     IsSized    nextParamStruct  nextParamSize) =>    (forall r.@@ -751,67 +739,117 @@ compileChunky next start =    Exec.compileModule $       liftM3 (,,)-         (createFunction ExternalLinkage $+         (createNamedFunction ExternalLinkage "startprocess" $           \paramPtr -> do-             -- FIXME: size computation in LLVM currently does not work for structs!-             pptr <- Rep.malloc-             flip Rep.store pptr =<< start =<< Rep.load paramPtr+             pptr <- LLVM.malloc+             flip Memory.store pptr =<< start =<< Memory.load paramPtr              ret pptr)-         (createFunction ExternalLinkage $-          \ pptr -> Rep.free pptr >> ret ())-         (createFunction ExternalLinkage $+         (createNamedFunction ExternalLinkage "stopprocess" $+          \ pptr -> LLVM.free pptr >> ret ())+         (createNamedFunction ExternalLinkage "fillprocess" $           \ paramPtr sptr loopLen aPtr bPtr -> do-             param <- Rep.load paramPtr-             sInit <- Rep.load sptr+             param <- Memory.load paramPtr+             sInit <- Memory.load sptr              (pos,sExit) <- Maybe.arrayLoop2 loopLen aPtr bPtr sInit $                    \ aPtri bPtri s0 -> do-                a <- Maybe.lift $ Rep.load aPtri+                a <- Maybe.lift $ Memory.load aPtri                 (b,s1) <- next param a s0-                Maybe.lift $ Rep.store b bPtri+                Maybe.lift $ Memory.store b bPtri                 return s1-             Rep.store sExit sptr+             Memory.store sExit sptr              ret (pos :: Value Word32))  +foreign import ccall safe "dynamic" derefStartParamPtr ::+   Exec.Importer (Ptr startParamStruct -> IO (Ptr stateStruct))++foreign import ccall safe "dynamic" derefStopPtr ::+   Exec.Importer (Ptr stateStruct -> IO ())++compilePlugged ::+   (Memory.C state stateStruct,+    IsSized    stateStruct stateSize,+    Memory.C startParamValue startParamStruct,+    Memory.C nextParamValue  nextParamStruct,+    IsSized    startParamStruct startParamSize,+    IsSized    nextParamStruct  nextParamSize,+    Undefined stateIn,  Phi stateIn,+    Undefined stateOut, Phi stateOut,+    Memory.C paramValueIn  paramStructIn,+    Memory.C paramValueOut paramStructOut,+    IsSized    paramStructIn  paramSizeIn,+    IsSized    paramStructOut paramSizeOut) =>+   (forall r.+    paramValueIn ->+    stateIn -> LLVM.CodeGenFunction r (valueA, stateIn)) ->+   (forall r.+    paramValueIn ->+    LLVM.CodeGenFunction r stateIn) ->+   (forall r.+    nextParamValue ->+    valueA -> state ->+    Maybe.T r+       (Value Bool, (Value Word32, (stateIn, state, stateOut)))+       (valueB, state)) ->+   (forall r.+    startParamValue ->+    CodeGenFunction r state) ->+   (forall r.+    paramValueOut ->+    valueB -> stateOut -> LLVM.CodeGenFunction r stateOut) ->+   (forall r.+    paramValueOut ->+    LLVM.CodeGenFunction r stateOut) ->+   IO (FunPtr (Ptr startParamStruct -> IO (Ptr stateStruct)),+       FunPtr (Ptr stateStruct -> IO ()),+       FunPtr (Ptr nextParamStruct -> Ptr stateStruct -> Word32 ->+               Ptr paramStructIn -> Ptr paramStructOut -> IO Word32))+compilePlugged nextIn startIn next start nextOut startOut =+   Exec.compileModule $+      liftM3 (,,)+         (createNamedFunction ExternalLinkage "startprocess" $+          \paramPtr -> do+             pptr <- LLVM.malloc+             flip Memory.store pptr =<< start =<< Memory.load paramPtr+             ret pptr)+         (createNamedFunction ExternalLinkage "stopprocess" $+          \ pptr -> LLVM.free pptr >> ret ())+         (createNamedFunction ExternalLinkage "fillprocess" $+          \ paramPtr sptr loopLen inPtr outPtr -> do+             param <- Memory.load paramPtr+             sInit <- Memory.load sptr+             inParam  <- Memory.load inPtr+             outParam <- Memory.load outPtr+             inInit  <- startIn  inParam+             outInit <- startOut outParam+             (pos,(_,sExit,_)) <-+                Maybe.fixedLengthLoop loopLen (inInit, sInit, outInit) $+                   \ (in0,s0,out0) -> do+                (a,in1) <- Maybe.lift $ nextIn inParam in0+                (b,s1) <- next param a s0+                out1 <- Maybe.lift $ nextOut outParam b out0+                return (in1, s1, out1)+             Memory.store sExit sptr+             ret (pos :: Value Word32))++ runStorableChunky ::-   (Storable a, MakeValueTuple a valueA, Rep.Memory valueA structA,-    Storable b, MakeValueTuple b valueB, Rep.Memory valueB structB) =>+   (Storable a, MakeValueTuple a valueA, Memory.C valueA structA,+    Storable b, MakeValueTuple b valueB, Memory.C valueB structB) =>    T p valueA valueB ->    IO (p -> SVL.Vector a -> SVL.Vector b) runStorableChunky proc =    fmap ($ const SVL.empty) $    runStorableChunkyCont proc -{--I liked to write something with signature--> import qualified Synthesizer.Causal.Process as Causal->-> liftStorableChunk ::->    T p valueA valueB ->->    IO (p -> Causal.T (SV.Vector a) (SV.Vector b))--This could be used to convert a LLVM causal process-to something that works on Haskell values (here: strict storable vectors).-In a second step we could convert this to a processor of lazy lists,-and thus to a processor of chunky storable vectors.-Unfortunately @Causal.T@ 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.--}- {- | This function should be used instead of @StorableVector.Lazy.Pattern.splitAt@ and subsequent @append@, because it does not have the risk of a memory leak. -} runStorableChunkyCont ::-   (Storable a, MakeValueTuple a valueA, Rep.Memory valueA structA,-    Storable b, MakeValueTuple b valueB, Rep.Memory valueB structB) =>+   (Storable a, MakeValueTuple a valueA, Memory.C valueA structA,+    Storable b, MakeValueTuple b valueB, Memory.C valueB structB) =>    T p valueA valueB ->    IO ((SVL.Vector a -> SVL.Vector b) ->        p ->@@ -823,9 +861,13 @@       SVL.fromChunks $ unsafePerformIO $ do          (ioContext, (nextParam, startParam)) <- createIOContext p -         statePtr <- Rep.newForeignPtrParam stopFunc startFunc startParam+         when False $ DebugCnt.with DebugSt.dumpCounter $ do+            DebugSt.dump "next-param" nextParam+            DebugSt.dump "start-param" startParam++         statePtr <- ForeignPtr.newParam stopFunc startFunc startParam          nextParamPtr <--            Rep.newForeignPtr (deleteIOContext ioContext) nextParam+            ForeignPtr.new (deleteIOContext ioContext) nextParam           let go xt =                unsafeInterleaveIO $@@ -833,14 +875,14 @@                   [] -> return []                   x:xs -> SVB.withStartPtr x $ \aPtr size -> do                      v <--                        Rep.withForeignPtr nextParamPtr $ \nptr ->+                        ForeignPtr.with nextParamPtr $ \nptr ->                         withForeignPtr statePtr $ \sptr ->                         SVB.createAndTrim size $                         fmap fromIntegral .                         derefChunkPtr fill nptr sptr                            (fromIntegral size)-                           (Rep.castStorablePtr aPtr) .-                        Rep.castStorablePtr+                           (Memory.castStorablePtr aPtr) .+                        Memory.castStorablePtr                      (if SV.length v > 0                         then fmap (v:)                         else id) $@@ -852,9 +894,90 @@          go (SVL.chunks sig)  applyStorableChunky ::-   (Storable a, MakeValueTuple a valueA, Rep.Memory valueA structA,-    Storable b, MakeValueTuple b valueB, Rep.Memory valueB structB) =>+   (Storable a, MakeValueTuple a valueA, Memory.C valueA structA,+    Storable b, MakeValueTuple b valueB, Memory.C valueB structB) =>    T p valueA valueB ->    p -> SVL.Vector a -> SVL.Vector b applyStorableChunky gen =    unsafePerformIO (runStorableChunky gen)+++{-+I liked to write something with signature++> import qualified Synthesizer.Causal.Process as Causal+>+> liftStorableChunk ::+>    T p valueA valueB ->+>    IO (p -> 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 an 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.+-}+processIOCore ::+   (Cut.Read a) =>+   PIn.T a b ->+   T p b c ->+   POut.T c d ->+   IO (p -> PIO.T a d)+processIOCore+      (PIn.Cons nextIn startIn createIn deleteIn)+      (Cons next start createIOContext deleteIOContext)+      (POut.Cons nextOut startOut createOut deleteOut) = do+   (startFunc, stopFunc, fill) <-+      compilePlugged nextIn startIn next start nextOut startOut+   return $ \p -> PIO.Cons+      (\a s@(_, (nextParamPtr,statePtr)) -> do+         let maximumSize = Cut.length a+             nptr = Memory.castStorablePtr nextParamPtr+             sptr = statePtr+         (contextIn, paramIn)  <- createIn a+         (contextOut,paramOut) <- createOut maximumSize+         actualSize <-+            AllocUtil.with paramIn $ \inptr ->+            AllocUtil.with paramOut $ \outptr ->+            derefChunkPtr fill nptr sptr+               (fromIntegral maximumSize)+               (Memory.castStorablePtr inptr)+               (Memory.castStorablePtr outptr)+         deleteIn contextIn+         b <- deleteOut (fromIntegral actualSize) contextOut+         return (b, s))+      (do+         (ioContext, (nextParam, startParam)) <- createIOContext p++         when False $ DebugCnt.with DebugSt.dumpCounter $ do+            DebugSt.dump "next-param" nextParam+            DebugSt.dump "start-param" startParam++         nextParamPtr <- Alloc.malloc+         poke nextParamPtr nextParam+         statePtr <-+            AllocUtil.with startParam+               (derefStartParamPtr startFunc . Memory.castStorablePtr)++         return (ioContext, (nextParamPtr, statePtr)))+      (\(ioContext, (nextParamPtr,statePtr)) -> do+         derefStopPtr stopFunc statePtr+         Alloc.free nextParamPtr+         deleteIOContext ioContext)++processIO ::+   (Cut.Read a, PIn.Default a b, POut.Default c d) =>+   T p b c ->+   IO (p -> PIO.T a d)+processIO proc =+   processIOCore PIn.deflt proc POut.deflt
src/Synthesizer/LLVM/CausalParameterized/ProcessPacked.hs view
@@ -12,31 +12,32 @@ import Synthesizer.LLVM.CausalParameterized.Process (T(Cons), ) import qualified Synthesizer.LLVM.CausalParameterized.Process as Causal import qualified Synthesizer.LLVM.Parameter as Param-import qualified Synthesizer.LLVM.Sample as Sample+import qualified Synthesizer.LLVM.Frame as Frame+import qualified Synthesizer.LLVM.SerialVector as Serial import qualified Synthesizer.LLVM.Frame.Stereo as Stereo  import qualified LLVM.Extra.ScalarOrVector as SoV import qualified LLVM.Extra.Vector as Vector import qualified LLVM.Extra.MaybeContinuation as Maybe-import qualified LLVM.Extra.Representation as Rep+import qualified LLVM.Extra.Memory as Memory import qualified LLVM.Extra.Class as Class import qualified LLVM.Extra.Arithmetic as A import qualified LLVM.Extra.Control as C-import LLVM.Extra.Control (whileLoop, ifThen, )+import LLVM.Extra.Class (MakeValueTuple, Undefined, undefTuple, )  import LLVM.Core as LLVM  import qualified Data.TypeLevel.Num as TypeNum-import qualified Data.TypeLevel.Num.Sets as TypeSet+import Data.TypeLevel.Num.Ops ((:<:), ) +import qualified Control.Category as Cat import qualified Control.Arrow    as Arr import Control.Arrow ((^<<), (<<<), ) --- import qualified Algebra.Transcendental as Trans--- import qualified Algebra.Field as Field-import qualified Algebra.Ring as Ring import qualified Algebra.Additive as Additive +import Data.Tuple.HT (swap, )+ import Data.Word (Word32, ) import Foreign.Storable (Storable, ) @@ -63,7 +64,7 @@              in  ((a,b), (valueOf $ (fromIntegral $ Vector.sizeInTuple b :: Word32), s)))             (\(cont,(_ab0,(i0,_s0))) ->                A.and cont =<<-                  A.icmp IntUGT i0 (value LLVM.zero))+                  A.cmp CmpGT i0 (value LLVM.zero))             (\(_,((a0,b0),(i0,s0))) -> Maybe.toBool $ do                ai <- Maybe.lift $ Vector.extract (valueOf 0) a0                (bi,s1) <- next param ai s0@@ -88,7 +89,7 @@    T p a b -> T p va vb packSmall (Cons next start createIOContext deleteIOContext) = Cons    (\param a s ->-      let vundef = LLVM.undefTuple+      let vundef = Class.undefTuple       in  foldr              (\i rest (v0,s0) -> do                 ai <- Maybe.lift $ Vector.extract (valueOf i) a@@ -111,70 +112,85 @@ -} unpack ::    (Vector.Access n a va, Vector.Access n b vb,-    Class.Zero va, LLVM.Undefined b,-    Rep.Memory va vap, IsSized vap vas,-    Rep.Memory vb vbp, IsSized vbp vbs) =>+    Class.Zero va, Class.Undefined b,+    Memory.C va vap, IsSized vap vas,+    Memory.C vb vbp, IsSized vbp vbs) =>    T p va vb -> T p a b unpack (Cons next start createIOContext deleteIOContext) = Cons    (\param ai ((a0,b0),(i0,s0)) -> do-      endOfVector <- Maybe.lift $ A.icmp IntEQ i0 (valueOf 0)+      endOfVector <- Maybe.lift $ A.cmp CmpEQ i0 (valueOf 0)       ((a2,b2),(i2,s2)) <-          Maybe.fromBool $          C.ifThen endOfVector (valueOf True, ((a0,b0),(i0,s0))) $ do             (cont1, (b1,s1)) <- Maybe.toBool $ next param a0 s0             return (cont1,-                      ((LLVM.undefTuple, b1),+                      ((Class.undefTuple, b1),                        (valueOf $ fromIntegral $ Vector.sizeInTuple a0, s1)))       Maybe.lift $ do          a3 <- fmap snd $ Vector.shiftDown ai a2-         (bi,b3) <- Vector.shiftDown (LLVM.undefTuple) b2+         (bi,b3) <- Vector.shiftDown (Class.undefTuple) b2          i3 <- A.dec i2          return (bi, ((a3,b3),(i3,s2))))    (\p -> do       s <- start p-      return ((Class.zeroTuple, LLVM.undefTuple), (valueOf (0::Word32), s)))+      return ((Class.zeroTuple, Class.undefTuple), (valueOf (0::Word32), s)))    createIOContext    deleteIOContext   raise ::-   (Storable a, IsArithmetic a, IsPrimitive a, IsConst a,-    MakeValueTuple a (Value a), IsFirstClass a, IsSized a size,-    IsPowerOf2 n, TypeNum.Mul n size ps, TypeSet.Pos ps) =>+   (Storable a, IsArithmetic a, IsConst a,+    MakeValueTuple a (Value a),+    Memory.FirstClass a am,+    IsPrimitive a,  IsSized a as,+    IsPrimitive am, IsSized am amsize,+    TypeNum.Mul n as vas, TypeNum.Pos vas,+    TypeNum.Mul n amsize vmsize, TypeNum.Pos vmsize,+    TypeNum.Pos n) =>    Param.T p a ->    T p (Value (Vector n a)) (Value (Vector n a)) raise x =-   Causal.map Sample.mixMono (LLVM.vector . (:[]) ^<< x)+   Causal.map Frame.mix (Serial.replicate ^<< x)   amplify ::-   (Storable a, IsArithmetic a, IsPrimitive a, IsConst a,-    MakeValueTuple a (Value a), IsFirstClass a, IsSized a size,-    IsPowerOf2 n, TypeNum.Mul n size ps, TypeSet.Pos ps) =>+   (Storable a, IsArithmetic a, IsConst a,+    MakeValueTuple a (Value a),+    Memory.FirstClass a am,+    IsPrimitive a,  IsSized a asize,+    IsPrimitive am, IsSized am amsize,+    TypeNum.Mul n asize vas, TypeNum.Pos vas,+    TypeNum.Mul n amsize vmsize, TypeNum.Pos vmsize,+    TypeNum.Pos n) =>    Param.T p a ->    T p (Value (Vector n a)) (Value (Vector n a)) amplify p =-   Causal.map Sample.amplifyMono (LLVM.vector . (:[]) ^<< p)+   Causal.map Frame.amplifyMono (Serial.replicate ^<< p)  amplifyStereo ::-   (Storable a, IsArithmetic a, IsPrimitive a, IsConst a,-    MakeValueTuple a (Value a), IsFirstClass a, IsSized a size,-    IsPowerOf2 n, TypeNum.Mul n size ps, TypeSet.Pos ps) =>+   (Storable a, IsArithmetic a, IsConst a,+    MakeValueTuple a (Value a),+    Memory.FirstClass a am,+    IsPrimitive a,  IsSized a asize,+    IsPrimitive am, IsSized am amsize,+    TypeNum.Mul n asize vas, TypeNum.Pos vas,+    TypeNum.Mul n amsize vmsize, TypeNum.Pos vmsize,+    TypeNum.Pos n) =>    Param.T p a ->    T p (Stereo.T (Value (Vector n a))) (Stereo.T (Value (Vector n a))) amplifyStereo p =-   Causal.map Sample.amplifyStereo (LLVM.vector . (:[]) ^<< p)+   Causal.map Frame.amplifyStereo (Serial.replicate ^<< p)   osciCore ::-   (IsFirstClass t, IsSized t size,+   (Memory.FirstClass t tm, IsSized t size, IsSized tm tmsize,     SoV.Fraction t, IsConst t,     Vector.Real t, IsPrimitive t,-    IsPowerOf2 n,+    TypeNum.Pos n,     Additive.C t) =>    T p (Value (Vector n t), Value (Vector n t)) (Value (Vector n t)) osciCore =-   Causal.mapSimple (uncurry SoV.addToPhase) <<<+   Causal.zipWithSimple SoV.addToPhase <<<    Arr.second       (Causal.mapAccumSimple          (\a phase0 -> do@@ -184,10 +200,10 @@          (return (valueOf Additive.zero)))  osciSimple ::-   (IsFirstClass t, IsSized t size,+   (Memory.FirstClass t tm, IsSized t size, IsSized tm tmsize,     SoV.Fraction t, IsConst t,     Vector.Real t, IsPrimitive t,-    IsPowerOf2 n,+    TypeNum.Pos n,     Additive.C t) =>    (forall r. Value (Vector n t) -> CodeGenFunction r y) ->    T p (Value (Vector n t), Value (Vector n t)) y@@ -195,12 +211,44 @@    Causal.mapSimple wave <<< osciCore  shapeModOsci ::-   (IsFirstClass t, IsSized t size,+   (Memory.FirstClass t tm, IsSized t size, IsSized tm tmsize,     SoV.Fraction t, IsConst t,     Vector.Real t, IsPrimitive t,-    IsPowerOf2 n,+    TypeNum.Pos n,     Additive.C t) =>    (forall r. c -> Value (Vector n t) -> CodeGenFunction r y) ->    T p (c, (Value (Vector n t), Value (Vector n t))) y shapeModOsci wave =-   Causal.mapSimple (uncurry wave) <<< Arr.second osciCore+   Causal.zipWithSimple wave <<< Arr.second osciCore+++delay1 ::+   (Vector.Access n al va,+    Storable a,+    MakeValueTuple a al,+    Memory.C al ap,+    IsSized ap as) =>+   Param.T p a -> T p va va+delay1 initial =+   Causal.loop initial $+   Causal.mapSimple (fmap swap . uncurry Vector.shiftUp . swap)++differentiate ::+   (Vector.Access n al va,+    A.Additive va,+    Storable a,+    MakeValueTuple a al,+    Memory.C al ap,+    IsSized ap as) =>+   Param.T p a -> T p va va+differentiate initial =+   Cat.id - delay1 initial+++arrayElement ::+   (IsFirstClass a, SoV.Replicate a v,+    LLVM.GetValue (LLVM.Array dim a) index a,+    TypeNum.Nat index, TypeNum.Nat dim, index :<: dim) =>+   index -> T p (Value (LLVM.Array dim a)) (Value v)+arrayElement i =+   Causal.mapSimple SoV.replicate <<< Causal.arrayElement i
src/Synthesizer/LLVM/CausalParameterized/ProcessPrivate.hs view
@@ -5,30 +5,33 @@ module Synthesizer.LLVM.CausalParameterized.ProcessPrivate where  import qualified Synthesizer.LLVM.Parameterized.SignalPrivate as Sig-import qualified LLVM.Extra.MaybeContinuation as Maybe import qualified Synthesizer.LLVM.Parameter as Param-import qualified LLVM.Extra.Representation as Rep  import qualified LLVM.Extra.Arithmetic as A+import qualified LLVM.Extra.MaybeContinuation as Maybe+import qualified LLVM.Extra.Memory as Memory  import qualified LLVM.Core as LLVM+import LLVM.Extra.Class (MakeValueTuple, ) import LLVM.Util.Loop (Phi, ) import LLVM.Core-          (Value, valueOf, MakeValueTuple,-           IsSized, IsFirstClass, IsArithmetic, CodeGenFunction, )+          (Value, valueOf,+           IsSized, CodeGenFunction, )  import qualified Control.Arrow    as Arr import qualified Control.Category as Cat-import Control.Arrow ((^<<), (<<<), (<<^), (&&&), )+import Control.Arrow (arr, (^<<), (<<<), (&&&), ) import Control.Monad (liftM2, )--import qualified Algebra.Ring     as Ring+import Control.Applicative (Applicative, pure, (<*>), )  import Data.Word (Word32, ) import Foreign.Storable.Tuple () import Foreign.Storable (Storable, ) -import Data.Tuple.HT (swap, )+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.Numeric import NumericPrelude.Base hiding (and, iterate, map, zip, zipWith, take, takeWhile, )@@ -42,11 +45,11 @@        Storable nextParamTuple,        MakeValueTuple startParamTuple startParamValue,        MakeValueTuple nextParamTuple  nextParamValue,-       Rep.Memory     startParamValue startParamPacked,-       Rep.Memory     nextParamValue  nextParamPacked,+       Memory.C     startParamValue startParamPacked,+       Memory.C     nextParamValue  nextParamPacked,        IsSized        startParamPacked startParamSize,        IsSized        nextParamPacked  nextParamSize,-       Rep.Memory state packed,+       Memory.C state packed,        IsSized packed size) =>    Cons       (forall r c.@@ -72,11 +75,11 @@     Storable nextParamTuple,     MakeValueTuple startParamTuple startParamValue,     MakeValueTuple nextParamTuple nextParamValue,-    Rep.Memory startParamValue startParamPacked,-    Rep.Memory nextParamValue nextParamPacked,+    Memory.C startParamValue startParamPacked,+    Memory.C nextParamValue nextParamPacked,     IsSized    startParamPacked startParamSize,     IsSized    nextParamPacked  nextParamSize,-    Rep.Memory state packed,+    Memory.C state packed,     IsSized packed size) =>    (forall r c.     (Phi c) =>@@ -100,17 +103,17 @@    start    createIOContext deleteIOContext -fromSignal :: Sig.T p a -> T p () a+fromSignal :: Sig.T p b -> T p a b fromSignal (Sig.Cons next start createIOContext deleteIOContext) = Cons-   (\ioContext () -> next ioContext)+   (\ioContext _ -> next ioContext)    start    createIOContext deleteIOContext   mapAccum ::-   (Storable pnh, MakeValueTuple pnh pnl, Rep.Memory pnl pnp, IsSized pnp pns,-    Storable psh, MakeValueTuple psh psl, Rep.Memory psl psp, IsSized psp pss,-    Rep.Memory s struct, IsSized struct sa) =>+   (Storable pnh, MakeValueTuple pnh pnl, Memory.C pnl pnp, IsSized pnp pns,+    Storable psh, MakeValueTuple psh psl, Memory.C psl psp, IsSized psp pss,+    Memory.C s struct, IsSized struct sa) =>    (forall r. pnl -> a -> s -> CodeGenFunction r (b,s)) ->    (forall r. psl -> CodeGenFunction r s) ->    Param.T p pnh ->@@ -124,7 +127,7 @@   map ::-   (Storable ph, MakeValueTuple ph pl, Rep.Memory pl pp, IsSized pp ps) =>+   (Storable ph, MakeValueTuple ph pl, Memory.C pl pp, IsSized pp ps) =>    (forall r. pl -> a -> CodeGenFunction r b) ->    Param.T p ph ->    T p a b@@ -141,18 +144,24 @@ mapSimple f =    map (const f) (return ()) +zipWithSimple ::+   (forall r. a -> b -> CodeGenFunction r c) ->+   T p (a,b) c+zipWithSimple f =+   mapSimple (uncurry f) + apply :: T p a b -> Sig.T p a -> Sig.T p b apply proc sig =    toSignal (proc <<< fromSignal sig)  feedFst :: Sig.T p a -> T p b (a,b) feedFst sig =-   first (fromSignal sig) <<^ (\b -> ((),b))+   fromSignal sig &&& Cat.id  feedSnd :: Sig.T p a -> T p b (b,a) feedSnd sig =-   swap ^<< feedFst sig+   Cat.id &&& fromSignal sig   {-@@ -202,8 +211,61 @@    first = first  +instance Functor (T p a) where+   fmap = (^<<)++instance Applicative (T p a) where+   pure x = Arr.arr (const x)+   f <*> x = uncurry ($) ^<< f&&&x+++instance (A.Additive b) => Additive.C (T p a b) where+   zero = pure A.zero+   negate x = mapSimple A.neg <<< x+   x + y = zipWithSimple A.add <<< x&&&y+   x - y = zipWithSimple A.sub <<< x&&&y++instance (A.PseudoRing b, A.IntegerConstant b) => Ring.C (T p a b) where+   one = pure A.one+   fromInteger n = pure (A.fromInteger' n)+   x * y = zipWithSimple A.mul <<< x&&&y++instance (A.Field b, A.RationalConstant b) => Field.C (T p a b) where+   fromRational' x = pure (A.fromRational' $ Ratio.toRational98 x)+   x / y = zipWithSimple A.fdiv <<< x&&&y+++{- |+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 ::+   (Storable ch,+    MakeValueTuple ch c,+    Memory.C c cp,+    IsSized cp cs) =>+   Param.T p ch -> T p (a,c) (b,c) -> T p a b+loop initial (Cons next start createIOContext deleteIOContext) =+   Cons+      (\p a0 (c0,s0) -> do+         ((b1,c1), s1) <- next p (a0,c0) s0+         return (b1,(c1,s1)))+      (\(i,p) -> fmap ((,) (Param.value initial i)) $ start p)+      (\p -> do+         (ctx,(nextParam,startParam)) <- createIOContext p+         return (ctx,+            (nextParam, (Param.get initial p, startParam))))+      deleteIOContext++ takeWhile ::-   (Storable ph, MakeValueTuple ph pl, Rep.Memory pl pp, IsSized pp ps) =>+   (Storable ph, MakeValueTuple ph pl, Memory.C pl pp, IsSized pp ps) =>    (forall r. pl -> a -> CodeGenFunction r (Value Bool)) ->    Param.T p ph ->    T p a a@@ -221,38 +283,28 @@    T p a a take len =    snd ^<<-   takeWhile (const $ A.icmp LLVM.IntULT (valueOf 0) . fst) (return ()) <<<+   takeWhile (const $ A.cmp LLVM.CmpLT (valueOf 0) . fst) (return ()) <<<    feedFst       (Sig.iterate (const A.dec) (return ())          ((fromIntegral :: Int -> Word32) . max 0 ^<< len))   {- |-The first output value is the start value.+The first output value is the initial value. Thus 'integrate' delays by one sample compared with 'integrate0'. -} integrate ::-   (Storable a, IsArithmetic a,-    MakeValueTuple a (Value a), IsFirstClass a, IsSized a size) =>+   (Storable a, A.Additive al,+    MakeValueTuple a al, Memory.C al as, IsSized as size) =>    Param.T p a ->-   T p (Value a) (Value a)+   T p al al integrate =-   mapAccum-      (\() a s -> do-         b <- A.add a s-         return (s,b))-      return-      (return ())+   flip loop (arr snd &&& zipWithSimple A.add)  integrate0 ::-   (Storable a, IsArithmetic a,-    MakeValueTuple a (Value a), IsFirstClass a, IsSized a size) =>+   (Storable a, A.Additive al,+    MakeValueTuple a al, Memory.C al as, IsSized as size) =>    Param.T p a ->-   T p (Value a) (Value a)+   T p al al integrate0 =-   mapAccum-      (\() a s -> do-         b <- A.add a s-         return (b,b))-      return-      (return ())+   flip loop ((\a -> (a,a)) ^<< zipWithSimple A.add)
+ src/Synthesizer/LLVM/Complex.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Synthesizer.LLVM.Complex (+   Complex.T(Complex.real, Complex.imag),+   (Complex.+:),+   Complex.cis,+   Complex.scale,+   constOf, unfold,+   ) where++import qualified Synthesizer.LLVM.Simple.Value as Value++import qualified LLVM.Extra.Memory as Memory+import LLVM.Extra.Class (Undefined, undefTuple, )++import qualified LLVM.Core as LLVM+import LLVM.Core (Value, ConstValue, Struct, IsConst, )+import LLVM.Util.Loop (Phi, phis, addPhis, )++import qualified Data.TypeLevel.Num      as TypeNum++import Control.Applicative (liftA2, )++import qualified Number.Complex as Complex++{-+import NumericPrelude.Numeric+import NumericPrelude.Base+-}++constOf :: IsConst a =>+   Complex.T a -> ConstValue (Struct (a, (a, ())))+constOf x =+   LLVM.constStruct+      (LLVM.constOf $ Complex.real x,+        (LLVM.constOf $ Complex.imag x,+          ()))++unfold ::+   Value (Struct (a, (a, ()))) -> Complex.T (Value.T a)+unfold x =+   Value.lift0 (LLVM.extractvalue x TypeNum.d0)+   Complex.+:+   Value.lift0 (LLVM.extractvalue x TypeNum.d1)+++instance (Undefined a) => Undefined (Complex.T a) where+   undefTuple = (Complex.+:) undefTuple undefTuple++instance (Phi a) => Phi (Complex.T a) where+   phis bb v =+      liftA2 (Complex.+:)+         (phis bb (Complex.real v))+         (phis bb (Complex.imag v))+   addPhis bb x y = do+      addPhis bb (Complex.real x) (Complex.real y)+      addPhis bb (Complex.imag x) (Complex.imag y)+++memory ::+   (Memory.C l s, LLVM.IsSized s ss) =>+   Memory.Record r (LLVM.Struct (s, (s, ()))) (Complex.T l)+memory =+   liftA2 (Complex.+:)+      (Memory.element Complex.real TypeNum.d0)+      (Memory.element Complex.imag TypeNum.d1)++instance+      (Memory.C l s, LLVM.IsSized s ss) =>+      Memory.C (Complex.T l) (LLVM.Struct (s, (s, ()))) where+   load = Memory.loadRecord memory+   store = Memory.storeRecord memory+   decompose = Memory.decomposeRecord memory+   compose = Memory.composeRecord memory
+ src/Synthesizer/LLVM/ConstantPiece.hs view
@@ -0,0 +1,148 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{- |+Data type that allows handling of piecewise constant signals+independently from the source.+-}+module Synthesizer.LLVM.ConstantPiece where++import qualified Synthesizer.LLVM.Parameterized.SignalPrivate as SigP+import qualified Synthesizer.LLVM.Parameter as Param++import qualified Synthesizer.LLVM.Storable.LazySizeIterator as SizeIt+import qualified Data.StorableVector.Lazy.Pattern as SVP++import qualified Synthesizer.LLVM.EventIterator as EventIt+import qualified Data.EventList.Relative.BodyTime as EventList+import qualified Numeric.NonNegative.Wrapper as NonNeg++import qualified LLVM.Extra.MaybeContinuation as Maybe+import qualified LLVM.Extra.Memory as Memory+import qualified LLVM.Extra.Class as Class+import qualified LLVM.Extra.Arithmetic as A+import LLVM.Extra.Control (whileLoop, )+import LLVM.Extra.Class (MakeValueTuple, Undefined, undefTuple, )++import LLVM.Util.Loop (Phi, phis, addPhis, )+import LLVM.Core as LLVM++import Data.TypeLevel.Num (d0, d1, )++import Data.Word (Word32, )+import Foreign.Storable.Tuple ()+import Foreign.Storable (Storable, )+import qualified Synthesizer.LLVM.Alloc as Alloc++import Control.Applicative (liftA2, )++import NumericPrelude.Numeric+import NumericPrelude.Base+++data T a = Cons (Value Word32) a++instance (Phi a) => Phi (T a) where+   phis bb (Cons len y) =+      liftA2 Cons (phis bb len) (phis bb y)+   addPhis bb (Cons lenA ya) (Cons lenB yb) =+      addPhis bb lenA lenB >> addPhis bb ya yb++instance (Undefined a) =>+      Undefined (T a) where+   undefTuple =+      Cons Class.undefTuple Class.undefTuple++instance (Class.Zero a) =>+      Class.Zero (T a) where+   zeroTuple =+      Cons Class.zeroTuple Class.zeroTuple++parameterMemory ::+   (Memory.C a s, IsSized s ss) =>+   Memory.Record r (Struct (Word32, (s, ()))) (T a)+parameterMemory =+   liftA2 Cons+      (Memory.element (\(Cons len _y) -> len) d0)+      (Memory.element (\(Cons _len y) -> y)   d1)++instance+      (Memory.C a s, IsSized s ss) =>+      Memory.C (T a) (Struct (Word32, (s, ()))) where+   load = Memory.loadRecord parameterMemory+   store = Memory.storeRecord parameterMemory+   decompose = Memory.decomposeRecord parameterMemory+   compose = Memory.composeRecord parameterMemory+++flatten ::+   (Memory.C value struct, IsSized struct size) =>+   SigP.T p (T value) ->+   SigP.T p value+flatten (SigP.Cons next start createIOContext deleteIOContext) =+   SigP.Cons+      (\nextParam state0 -> do+         (Cons length1 y1, s1) <-+            Maybe.fromBool $+            whileLoop (valueOf True, state0)+               (\(cont, (Cons len _y, _s)) ->+                  LLVM.and cont =<< A.cmp CmpEQ len (valueOf 0))+               (\(_cont, (Cons _len _y, s)) ->+                  Maybe.toBool $ next nextParam s)+         length2 <- Maybe.lift (A.dec length1)+         return (y1, (Cons length2 y1, s1)))+      (\startParam ->+         fmap ((,) (Cons (valueOf 0) undefTuple)) $+         start startParam)+      createIOContext deleteIOContext+++piecewiseConstant ::+   (Storable a, MakeValueTuple a value, Memory.C value struct, IsSized struct size) =>+   Param.T p (EventList.T NonNeg.Int a) ->+   SigP.T p (T value)+piecewiseConstant evs = SigP.Cons+   (\(stable, yPtr) () -> do+      len <- Maybe.lift $ do+         nextFn <- staticFunction EventIt.nextCallBack+         call nextFn stable yPtr+      Maybe.guard =<<+         Maybe.lift (A.cmp CmpNE len (valueOf 0))+      y <- Maybe.lift $ Memory.load yPtr+      return (Cons len y, ()))+   return+   (\p -> do+      stable <- EventIt.new (Param.get evs p)+      yPtr <- Alloc.malloc+      return ((stable, asTypeOfEventListElement yPtr evs),+              ((stable, Memory.castStorablePtr yPtr), ())))+   (\(stable,yPtr) -> do+      EventIt.dispose stable+      Alloc.free yPtr)++asTypeOfEventListElement ::+   Ptr a ->+   Param.T p (EventList.T NonNeg.Int a) ->+   Ptr a+asTypeOfEventListElement ptr _ = ptr+++lazySize ::+   Param.T p SVP.LazySize ->+   SigP.T p (T ())+lazySize size = SigP.Cons+   (\stable () -> do+      len <- Maybe.lift $ do+         nextFn <- staticFunction SizeIt.nextCallBack+         call nextFn stable+      Maybe.guard =<<+         Maybe.lift (A.cmp CmpNE len (valueOf 0))+      return (Cons len (), ()))+   return+   (\p -> do+      stable <- SizeIt.new (Param.get size p)+      return (stable, (stable, ())))+   SizeIt.dispose
+ src/Synthesizer/LLVM/Debug/Counter.hs view
@@ -0,0 +1,32 @@+module Synthesizer.LLVM.Debug.Counter where++import qualified Control.Monad.Trans.Reader as R+import qualified Data.IORef as IORef+import qualified Data.List.HT as ListHT+++newtype T ident = Cons Int+   deriving (Eq, Ord)++instance Enum (T ident) where+   fromEnum (Cons n) = n+   toEnum n = (Cons n)++format :: Int -> T ident -> String+format pad (Cons n) =+   ListHT.padLeft '0' pad (show n)++new :: IO (IORef.IORef (T ident))+new =+   IORef.newIORef (Cons 0)++{-+wrap :: (Int -> IO ()) -> R.ReaderT (T ident) IO ()+wrap act =+   R.ReaderT $ \(Cons n) -> act n+-}++with :: IORef.IORef (T ident) -> R.ReaderT (T ident) IO () -> IO ()+with cnt act = do+   R.runReaderT act =<< IORef.readIORef cnt+   IORef.modifyIORef cnt succ
+ src/Synthesizer/LLVM/Debug/StablePtr.hs view
@@ -0,0 +1,12 @@+module Synthesizer.LLVM.Debug.StablePtr where++import Foreign.StablePtr (StablePtr, castStablePtrToPtr, )+import Control.Monad (when, )+++{-# INLINE trace #-}+trace :: String -> StablePtr a -> IO (StablePtr a)+trace name s = do+   when False $+      putStrLn $ "EventIterator." ++ name ++ ": " ++ (show $ castStablePtrToPtr $ s)+   return s
+ src/Synthesizer/LLVM/Debug/Storable.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE Rank2Types #-}+module Synthesizer.LLVM.Debug.Storable where++import qualified Synthesizer.LLVM.Debug.Counter as Counter++import qualified Data.TypeLevel.Num as TypeNum+import qualified LLVM.Core as LLVM+import LLVM.Core (Array, ConstValue, constOf, )++import qualified System.IO as IO+import Numeric (showHex, )++import qualified Data.IORef as IORef+import qualified Data.List as List+import qualified Foreign.Marshal.Utils as Marshal+import Foreign.Marshal.Array (advancePtr, )+import Foreign.Storable (Storable, peek, peekByteOff, sizeOf, alignment, )+import Foreign.Ptr (Ptr, castPtr, )+import Data.Word (Word8, Word32, )+import System.IO.Unsafe (unsafePerformIO, )++import qualified Control.Monad.Trans.Reader as R+import Control.Monad (when, )+++data Dump = Dump++dumpCounter :: IORef.IORef (Counter.T Dump)+dumpCounter =+   unsafePerformIO $ Counter.new++format :: Storable a => a -> IO String+format a =+   Marshal.with a $ \ptr ->+      fmap (concatMap (\byte ->+               (if byte<16 then ('0':) else id) (showHex byte ""))) $+      mapM peek+         (List.take (sizeOf a) $+          List.iterate (flip advancePtr 1) $+          (castPtr ptr :: Ptr Word8))++dump :: Storable a => FilePath -> a -> R.ReaderT (Counter.T Dump) IO ()+dump path a =+   R.ReaderT $ \cnt ->+   IO.withBinaryFile+      (path ++ Counter.format 3 cnt ++ ".dump")+      IO.WriteMode $ \h ->+   Marshal.with a $ \ptr ->+   IO.hPutBuf h ptr (sizeOf a)+++type ArrayElem = Word32++{-+Unfortunately, you cannot 'alloca' or 'malloc' the constructed array,+because an IsSized instance is missing.+We may employ a specialised reifyIntegral for this purpose.+-}+withConstArray ::+   Storable a =>+   a ->+   (forall n. TypeNum.Nat n => ConstValue (Array n ArrayElem) -> b) ->+   IO b+withConstArray a f =+   Marshal.with a $ \ptr -> do+      content <-+         mapM+            (peekByteOff ptr)+            (takeWhile (< sizeOf a) [0,(sizeOf (undefined :: ArrayElem))..])+      return $+         TypeNum.reifyIntegral (length content)+            (\n ->+               let makeArray ::+                      TypeNum.Nat n =>+                      n -> [ConstValue ArrayElem] ->+                      ConstValue (Array n ArrayElem)+                   makeArray _ = LLVM.constArray+               in  f (makeArray n (map constOf content)))+++traceMalloc :: Storable a => a -> Int -> Ptr a -> IO (Ptr a)+traceMalloc a size ptr = do+   when False $ putStrLn $+      showString "%addr" . shows ptr .+      showString " = call float* @malloc(i8* getelementptr (i8* null, i32 " .+      shows size .+      showString "))   ; alignment " . shows (alignment a) $+      ""+   return ptr
src/Synthesizer/LLVM/EventIterator.hs view
@@ -13,7 +13,11 @@ import Foreign.Ptr (FunPtr, ) import Data.IORef (IORef, newIORef, readIORef, writeIORef, ) +import Control.Monad ((<=<), ) +import qualified Synthesizer.LLVM.Debug.StablePtr as DebugStable++ data T =    forall a. Storable a =>    Cons (IORef (EventList.T NonNeg.Int a))@@ -43,6 +47,7 @@    Storable a =>    EventList.T NonNeg.Int a -> IO (StablePtr T) new evs =+   DebugStable.trace "new" =<<    newStablePtr . Cons     =<< newIORef       (EventList.fromPairList $@@ -51,13 +56,14 @@  dispose ::    StablePtr T -> IO ()-dispose = freeStablePtr+dispose = freeStablePtr <=< DebugStable.trace "dispose"  next ::    StablePtr T ->    Ptr a -> IO Word32 next stable eventPtr =-   deRefStablePtr stable >>= \state ->+   DebugStable.trace "next" stable >>=+   deRefStablePtr >>= \state ->    case state of       Cons listRef ->          readIORef listRef >>=
src/Synthesizer/LLVM/Execution.hs view
@@ -1,36 +1,34 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} module Synthesizer.LLVM.Execution where -import LLVM.Core-   (CodeGenModule, newModule, defineModule, getGlobalMappings, Function,-    writeBitcodeToFile, )-import LLVM.ExecutionEngine-   (EngineAccess, runEngineAccess,-    Translatable, generateFunction,-    addModule, getPointerToFunction, addGlobalMappings, )-import LLVM.Util.Optimize (optimizeModule, )+import qualified LLVM.ExecutionEngine as EE+import qualified LLVM.Util.Optimize as Opt+import qualified LLVM.Core as LLVM  import Foreign.Ptr (FunPtr, ) +import qualified Control.Monad.Trans.Reader as R import Control.Monad (liftM2, liftM3, ) -import qualified Data.List.HT as ListHT import qualified Data.IORef as IORef import System.IO.Unsafe (unsafePerformIO, ) +import qualified Synthesizer.LLVM.Debug.Counter as Counter + type Importer f = FunPtr f -> f  class Compile externFunction llvmFunction |                     externFunction -> llvmFunction,                     llvmFunction -> externFunction where-   compile :: llvmFunction -> EngineAccess externFunction+   compile :: llvmFunction -> EE.EngineAccess externFunction -instance Compile (FunPtr f) (Function f) where-   compile = getPointerToFunction+instance Compile (FunPtr f) (LLVM.Function f) where+   compile = EE.getPointerToFunction  instance (Compile efa lfa, Compile efb lfb) =>       Compile (efa,efb) (lfa,lfb) where@@ -48,50 +46,53 @@          (compile fc)  +data BitCodeCnt = BitCodeCnt+ {- | This is only for debugging purposes and thus I felt free to use unsafePerformIO. -}-counter :: IORef.IORef Int+counter :: IORef.IORef (Counter.T BitCodeCnt) counter =-   unsafePerformIO $ IORef.newIORef 0+   unsafePerformIO $ Counter.new  +{- |+This function also initializes LLVM.+This simplifies usage from GHCi.+The @llvm@ packages prevents multiple initialization.+-} assembleModule ::-   (llvmFunction -> EngineAccess externFunction) ->-   CodeGenModule llvmFunction ->+   (llvmFunction -> EE.EngineAccess externFunction) ->+   LLVM.CodeGenModule llvmFunction ->    IO externFunction assembleModule comp bld = do-   m <- newModule+   LLVM.initializeNativeTarget+   m <- LLVM.newModule    (funcs, mappings) <--      defineModule m (liftM2 (,) bld getGlobalMappings)--   -- write bitcode files for debugging-   num <- fmap (ListHT.padLeft '0' 3 . show) (IORef.readIORef counter)-   IORef.modifyIORef counter succ--   writeBitcodeToFile ("generator"++num++".bc") m--   optimizeModule 3 m+      LLVM.defineModule m (liftM2 (,) bld LLVM.getGlobalMappings) -   writeBitcodeToFile ("generator"++num++"-opt.bc") m+   Counter.with counter $ R.ReaderT $ \cnt -> do+      LLVM.writeBitcodeToFile ("generator" ++ Counter.format 3 cnt ++ ".bc") m+      _ <- Opt.optimizeModule 3 m+      LLVM.writeBitcodeToFile ("generator" ++ Counter.format 3 cnt ++ "-opt.bc") m -   runEngineAccess $-      addModule m >>-      addGlobalMappings mappings >>+   EE.runEngineAccess $+      EE.addModule m >>+      EE.addGlobalMappings mappings >>       comp funcs   -- this compiles once and is much faster than runFunction compileModule ::    (Compile externFunction llvmFunction) =>-   CodeGenModule llvmFunction ->+   LLVM.CodeGenModule llvmFunction ->    IO externFunction compileModule =    assembleModule compile  runFunction ::-   (Translatable f) =>-   CodeGenModule (Function f) -> IO f+   (EE.Translatable f) =>+   LLVM.CodeGenModule (LLVM.Function f) -> IO f runFunction =-   assembleModule generateFunction+   assembleModule EE.generateFunction
src/Synthesizer/LLVM/Filter/Allpass.hs view
@@ -24,21 +24,20 @@ import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP import qualified LLVM.Extra.ScalarOrVector as SoV import qualified LLVM.Extra.Vector as Vector-import qualified LLVM.Extra.Representation as Rep+import qualified LLVM.Extra.Memory as Memory import qualified Synthesizer.LLVM.Simple.Value as Value  import qualified LLVM.Extra.Class as Class import qualified LLVM.Extra.Arithmetic as A import qualified LLVM.Core as LLVM+import LLVM.Extra.Class (Undefined, undefTuple, ) import LLVM.Core    (Value, valueOf, Vector,-    IsPowerOf2, IsConst, IsArithmetic, IsPrimitive, IsFirstClass, IsFloating, IsSized,-    Undefined, undefTuple,+    IsArithmetic, IsPrimitive, IsFloating, IsSized,     CodeGenFunction, ) import LLVM.Util.Loop (Phi, phis, addPhis, )  import qualified Data.TypeLevel.Num      as TypeNum-import qualified Data.TypeLevel.Num.Sets as TypeSet  import Foreign.Storable (Storable, ) @@ -49,9 +48,9 @@ import Control.Arrow ((<<<), (^<<), (<<^), (&&&), arr, first, second, )  import qualified Algebra.Transcendental as Trans-import qualified Algebra.Field as Field-import qualified Algebra.Module as Module-import qualified Algebra.Ring as Ring+-- import qualified Algebra.Field as Field+-- import qualified Algebra.Module as Module+-- import qualified Algebra.Ring as Ring  import NumericPrelude.Numeric import NumericPrelude.Base@@ -68,22 +67,24 @@    zeroTuple = Class.zeroTuplePointed  instance-      (Rep.Memory a s, IsSized s ss) =>-      Rep.Memory (Parameter a) s where-   load = Rep.loadNewtype Parameter-   store = Rep.storeNewtype (\(Parameter k) -> k)-   decompose = Rep.decomposeNewtype Parameter-   compose = Rep.composeNewtype (\(Parameter k) -> k)+      (Memory.C a s, IsSized s ss) =>+      Memory.C (Parameter a) s where+   load = Memory.loadNewtype Parameter+   store = Memory.storeNewtype (\(Parameter k) -> k)+   decompose = Memory.decomposeNewtype Parameter+   compose = Memory.composeNewtype (\(Parameter k) -> k)  +{- instance LLVM.ValueTuple a => LLVM.ValueTuple (Parameter a) where    buildTuple f = Class.buildTupleTraversable (LLVM.buildTuple f)  instance LLVM.IsTuple a => LLVM.IsTuple (Parameter a) where    tupleDesc = Class.tupleDescFoldable+-} -instance (LLVM.MakeValueTuple ah al) =>-      LLVM.MakeValueTuple (Parameter ah) (Parameter al) where+instance (Class.MakeValueTuple ah al) =>+      Class.MakeValueTuple (Parameter ah) (Parameter al) where    valueTupleOf = Class.valueTupleOfFunctor  @@ -104,7 +105,7 @@   parameter ::-   (Trans.C a, IsConst a, IsFloating a) =>+   (Trans.C a, SoV.RationalConstant a, IsFloating a) =>    Value a -> Value a ->    CodeGenFunction r (Parameter (Value a)) parameter phase freq =@@ -120,22 +121,24 @@           Functor, App.Applicative, Fold.Foldable, Trav.Traversable)  instance-      (Rep.Memory a s, IsSized s ss) =>-      Rep.Memory (CascadeParameter n a) s where-   load = Rep.loadNewtype CascadeParameter-   store = Rep.storeNewtype (\(CascadeParameter k) -> k)-   decompose = Rep.decomposeNewtype CascadeParameter-   compose = Rep.composeNewtype (\(CascadeParameter k) -> k)+      (Memory.C a s, IsSized s ss) =>+      Memory.C (CascadeParameter n a) s where+   load = Memory.loadNewtype CascadeParameter+   store = Memory.storeNewtype (\(CascadeParameter k) -> k)+   decompose = Memory.decomposeNewtype CascadeParameter+   compose = Memory.composeNewtype (\(CascadeParameter k) -> k)  +{- instance LLVM.ValueTuple a => LLVM.ValueTuple (CascadeParameter n a) where    buildTuple f = Class.buildTupleTraversable (LLVM.buildTuple f)  instance LLVM.IsTuple a => LLVM.IsTuple (CascadeParameter n a) where    tupleDesc = Class.tupleDescFoldable+-} -instance (LLVM.MakeValueTuple ah al) =>-      LLVM.MakeValueTuple (CascadeParameter n ah) (CascadeParameter n al) where+instance (Class.MakeValueTuple ah al) =>+      Class.MakeValueTuple (CascadeParameter n ah) (CascadeParameter n al) where    valueTupleOf = Class.valueTupleOfFunctor  @@ -156,7 +159,7 @@   flangerParameter ::-   (Trans.C a, IsConst a, IsFloating a, TypeNum.Nat n) =>+   (Trans.C a, SoV.RationalConstant a, IsFloating a, TypeNum.Nat n) =>    n -> Value a ->    CodeGenFunction r (CascadeParameter n (Value a)) flangerParameter order freq =@@ -174,7 +177,7 @@   modifier ::-   (Module.C (Value.T a) (Value.T v), IsArithmetic a, IsConst a) =>+   (SoV.PseudoModule a v, SoV.IntegerConstant a) =>    Modifier.Simple       -- (Allpass.State (Value.T v))       (Value.T v, Value.T v)@@ -187,10 +190,10 @@ For Allpass cascade you may use the 'CausalP.pipeline' function. -} causalP ::-   (Field.C a, Module.C (Value.T a) (Value.T v),-    IsFirstClass a, IsSized a as, IsConst a,-    IsFirstClass v, IsSized v vs, IsConst v,-    IsArithmetic a) =>+   (SoV.RationalConstant a, IsArithmetic a,+    SoV.PseudoModule a v,+    Memory.FirstClass a am, IsSized a as, IsSized am ams,+    Memory.FirstClass v vm, IsSized v vs, IsSized vm vms) =>    CausalP.T p       (Parameter (Value a), Value v) (Value v) causalP =@@ -208,10 +211,10 @@       (stg <<< first (arr (\(CascadeParameter p) -> p)))  cascadeP ::-   (Field.C a, Module.C (Value.T a) (Value.T v),-    IsFirstClass a, IsSized a as, IsConst a,-    IsFirstClass v, IsSized v vs, IsConst v,-    IsArithmetic a,+   (SoV.RationalConstant a, IsArithmetic a,+    SoV.PseudoModule a v,+    Memory.FirstClass a am, IsSized a as, IsSized am ams,+    Memory.FirstClass v vm, IsSized v vs, IsSized vm vms,     TypeNum.Nat n) =>    CausalP.T p       (CascadeParameter n (Value a), Value v) (Value v)@@ -219,24 +222,22 @@    replicateStage undefined causalP  half ::-   (Field.C a, Module.C (Value.T a) (Value.T v),-    IsFirstClass a, IsSized a as, IsConst a,-    IsFirstClass v, IsSized v vs, IsConst v,+   (SoV.RationalConstant a, SoV.RationalConstant v,     IsFloating a, IsArithmetic v,+    Memory.FirstClass a am, IsSized a as, IsSized am ams,+    Memory.FirstClass v vm, IsSized v vs, IsSized vm vms,     TypeNum.Nat n) =>    CausalP.T p       (CascadeParameter n (Value a), Value v) (Value v) half =-   CausalP.mapSimple (\(p,x) ->-      Value.decons-         ((const :: Value.T a -> CascadeParameter n (Value a) -> Value.T a) 0.5 p *>-          Value.constantValue x))+   CausalP.mapSimple+      (\(_p,x) -> A.mul (A.fromRational' 0.5) x)  phaserP ::-   (Field.C a, Module.C (Value.T a) (Value.T v),-    IsFirstClass a, IsSized a as, IsConst a,-    IsFirstClass v, IsSized v vs, IsConst v,-    IsFloating a, IsArithmetic v,+   (SoV.RationalConstant a, SoV.RationalConstant v,+    IsFloating a, SoV.PseudoModule a v,+    Memory.FirstClass a am, IsSized a as, IsSized am ams,+    Memory.FirstClass v vm, IsSized v vs, IsSized vm vms,     TypeNum.Nat n) =>    CausalP.T p       (CascadeParameter n (Value a), Value v) (Value v)@@ -251,9 +252,9 @@ but LLVM-2.6 does not yet do it. -} stage ::-   (IsPowerOf2 n, IsPrimitive a, IsFirstClass a,-    IsConst a, IsArithmetic a, Ring.C a,-    IsSized a sa) =>+   (TypeNum.Pos n, IsPrimitive a,+    IsArithmetic a, SoV.IntegerConstant a, SoV.PseudoModule a a,+    Memory.FirstClass a am, IsSized a as, IsSized am ams) =>    n ->    CausalP.T p       (CascadeParameter n (Value (Vector n a)), Value (Vector n a))@@ -271,16 +272,19 @@  {- | Fast implementation of 'cascadeP' using vector instructions.-However, we are currently limited to powers of two,+However, there must be at least one pipeline stage, primitive element types and we get a delay by the number of pipeline stages. -} cascadePipelineP ::-   (Field.C a, IsFirstClass a, IsSized a as,-    TypeNum.Mul n as vas, TypeSet.Pos vas,+   (SoV.RationalConstant a, SoV.PseudoModule a a, --    IsSized (Vector n a) vas,-    IsPowerOf2 n,-    IsArithmetic a, IsPrimitive a, IsConst a) =>+    Memory.FirstClass a am,+    IsPrimitive a,  IsSized a asize,+    IsPrimitive am, IsSized am amsize,+    TypeNum.Mul n asize vasize, TypeNum.Pos vasize,+    TypeNum.Mul n amsize vmsize, TypeNum.Pos vmsize,+    TypeNum.Pos n) =>    CausalP.T p       (CascadeParameter n (Value a), Value a) (Value a) cascadePipelineP = withSize $ \order ->@@ -292,12 +296,13 @@ vectorId _ = Cat.id  phaserPipelineP ::-   (Field.C a,-    IsFirstClass a, IsSized a as,-    IsSized (Vector n a) vas,-    TypeNum.Mul n as vas,-    IsPowerOf2 n,-    IsFloating a, IsPrimitive a, IsConst a) =>+   (SoV.RationalConstant a, IsFloating a, SoV.PseudoModule a a,+    Memory.FirstClass a am,+    IsPrimitive a,  IsSized a asize,+    IsPrimitive am, IsSized am amsize,+    TypeNum.Mul n asize vasize, TypeNum.Pos vasize,+    TypeNum.Mul n amsize vmsize, TypeNum.Pos vmsize,+    TypeNum.Pos n) =>    CausalP.T p       (CascadeParameter n (Value a), Value a) (Value a) phaserPipelineP = withSize $ \order ->@@ -310,9 +315,9 @@  causalPackedP,   causalNonRecursivePackedP ::-   (Ring.C a,-    IsFirstClass a, IsArithmetic a, IsConst a,-    IsPowerOf2 n, IsPrimitive a, IsSized a as) =>+   (Memory.FirstClass a am, IsSized a as, IsSized am ams,+    SoV.IntegerConstant a, IsArithmetic a,+    TypeNum.Pos n, IsPrimitive a) =>    CausalP.T p       (Parameter (Value a), Value (Vector n a)) (Value (Vector n a)) causalPackedP =@@ -333,9 +338,9 @@       (return (LLVM.value LLVM.zero))  cascadePackedP, phaserPackedP ::-   (Field.C a,-    IsFirstClass a, IsArithmetic a, IsConst a,-    IsPowerOf2 m, IsPrimitive a, IsSized a as,+   (SoV.RationalConstant a, IsArithmetic a,+    Memory.FirstClass a am, IsSized a as, IsSized am ams,+    TypeNum.Pos m, IsPrimitive a,     TypeNum.Nat n) =>    CausalP.T p       (CascadeParameter n (Value a), Value (Vector m a)) (Value (Vector m a))@@ -345,4 +350,4 @@ phaserPackedP =    CausalP.mix <<<    cascadePackedP &&& arr snd <<<-   second (CausalP.mapSimple (A.mul (SoV.replicateOf 0.5)))+   second (CausalP.mapSimple (A.mul (A.fromRational' 0.5)))
src/Synthesizer/LLVM/Filter/Butterworth.hs view
@@ -7,15 +7,16 @@    ) where  import qualified Synthesizer.LLVM.Filter.SecondOrderCascade as Cascade+import qualified Synthesizer.LLVM.Filter.SecondOrder as Filt2  import qualified Synthesizer.Plain.Filter.Recursive.Butterworth as Butterworth-import qualified Synthesizer.Plain.Filter.Recursive.SecondOrder as Filt2+import qualified Synthesizer.Plain.Filter.Recursive.SecondOrder as Filt2Core import Synthesizer.Plain.Filter.Recursive (Passband, ) -import qualified LLVM.Extra.Control as U-import qualified LLVM.Extra.Representation as Rep import qualified Synthesizer.LLVM.Simple.Value as Value +import qualified LLVM.Extra.ScalarOrVector as SoV+import qualified LLVM.Extra.Control as U import qualified LLVM.Extra.Arithmetic as A  import qualified LLVM.Core as LLVM@@ -38,7 +39,7 @@   parameter, parameterMalloc, _parameterAlloca ::-   (Trans.C a, IsConst a, IsFloating a, IsSized a as,+   (Trans.C a, SoV.RationalConstant a, IsFloating a, IsSized a as,     TypeSet.Nat n,     TypeNum.Mul n as sineSize,     TypeSet.Pos sineSize,@@ -62,12 +63,13 @@    s <- LLVM.getElementPtr0 psine (valueOf (0::Word32), ())    ps <- LLVM.malloc    p <- LLVM.getElementPtr0 ps (valueOf (0::Word32), ())-   let len = valueOf $ (fromIntegral $ TypeNum.toInt n :: Word32)-   U.arrayLoop len p s $ \ptri si -> do+   let len = valueOf $ (TypeNum.toNum n :: Word32)+   _ <- U.arrayLoop len p s $ \ptri si -> do       sinw <- LLVM.load si-      flip Rep.store ptri =<<+      flip LLVM.store ptri =<<+         Filt2.composeParameter =<<          Value.flatten-            (Filt2.adjustPassband kind+            (Filt2Core.adjustPassband kind                (flip                   (Butterworth.partialParameter                       (Value.constantValue partialRatio))@@ -94,12 +96,13 @@    s <- LLVM.getElementPtr0 psine (valueOf (0::Word32), ())    ps <- LLVM.alloca    p <- LLVM.getElementPtr0 ps (valueOf (0::Word32), ())-   let len = valueOf $ (fromIntegral $ TypeNum.toInt n :: Word32)-   U.arrayLoop len p s $ \ptri si -> do+   let len = valueOf $ (TypeNum.toNum n :: Word32)+   _ <- U.arrayLoop len p s $ \ptri si -> do       sinw <- LLVM.load si-      flip Rep.store ptri =<<+      flip LLVM.store ptri =<<+         Filt2.composeParameter =<<          Value.flatten-            (Filt2.adjustPassband kind+            (Filt2Core.adjustPassband kind                (flip                   (Butterworth.partialParameter                       (Value.constantValue partialRatio))
src/Synthesizer/LLVM/Filter/Chebyshev.hs view
@@ -7,62 +7,46 @@    ) where  import qualified Synthesizer.LLVM.Filter.SecondOrderCascade as Cascade+import qualified Synthesizer.LLVM.Filter.SecondOrder as Filt2  import qualified Synthesizer.Plain.Filter.Recursive.Chebyshev as Chebyshev-import qualified Synthesizer.Plain.Filter.Recursive.SecondOrder as Filt2+import qualified Synthesizer.Plain.Filter.Recursive.SecondOrder as Filt2Core import Synthesizer.Plain.Filter.Recursive (Passband, )  import qualified Synthesizer.LLVM.Simple.Value as Value-import qualified LLVM.Extra.Representation as Rep-import qualified LLVM.Extra.Control as U +import qualified LLVM.Extra.ScalarOrVector as SoV+import qualified LLVM.Extra.Control as U import qualified LLVM.Extra.Arithmetic as A  import qualified LLVM.Core as LLVM import LLVM.Core-   (Value, valueOf, ConstValue,-    Struct, IsSized, IsConst, IsFloating,-    CodeGenFunction, )+   (Value, valueOf, IsSized, IsFloating, CodeGenFunction, ) import Data.Word (Word32, )  import qualified Data.TypeLevel.Num      as TypeNum import qualified Data.TypeLevel.Num.Sets as TypeSet +import qualified Synthesizer.LLVM.Complex as ComplexL+ import qualified Number.Complex as Complex  import qualified Algebra.Transcendental as Trans -- import qualified Algebra.Field as Field -- import qualified Algebra.Module as Module-import qualified Algebra.Ring as Ring+-- import qualified Algebra.Ring as Ring  import NumericPrelude.Numeric import NumericPrelude.Base  -constComplexOf :: IsConst a =>-   Complex.T a -> ConstValue (Struct (a, (a, ())))-constComplexOf x =-   LLVM.constStruct-      (LLVM.constOf $ Complex.real x,-        (LLVM.constOf $ Complex.imag x,-          ()))--valueComplex ::-   Value (Struct (a, (a, ()))) -> Complex.T (Value.T a)-valueComplex x =-   Value.Cons (LLVM.extractvalue x TypeNum.d0)-   Complex.+:-   Value.Cons (LLVM.extractvalue x TypeNum.d1)-- {- | 'n' must be at least one in order to allow amplification by the first partial filter. -} parameterA, parameterB ::-   (Trans.C a, IsConst a, IsFloating a, IsSized a as,-    TypeSet.Pos n,-    TypeNum.Mul n as sineSize,+   (Trans.C a, SoV.RationalConstant a, IsFloating a, IsSized a as,+    TypeSet.Pos n, TypeNum.Mul n as sineSize,     TypeSet.Pos sineSize,     IsSized (Cascade.Parameter n a) paramSize,     TypeNum.Mul n LLVM.UnknownSize paramSize, TypeSet.Pos paramSize) =>@@ -73,13 +57,13 @@     -- adjust amplification of the first filter    filt0 <--      Rep.decompose =<<+      Filt2.decomposeParameter =<<       LLVM.extractvalue pv (0::Word32)    fmap Cascade.ParameterValue $       flip (LLVM.insertvalue pv) (0::Word32) =<<-         Rep.compose =<<+         Filt2.composeParameter =<<          Value.flatten-            (Filt2.amplify (Value.constantValue ratio) (Value.unfold filt0))+            (Filt2Core.amplify (Value.constantValue ratio) (Value.unfold filt0))  parameterB n kind ratio freq =    fmap Cascade.ParameterValue $@@ -87,14 +71,14 @@   parameter ::-   (Trans.C a, IsConst a, IsFloating a, IsSized a as,+   (Trans.C a, SoV.RationalConstant a, IsFloating a, IsSized a as,     TypeSet.Pos n,     TypeNum.Mul n as sineSize,     TypeSet.Pos sineSize,     IsSized (Cascade.Parameter n a) paramSize,     TypeNum.Mul n LLVM.UnknownSize paramSize, TypeSet.Pos paramSize) =>    (Int -> Value.T a -> Value.T a ->-    Complex.T (Value.T a) -> Filt2.Parameter (Value.T a)) ->+    Complex.T (Value.T a) -> Filt2Core.Parameter (Value.T a)) ->    n -> Passband -> Value a -> Value a ->    CodeGenFunction r (Value (Cascade.Parameter n a)) parameter partialParameter n kind ratio freq = do@@ -104,23 +88,24 @@                            -> LLVM.Value (LLVM.Array n a)) n $           LLVM.value $           LLVM.constArray $-          map constComplexOf $+          map ComplexL.constOf $           Chebyshev.makeCirclePoints order    psine <- LLVM.malloc    LLVM.store sines psine    s <- LLVM.getElementPtr0 psine (valueOf (0::Word32), ())    ps <- LLVM.malloc    p <- LLVM.getElementPtr0 ps (valueOf (0::Word32), ())-   let len = valueOf $ (fromIntegral $ TypeNum.toInt n :: Word32)-   U.arrayLoop len p s $ \ptri si -> do+   let len = valueOf $ (TypeNum.toNum n :: Word32)+   _ <- U.arrayLoop len p s $ \ptri si -> do       c <- LLVM.load si-      flip Rep.store ptri =<<+      flip LLVM.store ptri =<<+         Filt2.composeParameter =<<          Value.flatten-            (Filt2.adjustPassband kind+            (Filt2Core.adjustPassband kind                (flip                   (partialParameter order                       (Value.constantValue ratio))-                  (valueComplex c))+                  (ComplexL.unfold c))                (Value.constantValue freq))       A.advanceArrayElementPtr si
src/Synthesizer/LLVM/Filter/ComplexFirstOrder.hs view
@@ -13,24 +13,30 @@  import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP import qualified Synthesizer.LLVM.Causal.Process as Causal-import qualified LLVM.Extra.Representation as Rep import qualified Synthesizer.LLVM.Simple.Value as Value  import qualified Synthesizer.LLVM.Frame.Stereo as Stereo+import qualified Synthesizer.LLVM.Complex as Complex +import qualified LLVM.Extra.ScalarOrVector as SoV import qualified LLVM.Extra.Arithmetic as A+import qualified LLVM.Extra.Memory as Memory+import qualified LLVM.Extra.Class as Class+import LLVM.Extra.Class (Undefined, undefTuple, )  import qualified LLVM.Core as LLVM import LLVM.Core-   (value, valueOf, Value, Struct,-    IsFirstClass, IsConst, IsArithmetic, IsFloating, IsSized,-    Undefined, undefTuple,+   (Value, Struct, value, valueOf,+    IsArithmetic, IsFloating, IsSized,     CodeGenFunction, ) import LLVM.Util.Loop (Phi, phis, addPhis, )  import Data.TypeLevel.Num (d0, d1, d2, ) -import Control.Applicative (liftA3, )+import qualified Control.Applicative as App+import qualified Data.Foldable as Fold+import qualified Data.Traversable as Trav+import Control.Applicative (liftA2, liftA3, (<*>), )  import qualified Algebra.Transcendental as Trans @@ -39,76 +45,125 @@   data Parameter a =-   Parameter a (a,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 (Phi a) => Phi (Parameter a) where-   phis bb (Parameter k (r,i)) = do-      k' <- phis bb k-      r' <- phis bb r-      i' <- phis bb i-      return (Parameter k' (r',i'))-   addPhis bb-        (Parameter k (r,i))-        (Parameter k' (r',i')) = do-      addPhis bb k k'-      addPhis bb r r'-      addPhis bb i i'+   phis = Class.phisTraversable+   addPhis = Class.addPhisFoldable  instance Undefined a => Undefined (Parameter a) where-   undefTuple = Parameter undefTuple (undefTuple,undefTuple)+   undefTuple = Class.undefTuplePointed   parameterMemory ::-   (Rep.Memory l s, IsSized s ss) =>-   Rep.MemoryRecord r (Struct (s, (s, (s, ())))) (Parameter l)+   (Memory.C l s, IsSized s ss) =>+   Memory.Record r (Struct (s, (s, (s, ())))) (Parameter l) parameterMemory =-   liftA3 (\amp kr ki -> Parameter amp (kr,ki))-      (Rep.memoryElement (\(Parameter  amp (_kr,_ki)) -> amp) d0)-      (Rep.memoryElement (\(Parameter _amp ( kr,_ki)) -> kr) d1)-      (Rep.memoryElement (\(Parameter _amp (_kr, ki)) -> ki) d2)+   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 (Rep.Memory l s, IsSized s ss) =>-      Rep.Memory (Parameter l) (Struct (s, (s, (s, ())))) where-   load = Rep.loadRecord parameterMemory-   store = Rep.storeRecord parameterMemory-   decompose = Rep.decomposeRecord parameterMemory-   compose = Rep.composeRecord parameterMemory+instance (Memory.C l s, IsSized s ss) =>+      Memory.C (Parameter l) (Struct (s, (s, (s, ())))) where+   load = Memory.loadRecord parameterMemory+   store = Memory.storeRecord parameterMemory+   decompose = Memory.decomposeRecord parameterMemory+   compose = Memory.composeRecord parameterMemory -parameter ::-   (Trans.C a,-    IsConst a, IsFloating a) =>+instance (Value.Flatten ah al) =>+      Value.Flatten (Parameter ah) (Parameter al) where+   flatten = Value.flattenTraversable+   unfold =  Value.unfoldFunctor+++parameter, _parameter ::+   (Trans.C a, IsFloating a, SoV.RationalConstant a) =>    Value a -> Value a -> CodeGenFunction r (Parameter (Value a))-parameter reson freq = do+parameter reson freq =+   let amp = recip $ Value.unfold reson+   in  Value.flatten $ Parameter amp $+       Complex.scale (1-amp) $ Complex.cis $+       Value.unfold freq * Value.twoPi++_parameter reson freq = do    amp <- A.fdiv (valueOf 1) reson    k   <- A.sub  (valueOf 1) amp    w  <- A.mul freq =<< Value.decons Value.twoPi    kr <- A.mul k =<< A.cos w    ki <- A.mul k =<< A.sin w-   return (Parameter amp (kr,ki))+   return (Parameter amp (kr Complex.+: ki))  -next ::-   (IsArithmetic a, IsConst a) =>+{-+Synthesizer.Plain.Filter.Recursive.FirstOrderComplex.step+cannot be used directly, because Filt1C has complex amplitude+-}+next, _next ::+   (IsArithmetic a, SoV.IntegerConstant a) =>    (Parameter (Value a), Stereo.T (Value a)) ->-   (Value a, Value a) ->-   CodeGenFunction r (Stereo.T (Value a), (Value a, Value a))-next (Parameter amp (kr,ki), x) (sr,si) = do+   Complex.T (Value a) ->+   CodeGenFunction r (Stereo.T (Value a), Complex.T (Value a))+next inp state =+   let stereoFromComplex ::+          Complex.T (Value a) -> Complex.T (Value.T a) ->+          Stereo.T (Value.T a)+       stereoFromComplex _ c =+          Stereo.cons (Complex.real c) (Complex.imag c)+       (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 (stereoFromComplex state 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.Cons (A.mul (Stereo.left x) amp) +-      Value.Cons (A.mul kr sr) - Value.Cons (A.mul ki si)+      Value.lift0 (A.mul (Stereo.left x) amp) ++      Value.lift0 (A.mul kr sr) - Value.lift0 (A.mul ki si)    yi <- Value.decons $-      Value.Cons (A.mul (Stereo.right x) amp) +-      Value.Cons (A.mul kr si) + Value.Cons (A.mul ki sr)-   return (Stereo.cons yr yi, (yr, yi))+      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 ::-   (LLVM.IsType a, IsConst a) =>-   CodeGenFunction r (Value a, Value a)+   (LLVM.IsType a, SoV.IntegerConstant a) =>+   CodeGenFunction r (Complex.T (Value a)) start =-   return (value LLVM.zero, value LLVM.zero)+   return (value LLVM.zero Complex.+: value LLVM.zero)  causal ::-   (IsFirstClass a, IsSized a sa, IsConst a,+   (IsSized a sa, SoV.IntegerConstant a,+    Memory.FirstClass a am, IsSized am amsize,     IsFloating a) =>    Causal.T       (Parameter (Value a), Stereo.T (Value a))@@ -117,7 +172,8 @@    Causal.mapAccum next start  causalP ::-   (IsFirstClass a, IsSized a sa, IsConst a,+   (IsSized a sa, SoV.IntegerConstant a,+    Memory.FirstClass a am, IsSized am amsize,     IsFloating a) =>    CausalP.T p       (Parameter (Value a), Stereo.T (Value a))
src/Synthesizer/LLVM/Filter/ComplexFirstOrderPacked.hs view
@@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE Rank2Types #-} module Synthesizer.LLVM.Filter.ComplexFirstOrderPacked (@@ -13,25 +14,24 @@  import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP import qualified Synthesizer.LLVM.Causal.Process as Causal-import qualified LLVM.Extra.Representation as Rep import qualified Synthesizer.LLVM.Simple.Value as Value-import qualified LLVM.Extra.Vector as Vector  import qualified Synthesizer.LLVM.Frame.Stereo as Stereo +import qualified LLVM.Extra.Memory as Memory+import qualified LLVM.Extra.Vector as Vector import qualified LLVM.Extra.Arithmetic as A+import LLVM.Extra.Class (Undefined, undefTuple, )  import qualified LLVM.Core as LLVM import LLVM.Core    (Value, valueOf, value, Struct,     IsPrimitive, IsConst, IsFloating, IsSized,-    Undefined, undefTuple,     Vector, insertelement,     neg, CodeGenFunction, ) import LLVM.Util.Loop (Phi, phis, addPhis, ) -import Data.TypeLevel.Num (Add, D4, d0, d1, )-import qualified Data.TypeLevel.Num.Sets as Sets+import Data.TypeLevel.Num (D4, d0, d1, )  import Control.Applicative (liftA2, ) @@ -63,30 +63,36 @@    undefTuple = Parameter undefTuple undefTuple  +type ParameterStruct a = Struct (Vector D4 a, (Vector D4 a, ()))+ parameterMemory ::-   (IsPrimitive l, IsSized l s, Add s s s2, Add s2 s s3, Add s3 s s4, Sets.Pos s4) =>-   Rep.MemoryRecord r (Struct (Vector D4 l, (Vector D4 l, ()))) (Parameter l)+   (Memory.FirstClass a am,+    IsPrimitive a, IsPrimitive am) =>+   Memory.Record r (ParameterStruct am) (Parameter a) parameterMemory =    liftA2 Parameter-      (Rep.memoryElement (\(Parameter kr _) -> kr) d0)-      (Rep.memoryElement (\(Parameter _ ki) -> ki) d1)+      (Memory.element (\(Parameter kr _) -> kr) d0)+      (Memory.element (\(Parameter _ ki) -> ki) d1)  {- The complicated Add constraints are caused by the IsType superclass of Memory.  instance (IsPrimitive l, IsSized (Vector D4 l) ss) =>-      Rep.Memory (Parameter l) (Struct (Vector D4 l, (Vector D4 l, ()))) where+      Memory.C (Parameter l) (Struct (Vector D4 l, (Vector D4 l, ()))) where  Mul constraint seems to be not enough, GHC urges to give constraints in terms of Add instance (IsPrimitive l, IsSized l s, Mul D4 s ss, Sets.Pos ss) =>-      Rep.Memory (Parameter l) (Struct (Vector D4 l, (Vector D4 l, ()))) where+      Memory.C (Parameter l) (Struct (Vector D4 l, (Vector D4 l, ()))) where -}-instance (IsPrimitive l, IsSized l s, Add s s s2, Add s2 s s3, Add s3 s s4, Sets.Pos s4) =>-      Rep.Memory (Parameter l) (Struct (Vector D4 l, (Vector D4 l, ()))) where-   load = Rep.loadRecord parameterMemory-   store = Rep.storeRecord parameterMemory-   decompose = Rep.decomposeRecord parameterMemory-   compose = Rep.composeRecord parameterMemory+instance+   (Memory.FirstClass a am,+    IsPrimitive a, IsPrimitive am,+    IsSized (ParameterStruct am) s) =>+      Memory.C (Parameter a) (ParameterStruct am) where+   load = Memory.loadRecord parameterMemory+   store = Memory.storeRecord parameterMemory+   decompose = Memory.decomposeRecord parameterMemory+   compose = Memory.composeRecord parameterMemory  parameter ::    (Trans.C a,@@ -104,6 +110,9 @@    kvi <- Vector.assemble [ki,kr, amp, value LLVM.zero]    return (Parameter kvr kvi) ++type State a = Vector D4 a+ {- The handling of Vector D2 Float in LLVM-2.5 and LLVM-2.6 is at least unexpected. Because of compatibility reasons, LLVM chooses MMX registers@@ -116,8 +125,8 @@ next ::    (Vector.Arithmetic a, IsConst a) =>    (Parameter a, Stereo.T (Value a)) ->-   (Value (Vector D4 a)) ->-   CodeGenFunction r (Stereo.T (Value a), (Value (Vector D4 a)))+   (Value (State a)) ->+   CodeGenFunction r (Stereo.T (Value a), (Value (State a))) next (Parameter kr ki, x) s = do    sr <- insertelement s (Stereo.left  x) (valueOf 2)    yr <- Vector.dotProduct kr sr@@ -130,13 +139,21 @@  start ::    (IsPrimitive a, IsConst a) =>-   CodeGenFunction r (Value (Vector D4 a))+   CodeGenFunction r (Value (State a)) start =    return (value LLVM.zero)  causal ::    (IsConst a, Vector.Arithmetic a,-    IsSized (Vector D4 a) as) =>+    Memory.C (Value (State a)) struct, IsSized struct size) =>+{-+   (IsConst a, Vector.Arithmetic a,+    Memory.FirstClass a am,+    IsPrimitive am,+    IsSized am s, Add s s s2, Add s2 s s3, Add s3 s s4, Sets.Pos s4,+    IsSized (State a) vasize,+    IsSized (State am) vamsize) =>+-}    Causal.T       (Parameter a, Stereo.T (Value a))       (Stereo.T (Value a))@@ -145,7 +162,15 @@  causalP ::    (IsConst a, Vector.Arithmetic a,-    IsSized (Vector D4 a) as) =>+    Memory.C (Value (State a)) struct, IsSized struct size) =>+{-+   (IsConst a, Vector.Arithmetic a,+    Memory.FirstClass a am,+    IsPrimitive am,+    IsSized am s, Add s s s2, Add s2 s s3, Add s3 s s4, Sets.Pos s4,+    IsSized (State a) vasize,+    IsSized (State am) vamsize) =>+-}    CausalP.T p       (Parameter a, Stereo.T (Value a))       (Stereo.T (Value a))
src/Synthesizer/LLVM/Filter/FirstOrder.hs view
@@ -16,24 +16,27 @@  import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as FirstOrder import Synthesizer.Plain.Filter.Recursive.FirstOrder-          (Parameter(Parameter), Result(Result,lowpass_,highpass_))+          (Parameter(Parameter), Result(Result))  import qualified Synthesizer.Plain.Modifier as Modifier  import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP-import qualified LLVM.Extra.Representation as Rep+import qualified Synthesizer.LLVM.Simple.Value as Value+import qualified LLVM.Extra.Memory as Memory import qualified LLVM.Extra.ScalarOrVector as SoV import qualified LLVM.Extra.Vector as Vector-import qualified Synthesizer.LLVM.Simple.Value as Value  import qualified LLVM.Extra.Class as Class import qualified LLVM.Extra.Arithmetic as A+import LLVM.Extra.Class (Undefined, undefTuple, ) +import qualified Data.TypeLevel.Num as TypeNum+ import qualified LLVM.Core as LLVM import LLVM.Core-   (Value, valueOf, Vector, Undefined, undefTuple,-    IsFirstClass, IsConst, IsArithmetic, IsFloating,-    IsPrimitive, IsPowerOf2, IsSized,+   (Value, valueOf, Vector,+    IsArithmetic, IsFloating,+    IsPrimitive, IsSized,     CodeGenFunction, ) import LLVM.Util.Loop (Phi, phis, addPhis, ) @@ -42,8 +45,8 @@  import qualified Algebra.Transcendental as Trans -- import qualified Algebra.Field as Field-import qualified Algebra.Module as Module-import qualified Algebra.Ring as Ring+-- import qualified Algebra.Module as Module+-- import qualified Algebra.Ring as Ring  import NumericPrelude.Numeric import NumericPrelude.Base@@ -57,31 +60,33 @@    undefTuple = Class.undefTuplePointed  instance-      (Rep.Memory a s, IsSized s ss) =>-      Rep.Memory (Parameter a) s where-   load = Rep.loadNewtype Parameter-   store = Rep.storeNewtype (\(Parameter k) -> k)-   decompose = Rep.decomposeNewtype Parameter-   compose = Rep.composeNewtype (\(Parameter k) -> k)+      (Memory.C a s, IsSized s ss) =>+      Memory.C (Parameter a) s where+   load = Memory.loadNewtype Parameter+   store = Memory.storeNewtype (\(Parameter k) -> k)+   decompose = Memory.decomposeNewtype Parameter+   compose = Memory.composeNewtype (\(Parameter k) -> k)  instance (Value.Flatten ah al) =>       Value.Flatten (Parameter ah) (Parameter al) where    flatten = Value.flattenTraversable    unfold =  Value.unfoldFunctor +{- instance LLVM.ValueTuple a => LLVM.ValueTuple (Parameter a) where    buildTuple f = Class.buildTupleTraversable (LLVM.buildTuple f)  instance LLVM.IsTuple a => LLVM.IsTuple (Parameter a) where    tupleDesc = Class.tupleDescFoldable+-} -instance (LLVM.MakeValueTuple ah al) =>-      LLVM.MakeValueTuple (Parameter ah) (Parameter al) where+instance (Class.MakeValueTuple ah al) =>+      Class.MakeValueTuple (Parameter ah) (Parameter al) where    valueTupleOf = Class.valueTupleOfFunctor   parameter ::-   (Trans.C a, IsConst a, IsFloating a) =>+   (Trans.C a, SoV.RationalConstant a, IsFloating a) =>    Value a ->    CodeGenFunction r (Parameter (Value a)) parameter reson =@@ -91,7 +96,7 @@   lowpassModifier, highpassModifier ::-   (Module.C (Value.T a) (Value.T v), IsArithmetic a, IsConst a) =>+   (SoV.PseudoModule a v, SoV.IntegerConstant a) =>    Modifier.Simple --      (FirstOrder.State (Value.T v))       (Value.T v)@@ -101,9 +106,9 @@ highpassModifier = FirstOrder.highpassModifier  causalP ::-   (Ring.C a, Module.C (Value.T a) (Value.T v),-    IsFirstClass a, IsSized a as, IsConst a, IsArithmetic a,-    IsFirstClass v, IsSized v vs, IsConst v, IsArithmetic v) =>+   (SoV.IntegerConstant a, SoV.PseudoModule a v,+    Memory.FirstClass a am, IsSized a as, IsSized am ams,+    Memory.FirstClass v vm, IsSized v vs, IsSized vm vms) =>    CausalP.T p       (Parameter (Value a), Value v) (Result (Value v)) {-@@ -118,31 +123,28 @@     <<< (lowpassCausalP &&& arr snd)  lowpassCausalP, highpassCausalP ::-   (Ring.C a, Module.C (Value.T a) (Value.T v),-    IsFirstClass a, IsSized a as, IsConst a,-    IsFirstClass v, IsSized v vs, IsConst v,-    IsArithmetic a) =>+   (SoV.IntegerConstant a, SoV.PseudoModule a v,+    Memory.FirstClass a am, IsSized a as, IsSized am ams,+    Memory.FirstClass v vm, IsSized v vs, IsSized vm vms) =>    CausalP.T p       (Parameter (Value a), Value v) (Value v) lowpassCausalP  = CausalP.fromModifier lowpassModifier highpassCausalP = CausalP.fromModifier highpassModifier  lowpassCausalPackedP, highpassCausalPackedP, causalRecursivePackedP ::-   (Ring.C a,-    IsFirstClass a, IsConst a, IsSized a as,-    IsPowerOf2 n, -- IsSized (Vector n a) vas,-    IsArithmetic a, IsPrimitive a) =>+   (Memory.FirstClass a am, IsSized a as, IsSized am ams,+    TypeNum.Pos n, -- IsSized (Vector n a) vas,+    SoV.IntegerConstant a, IsArithmetic a, IsPrimitive a) =>    CausalP.T p       (Parameter (Value a), Value (Vector n a)) (Value (Vector n a)) highpassCausalPackedP =-   CausalP.mapSimple (uncurry A.sub) <<<-   (arr snd &&& lowpassCausalPackedP)+   arr snd - lowpassCausalPackedP lowpassCausalPackedP =    causalRecursivePackedP <<<    (arr fst &&&     CausalP.mapSimple        (\(FirstOrder.Parameter k, x) ->-          A.mul x =<< SoV.replicate =<< A.sub (valueOf 1) k))+          A.mul x =<< SoV.replicate =<< A.sub (A.fromInteger' 1) k))  {- x = [x0, x1, x2, x3]@@ -235,9 +237,9 @@   causalPackedP ::-   (Ring.C a, IsArithmetic a, IsPrimitive a,-    IsFirstClass a, IsConst a, IsSized a as,-    IsPowerOf2 n) =>+   (SoV.IntegerConstant a, IsArithmetic a, IsPrimitive a,+    Memory.FirstClass a am, IsSized a as, IsSized am ams,+    TypeNum.Pos n) =>    CausalP.T p       (Parameter (Value a), Value (Vector n a))       (Result (Value (Vector n a)))
src/Synthesizer/LLVM/Filter/Moog.hs view
@@ -21,15 +21,15 @@  import Foreign.Storable (Storable, ) -import qualified LLVM.Extra.Representation as Rep-import qualified LLVM.Extra.Class as Class+import qualified LLVM.Extra.ScalarOrVector as SoV import qualified LLVM.Extra.Vector as Vector+import qualified LLVM.Extra.Memory as Memory+import qualified LLVM.Extra.Class as Class+import LLVM.Extra.Class (Undefined, undefTuple, ) -import qualified LLVM.Core as LLVM import LLVM.Core    (valueOf, Value, Struct,-    IsFirstClass, IsConst, IsArithmetic, IsFloating, IsSized,-    Undefined, undefTuple,+    IsConst, IsFloating, IsSized,     CodeGenFunction, ) import LLVM.Util.Loop (Phi, phis, addPhis, ) @@ -40,13 +40,13 @@ import qualified Control.Applicative as App import qualified Data.Foldable as Fold import qualified Data.Traversable as Trav-import Control.Arrow ((>>>), (&&&), arr, )+import Control.Arrow ((>>>), (&&&), ) import Control.Applicative (liftA2, )  import qualified Algebra.Transcendental as Trans -- import qualified Algebra.Field as Field-import qualified Algebra.Module as Module-import qualified Algebra.Ring as Ring+-- import qualified Algebra.Module as Module+import qualified Algebra.Additive as Additive  import NumericPrelude.Numeric import NumericPrelude.Base@@ -70,20 +70,20 @@    zeroTuple = Class.zeroTuplePointed  parameterMemory ::-   (Rep.Memory a s, IsSized s ss, TypeNum.Nat n) =>-   Rep.MemoryRecord r (Struct (s, (s, ()))) (Parameter n a)+   (Memory.C a s, IsSized s ss, TypeNum.Nat n) =>+   Memory.Record r (Struct (s, (s, ()))) (Parameter n a) parameterMemory =    liftA2 (\f k -> Parameter (Moog.Parameter f k))-      (Rep.memoryElement (Moog.feedback     . getParam) d0)-      (Rep.memoryElement (Moog.lowpassParam . getParam) d1)+      (Memory.element (Moog.feedback     . getParam) d0)+      (Memory.element (Moog.lowpassParam . getParam) d1)  instance-      (Rep.Memory a s, IsSized s ss, TypeNum.Nat n) =>-      Rep.Memory (Parameter n a) (Struct (s, (s, ()))) where-   load = Rep.loadRecord parameterMemory-   store = Rep.storeRecord parameterMemory-   decompose = Rep.decomposeRecord parameterMemory-   compose = Rep.composeRecord parameterMemory+      (Memory.C a s, IsSized s ss, TypeNum.Nat n) =>+      Memory.C (Parameter n a) (Struct (s, (s, ()))) where+   load = Memory.loadRecord parameterMemory+   store = Memory.storeRecord parameterMemory+   decompose = Memory.decomposeRecord parameterMemory+   compose = Memory.composeRecord parameterMemory   instance (Value.Flatten ah al, TypeNum.Nat n) =>@@ -103,7 +103,7 @@   parameter ::-   (Trans.C a, IsConst a, IsFloating a, TypeNum.Nat n) =>+   (Trans.C a, SoV.RationalConstant a, IsFloating a, TypeNum.Nat n) =>    n -> Value a -> Value a ->    CodeGenFunction r (Parameter n (Value a)) parameter order reson freq =@@ -128,18 +128,18 @@ -}  merge ::-   (Module.C (Value.T a) (Value.T v),-    LLVM.MakeValueTuple v (Value v), IsConst v,-    LLVM.MakeValueTuple a (Value a), IsConst a) =>+   (SoV.PseudoModule a v, SoV.IntegerConstant a,+    Class.MakeValueTuple v (Value v),+    Class.MakeValueTuple a (Value a)) =>    (Parameter n (Value a), Value v) -> Value v ->    CodeGenFunction r (FirstOrder.Parameter (Value a), Value v) merge (Parameter (Moog.Parameter f k), x) y0 =-   let c :: (LLVM.MakeValueTuple a (Value a)) => Value a -> Value.T a+   let c :: (Class.MakeValueTuple a (Value a)) => Value a -> Value.T a        c = Value.constantValue    in  Value.flatten (fmap c k, c x - c f *> c y0)  amplify ::-   (Module.C (Value.T a) (Value.T v)) =>+   (SoV.PseudoModule a v, SoV.IntegerConstant a) =>    Parameter n (Value a) ->    Value v ->    CodeGenFunction r (Value v)@@ -148,12 +148,13 @@    (1 + Value.constantValue f) *> Value.constantValue y1  causalP ::-   (Module.C (Value.T a) (Value.T v),-    Module.C a v, Storable v,-    LLVM.MakeValueTuple v (Value v),-    LLVM.MakeValueTuple a (Value a),-    IsFirstClass a, IsSized a as, IsConst a, IsArithmetic a,-    IsFirstClass v, IsSized v vs, IsConst v,+   (SoV.PseudoModule a v, SoV.IntegerConstant a,+    IsConst v, Additive.C v,+    Storable v,+    Class.MakeValueTuple v (Value v),+    Class.MakeValueTuple a (Value a),+    Memory.FirstClass a am, IsSized a as, IsSized am ams,+    Memory.FirstClass v vm, IsSized v vs, IsSized vm vms,     TypeNum.Nat n) =>    CausalP.T p       (Parameter n (Value a), Value v) (Value v)@@ -161,12 +162,13 @@    causalPSize undefined  causalPSize ::-   (Module.C (Value.T a) (Value.T v),-    Module.C a v, Storable v,-    LLVM.MakeValueTuple v (Value v),-    LLVM.MakeValueTuple a (Value a),-    IsFirstClass a, IsSized a as, IsConst a, IsArithmetic a,-    IsFirstClass v, IsSized v vs, IsConst v,+   (SoV.PseudoModule a v, SoV.IntegerConstant a,+    IsConst v, Additive.C v,+    Storable v,+    Class.MakeValueTuple v (Value v),+    Class.MakeValueTuple a (Value a),+    Memory.FirstClass a am, IsSized a as, IsSized am ams,+    Memory.FirstClass v vm, IsSized v vs, IsSized vm vms,     TypeNum.Nat n) =>    n ->    CausalP.T p@@ -178,7 +180,7 @@    in  Arrow.arr fst &&&        CausalP.feedbackControlled           (return feedZero)-          (CausalP.mapSimple (uncurry merge) >>>+          (CausalP.zipWithSimple merge >>>            CausalP.replicateControlled order Filt1.lowpassCausalP)           (Arrow.arr selectOutput)-        >>> CausalP.mapSimple (uncurry amplify)+        >>> CausalP.zipWithSimple amplify
src/Synthesizer/LLVM/Filter/SecondOrder.hs view
@@ -6,7 +6,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Synthesizer.LLVM.Filter.SecondOrder (    Parameter, bandpassParameter,-   ParameterStruct, -- for cascade+   ParameterStruct, composeParameter, decomposeParameter, -- for cascade    causalP, causalPackedP,    ) where @@ -18,19 +18,20 @@ import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP import qualified Synthesizer.LLVM.Simple.Value as Value -import qualified LLVM.Extra.Representation as Rep+import qualified LLVM.Extra.Memory as Memory import qualified LLVM.Extra.ScalarOrVector as SoV import qualified LLVM.Extra.Vector as Vector  import qualified LLVM.Extra.Class as Class import qualified LLVM.Extra.Arithmetic as A import qualified LLVM.Extra.Monad as M+import LLVM.Extra.Class (Undefined, undefTuple, )  import qualified LLVM.Core as LLVM import LLVM.Core-   (Value, valueOf, Struct, Undefined, undefTuple,-    IsFirstClass, IsConst, IsArithmetic, IsFloating,-    Vector, IsPowerOf2, IsPrimitive, IsSized,+   (Value, valueOf, Struct,+    IsConst, IsArithmetic, IsFloating,+    Vector, IsPrimitive, IsSized,     CodeGenFunction, ) import LLVM.Util.Loop (Phi, phis, addPhis, ) @@ -39,12 +40,13 @@  import Control.Arrow (arr, (<<<), (&&&), ) import Control.Monad (liftM2, foldM, )+import Control.Applicative (pure, (<*>), ) import Synthesizer.ApplicativeUtility (liftA4, liftA5, )  import qualified Algebra.Transcendental as Trans -- import qualified Algebra.Field as Field-import qualified Algebra.Module as Module-import qualified Algebra.Ring as Ring+-- import qualified Algebra.Module as Module+-- import qualified Algebra.Ring as Ring  import NumericPrelude.Numeric import NumericPrelude.Base@@ -57,37 +59,62 @@ instance Undefined a => Undefined (Parameter a) where    undefTuple = Class.undefTuplePointed +{- instance LLVM.ValueTuple a => LLVM.ValueTuple (Parameter a) where    buildTuple f = Class.buildTupleTraversable (LLVM.buildTuple f)  instance LLVM.IsTuple a => LLVM.IsTuple (Parameter a) where    tupleDesc = Class.tupleDescFoldable+-} -instance LLVM.MakeValueTuple h l =>-      LLVM.MakeValueTuple (Parameter h) (Parameter l) where+instance Class.MakeValueTuple h l =>+      Class.MakeValueTuple (Parameter h) (Parameter l) where    valueTupleOf = Class.valueTupleOfFunctor   type ParameterStruct a = Struct (a, (a, (a, (a, (a, ())))))  parameterMemory ::-   (Rep.Memory a s, IsSized s ss) =>-   Rep.MemoryRecord r (ParameterStruct s) (Parameter a)+   (Memory.C a s, IsSized s ss) =>+   Memory.Record r (ParameterStruct s) (Parameter a) parameterMemory =    liftA5 Parameter-      (Rep.memoryElement Filt2.c0 d0)-      (Rep.memoryElement Filt2.c1 d1)-      (Rep.memoryElement Filt2.c2 d2)-      (Rep.memoryElement Filt2.d1 d3)-      (Rep.memoryElement Filt2.d2 d4)+      (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 ::+   Value (ParameterStruct a) ->+   CodeGenFunction r (Filt2.Parameter (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++composeParameter ::+   (IsSized a size) =>+   Filt2.Parameter (Value a) ->+   CodeGenFunction r (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)+ instance-      (Rep.Memory a s, IsSized s ss) =>-      Rep.Memory (Parameter a) (Struct (s, (s, (s, (s, (s, ())))))) where-   load = Rep.loadRecord parameterMemory-   store = Rep.storeRecord parameterMemory-   decompose = Rep.decomposeRecord parameterMemory-   compose = Rep.composeRecord parameterMemory+      (Memory.C a s, IsSized s ss) =>+      Memory.C (Parameter a) (Struct (s, (s, (s, (s, (s, ())))))) where+   load = Memory.loadRecord parameterMemory+   store = Memory.storeRecord parameterMemory+   decompose = Memory.decomposeRecord parameterMemory+   compose = Memory.composeRecord parameterMemory   instance (Value.Flatten ah al) =>@@ -105,23 +132,23 @@    undefTuple = Class.undefTuplePointed  stateMemory ::-   (Rep.Memory a s, IsSized s ss) =>-   Rep.MemoryRecord r (Struct (s, (s, (s, (s, (s, ())))))) (Filt2.State a)+   (Memory.C a s, IsSized s ss) =>+   Memory.Record r (Struct (s, (s, (s, (s, (s, ())))))) (Filt2.State a) stateMemory =    liftA4 Filt2.State-      (Rep.memoryElement Filt2.u1 d0)-      (Rep.memoryElement Filt2.u2 d1)-      (Rep.memoryElement Filt2.y1 d2)-      (Rep.memoryElement Filt2.y2 d3)+      (Memory.element Filt2.u1 d0)+      (Memory.element Filt2.u2 d1)+      (Memory.element Filt2.y1 d2)+      (Memory.element Filt2.y2 d3)   instance-      (Rep.Memory a s, IsSized s ss) =>-      Rep.Memory (Filt2.State a) (Struct (s, (s, (s, (s, (s, ())))))) where-   load = Rep.loadRecord stateMemory-   store = Rep.storeRecord stateMemory-   decompose = Rep.decomposeRecord stateMemory-   compose = Rep.composeRecord stateMemory+      (Memory.C a s, IsSized s ss) =>+      Memory.C (Filt2.State a) (Struct (s, (s, (s, (s, (s, ())))))) where+   load = Memory.loadRecord stateMemory+   store = Memory.storeRecord stateMemory+   decompose = Memory.decomposeRecord stateMemory+   compose = Memory.composeRecord stateMemory  instance (Value.Flatten ah al) =>       Value.Flatten (Filt2.State ah) (Filt2.State al) where@@ -149,7 +176,7 @@          kcos k2  modifier ::-   (Module.C (Value.T a) (Value.T v), IsArithmetic a, IsConst a) =>+   (SoV.PseudoModule a v, SoV.IntegerConstant a) =>    Modifier.Simple       (Filt2.State (Value.T v))       (Parameter (Value.T a))@@ -158,10 +185,9 @@    Filt2.modifier  causalP ::-   (Ring.C a, Module.C (Value.T a) (Value.T v),-    IsFirstClass a, IsSized a as, IsConst a,-    IsFirstClass v, IsSized v vs, IsConst v,-    IsArithmetic a) =>+   (SoV.PseudoModule a v, SoV.IntegerConstant a,+    Memory.FirstClass a am, IsSized a as, IsSized am ams,+    Memory.FirstClass v vm, IsSized v vs, IsSized vm vms) =>    CausalP.T p       (Parameter (Value a), Value v) (Value v) causalP =@@ -173,11 +199,14 @@ -} causalPackedP,   causalRecursivePackedP ::-   (Ring.C a,-    IsFirstClass a, IsArithmetic a, IsConst a,-    IsPowerOf2 n, IsPrimitive a, IsSized a as,-    TypeNum.Mul n as vas, TypeNum.Pos vas) =>---    IsPowerOf2 n, IsPrimitive a, IsSized (Vector n a) as) =>+   (IsArithmetic a, SoV.IntegerConstant a,+    Memory.FirstClass a am,+    IsPrimitive a,  IsSized a asize,+    IsPrimitive am, IsSized am amsize,+    TypeNum.Mul n asize vasize, TypeNum.Pos vasize,+    TypeNum.Mul n amsize vmsize, TypeNum.Pos vmsize,+    TypeNum.Pos n) =>+--    TypeNum.Pos n, IsPrimitive a, IsSized (Vector n a) as) =>    CausalP.T p       (Parameter (Value a), Value (Vector n a)) (Value (Vector n a)) causalPackedP =@@ -186,9 +215,13 @@  _causalRecursivePackedPAlt,   causalNonRecursivePackedP ::-   (Ring.C a,-    IsFirstClass a, IsArithmetic a, IsConst a,-    IsPowerOf2 n, IsPrimitive a, IsSized a as) =>+   (IsArithmetic a, SoV.IntegerConstant a,+    Memory.FirstClass a am,+    IsPrimitive a,  IsSized a asize,+    IsPrimitive am, IsSized am amsize,+    TypeNum.Mul n asize vasize, TypeNum.Pos vasize,+    TypeNum.Mul n amsize vmsize, TypeNum.Pos vmsize,+    TypeNum.Pos n) =>    CausalP.T p       (Parameter (Value a), Value (Vector n a)) (Value (Vector n a)) causalNonRecursivePackedP =@@ -273,7 +306,7 @@                   liftM2 (,)                      (M.liftR2 A.sub                          (A.mul a a)-                         (A.mul b (SoV.replicateOf 2)))+                         (A.mul b (A.fromInteger' 2)))                      (A.mul b b))                (xk1,(d1v,d2vn))                (takeWhile (< size) $ iterate (2*) 1)@@ -310,7 +343,7 @@                   liftM2 (,)                      (M.liftR2 A.sub                          (A.mul a a)-                         (A.mul b (SoV.replicateOf 2)))+                         (A.mul b (A.fromInteger' 2)))                      (A.mul b b))                (xk1,(d1v,d2v))                (takeWhile (< size) $ iterate (2*) 1)
src/Synthesizer/LLVM/Filter/SecondOrderCascade.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeSynonymInstances #-} module Synthesizer.LLVM.Filter.SecondOrderCascade where@@ -9,16 +10,17 @@ import qualified Synthesizer.Plain.Filter.Recursive.SecondOrder as Filt2Core  import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP-import qualified LLVM.Extra.Representation as Rep-import qualified Synthesizer.LLVM.Simple.Value as Value  import qualified LLVM.Extra.Class as Class+import qualified LLVM.Extra.ScalarOrVector as SoV+import qualified LLVM.Extra.Memory as Memory+import LLVM.Extra.Class (Undefined, undefTuple, )  import qualified LLVM.Core as LLVM import LLVM.Util.Loop (Phi, phis, addPhis, ) import LLVM.Core    (Value, valueOf, Vector,-    IsPowerOf2, IsConst, IsArithmetic, IsPrimitive, IsFirstClass, IsSized,+    IsArithmetic, IsPrimitive, IsSized,     CodeGenFunction, )  import qualified Data.TypeLevel.Num      as TypeNum@@ -31,8 +33,8 @@  -- import qualified Algebra.Transcendental as Trans -- import qualified Algebra.Field as Field-import qualified Algebra.Module as Module-import qualified Algebra.Ring as Ring+-- import qualified Algebra.Module as Module+-- import qualified Algebra.Ring as Ring  import NumericPrelude.Numeric import NumericPrelude.Base@@ -47,7 +49,7 @@ because of IsSized constraint and it would also be wrong for Functor and friends.       deriving-         (Phi, LLVM.Undefined, Class.Zero,+         (Phi, Class.Undefined, Class.Zero,           Functor, App.Applicative, Fold.Foldable, Trav.Traversable) -} @@ -61,20 +63,20 @@       addPhis bb r r'  instance (TypeNum.Nat n, IsSized a s) =>-      LLVM.Undefined (ParameterValue n a) where-   undefTuple = ParameterValue LLVM.undefTuple+      Class.Undefined (ParameterValue n a) where+   undefTuple = ParameterValue Class.undefTuple  instance (TypeNum.Nat n, IsSized a s) =>       Class.Zero (ParameterValue n a) where    zeroTuple = ParameterValue Class.zeroTuple  instance-      (TypeNum.Nat n, IsSized a s) =>-      Rep.Memory (ParameterValue n a) (Parameter n a) where-   load = Rep.loadNewtype ParameterValue-   store = Rep.storeNewtype (\(ParameterValue k) -> k)-   decompose = Rep.decomposeNewtype ParameterValue-   compose = Rep.composeNewtype (\(ParameterValue k) -> k)+      (TypeNum.Nat n, Memory.FirstClass a am, IsSized a s, IsSized am ams) =>+      Memory.C (ParameterValue n a) (Parameter n am) where+   load = Memory.loadNewtype ParameterValue+   store = Memory.storeNewtype (\(ParameterValue k) -> k)+   decompose = Memory.decomposeNewtype ParameterValue+   compose = Memory.composeNewtype (\(ParameterValue k) -> k)   @@ -90,9 +92,9 @@ fixSize _n = id  causalP ::-   (Ring.C a, Module.C (Value.T a) (Value.T v),-    IsFirstClass a, IsSized a as, IsConst a,-    IsFirstClass v, IsSized v vs, IsConst v,+   (SoV.PseudoModule a v, SoV.IntegerConstant a,+    Memory.FirstClass a am, IsSized a as, IsSized am ams,+    Memory.FirstClass v vm, IsSized v vs, IsSized vm vms,     IsArithmetic a, TypeSet.Nat n,     TypeNum.Mul n LLVM.UnknownSize paramSize, TypeSet.Pos paramSize) =>    CausalP.T p (ParameterValue n a, Value v) (Value v)@@ -107,11 +109,15 @@       (take (TypeNum.toInt n) [0..])  causalPackedP ::-   (Ring.C a,-    IsPrimitive a, IsSized a as, IsConst a,-    IsArithmetic a, TypeSet.Nat n,+   (IsArithmetic a, SoV.IntegerConstant a,+    Memory.FirstClass a am,+    IsPrimitive a,  IsSized a asize,+    IsPrimitive am, IsSized am amsize,+    TypeNum.Mul d asize vasize, TypeNum.Pos vasize,+    TypeNum.Mul d amsize vmsize, TypeNum.Pos vmsize,+    TypeNum.Pos d,     TypeNum.Mul n LLVM.UnknownSize paramSize, TypeSet.Pos paramSize,-    IsPowerOf2 d, TypeNum.Mul d as vas, TypeSet.Pos vas) =>+    TypeSet.Nat n) =>    CausalP.T p       (ParameterValue n a, Value (Vector d a)) (Value (Vector d a)) causalPackedP =@@ -125,14 +131,18 @@       (take (TypeNum.toInt n) [0..])  getStageParameter, getStageParameterMalloc, getStageParameterAlloca ::-   (IsFirstClass a, TypeSet.Nat n, IsSized a sa,-    TypeNum.Mul n LLVM.UnknownSize s, TypeSet.Pos s) =>+   (LLVM.IsFirstClass a, IsSized a as, SoV.IntegerConstant a,+    TypeSet.Nat n, TypeNum.Mul n LLVM.UnknownSize s, TypeSet.Pos s) =>    ParameterValue n a ->    Word32 ->    CodeGenFunction r (Filt2Core.Parameter (Value a)) getStageParameter ps k =-   Rep.decompose =<<-   LLVM.extractvalue (parameterValue ps) k+   Filt2.decomposeParameter =<< LLVM.extractvalue (parameterValue ps) k+{-+   Memory.decompose =<<+   flip LLVM.extractvalue k =<<+   Memory.compose ps+-}  {- Expensive because we need a heap allocation for every sample.@@ -141,7 +151,10 @@ getStageParameterMalloc ps k = do    ptr <- LLVM.malloc    LLVM.store (parameterValue ps) ptr-   p <- Rep.load =<< LLVM.getElementPtr0 ptr (valueOf k, ())+   p <-+      Filt2.decomposeParameter+       =<< LLVM.load+       =<< LLVM.getElementPtr0 ptr (valueOf k, ())    LLVM.free ptr    return p @@ -153,4 +166,6 @@ getStageParameterAlloca ps k = do    ptr <- LLVM.alloca    LLVM.store (parameterValue ps) ptr-   Rep.load =<< LLVM.getElementPtr0 ptr (valueOf k, ())+   Filt2.decomposeParameter+    =<< LLVM.load+    =<< LLVM.getElementPtr0 ptr (valueOf k, ())
src/Synthesizer/LLVM/Filter/SecondOrderPacked.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TypeSynonymInstances #-} module Synthesizer.LLVM.Filter.SecondOrderPacked (    Parameter, bandpassParameter, State, causalP,    ) where@@ -11,27 +12,25 @@ import qualified Synthesizer.Plain.Filter.Recursive.SecondOrder as Filt2  import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP-import qualified LLVM.Extra.Representation as Rep+import qualified LLVM.Extra.Memory as Memory import qualified LLVM.Extra.Vector as Vector- import qualified LLVM.Extra.Arithmetic as A+import LLVM.Extra.Class (Undefined, undefTuple, )  import qualified LLVM.Core as LLVM import LLVM.Core-   (Value, valueOf, Struct, Undefined, undefTuple,+   (Value, valueOf, Struct,     IsFirstClass, IsConst, IsFloating,     Vector, IsPrimitive, IsSized,     CodeGenFunction, ) import LLVM.Util.Loop (Phi, phis, addPhis, ) -import Data.TypeLevel.Num (Add, D4, d0, d1, )-import qualified Data.TypeLevel.Num as TypeNum-import qualified Data.TypeLevel.Num.Sets as Sets+import Data.TypeLevel.Num (D4, d0, d1, )  import Control.Applicative (liftA2, )  import qualified Algebra.Transcendental as Trans-import qualified Algebra.Field as Field+-- import qualified Algebra.Field as Field -- import qualified Algebra.Module as Module -- import qualified Algebra.Ring as Ring @@ -62,22 +61,28 @@    undefTuple = Parameter undefTuple undefTuple  +type ParameterStruct a = Struct (a, (Vector D4 a, ()))+ parameterMemory ::-   (IsPrimitive l, IsFirstClass l, IsSized l s,-    Add s s s2, Add s2 s s3, Add s3 s s4, Sets.Pos s4) =>-   Rep.MemoryRecord r (Struct (l, (Vector D4 l, ()))) (Parameter l)+   (Memory.FirstClass a am,+    IsSized a s, IsPrimitive a,+    IsSized am ams, IsPrimitive am) =>+   Memory.Record r (ParameterStruct am) (Parameter a) parameterMemory =    liftA2 Parameter-      (Rep.memoryElement (\(Parameter c0 _) -> c0) d0)-      (Rep.memoryElement (\(Parameter _ cd) -> cd) d1)+      (Memory.element (\(Parameter c0 _) -> c0) d0)+      (Memory.element (\(Parameter _ cd) -> cd) d1) -instance (IsPrimitive l, IsFirstClass l, IsSized l s,-          Add s s s2, Add s2 s s3, Add s3 s s4, Sets.Pos s4) =>-      Rep.Memory (Parameter l) (Struct (l, (Vector D4 l, ()))) where-   load = Rep.loadRecord parameterMemory-   store = Rep.storeRecord parameterMemory-   decompose = Rep.decomposeRecord parameterMemory-   compose = Rep.composeRecord parameterMemory+instance+   (Memory.FirstClass a am,+    IsSized a s, IsPrimitive a,+    IsSized am ms, IsPrimitive am,+    IsSized (ParameterStruct am) sms) =>+      Memory.C (Parameter a) (ParameterStruct am) where+   load = Memory.loadRecord parameterMemory+   store = Memory.storeRecord parameterMemory+   decompose = Memory.decomposeRecord parameterMemory+   compose = Memory.composeRecord parameterMemory   type State = Vector D4@@ -110,7 +115,17 @@    return (y0, yv)  causalP ::-   (Field.C a, Vector.Arithmetic a, IsSized (State a) as) =>+   (Vector.Arithmetic a,+    Memory.C (Value (State a)) struct, IsSized struct size) =>+{-+   (Vector.Arithmetic a, IsPrimitive am,+    Memory.FirstClass a am,+    IsSized am ams,+    Add ams ams  ams2,+    Add ams ams2 ams3,+    Add ams ams3 ams4,+    Sets.Pos ams4) =>+-}    CausalP.T p       (Parameter a, Value a) (Value a) causalP =
src/Synthesizer/LLVM/Filter/Universal.hs view
@@ -13,8 +13,7 @@  import qualified Synthesizer.Plain.Filter.Recursive.Universal as Universal import Synthesizer.Plain.Filter.Recursive.Universal-          (Parameter(Parameter),-           Result(Result, lowpass, highpass, bandpass, bandlimit))+          (Parameter(Parameter), Result, ) import Synthesizer.Plain.Filter.Recursive (Pole(..))  import qualified Synthesizer.Plain.Modifier as Modifier@@ -22,16 +21,14 @@ import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP import qualified Synthesizer.LLVM.Simple.Value as Value -import qualified LLVM.Extra.Representation as Rep+import qualified LLVM.Extra.Memory as Memory import qualified LLVM.Extra.Class as Class+import qualified LLVM.Extra.ScalarOrVector as SoV import qualified LLVM.Extra.Vector as Vector+import LLVM.Extra.Class (Undefined, undefTuple, ) -import qualified LLVM.Core as LLVM import LLVM.Core-   (Value, Struct,-    IsFirstClass, IsConst, IsArithmetic, IsFloating, IsSized,-    Undefined, undefTuple,-    CodeGenFunction, )+   (Value, Struct, IsFloating, IsSized, CodeGenFunction, ) import LLVM.Util.Loop (Phi, phis, addPhis, )  import Data.TypeLevel.Num (d0, d1, d2, d3, d4, d5, )@@ -39,8 +36,8 @@ import Synthesizer.ApplicativeUtility (liftA6, )  import qualified Algebra.Transcendental as Trans-import qualified Algebra.Field as Field-import qualified Algebra.Module as Module+-- import qualified Algebra.Field as Field+-- import qualified Algebra.Module as Module -- import qualified Algebra.Ring as Ring  @@ -52,35 +49,36 @@    undefTuple = Class.undefTuplePointed  parameterMemory ::-   (Rep.Memory a s, IsSized s ss) =>-   Rep.MemoryRecord r (Struct (s, (s, (s, (s, (s, (s, ()))))))) (Parameter a)+   (Memory.C a s, IsSized s ss) =>+   Memory.Record r (Struct (s, (s, (s, (s, (s, (s, ()))))))) (Parameter a) parameterMemory =    liftA6 Parameter-      (Rep.memoryElement Universal.k1       d0)-      (Rep.memoryElement Universal.k2       d1)-      (Rep.memoryElement Universal.ampIn    d2)-      (Rep.memoryElement Universal.ampI1    d3)-      (Rep.memoryElement Universal.ampI2    d4)-      (Rep.memoryElement Universal.ampLimit d5)+      (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-      (Rep.Memory a s, IsSized s ss) =>-      Rep.Memory (Parameter a) (Struct (s, (s, (s, (s, (s, (s, ()))))))) where-   load = Rep.loadRecord parameterMemory-   store = Rep.storeRecord parameterMemory-   decompose = Rep.decomposeRecord parameterMemory-   compose = Rep.composeRecord parameterMemory-+      (Memory.C a s, IsSized s ss) =>+      Memory.C (Parameter a) (Struct (s, (s, (s, (s, (s, (s, ()))))))) where+   load = Memory.loadRecord parameterMemory+   store = Memory.storeRecord parameterMemory+   decompose = Memory.decomposeRecord parameterMemory+   compose = Memory.composeRecord parameterMemory +{- instance LLVM.ValueTuple a => LLVM.ValueTuple (Result a) where    buildTuple f = Class.buildTupleTraversable (LLVM.buildTuple f)  instance LLVM.IsTuple a => LLVM.IsTuple (Result a) where    tupleDesc = Class.tupleDescFoldable+-} -instance (LLVM.MakeValueTuple ah al) =>-      LLVM.MakeValueTuple (Result ah) (Result al) where+instance (Class.MakeValueTuple ah al) =>+      Class.MakeValueTuple (Result ah) (Result al) where    valueTupleOf = Class.valueTupleOfFunctor  instance (Value.Flatten ah al) =>@@ -89,14 +87,16 @@    unfold =  Value.unfoldFunctor  +{- instance LLVM.ValueTuple a => LLVM.ValueTuple (Parameter a) where    buildTuple f = Class.buildTupleTraversable (LLVM.buildTuple f)  instance LLVM.IsTuple a => LLVM.IsTuple (Parameter a) where    tupleDesc = Class.tupleDescFoldable+-} -instance (LLVM.MakeValueTuple ah al) =>-      LLVM.MakeValueTuple (Parameter ah) (Parameter al) where+instance (Class.MakeValueTuple ah al) =>+      Class.MakeValueTuple (Parameter ah) (Parameter al) where    valueTupleOf = Class.valueTupleOfFunctor  instance (Value.Flatten ah al) =>@@ -133,7 +133,7 @@   parameter ::-   (Trans.C a, IsConst a, IsFloating a) =>+   (Trans.C a, SoV.RationalConstant a, IsFloating a) =>    Value a -> Value a ->    CodeGenFunction r (Parameter (Value a)) parameter reson freq =@@ -144,7 +144,7 @@   modifier ::-   (Module.C (Value.T a) (Value.T v), IsArithmetic a, IsConst a) =>+   (SoV.PseudoModule a v, SoV.IntegerConstant a) =>    Modifier.Simple       (Universal.State (Value.T v))       (Parameter (Value.T a))@@ -153,11 +153,23 @@    Universal.modifier  causalP ::-   (Field.C a, Module.C (Value.T a) (Value.T v),-    IsFirstClass a, IsSized a as, IsConst a,-    IsFirstClass v, IsSized v vs, IsConst v,-    IsArithmetic a) =>+   (SoV.PseudoModule a v, SoV.IntegerConstant a,+    Memory.FirstClass a am, IsSized a as, IsSized am ams,+    Memory.FirstClass v vm, IsSized v vs, IsSized vm vms) =>    CausalP.T p       (Parameter (Value a), Value v) (Result (Value v)) causalP =    CausalP.fromModifier 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/Frame.hs view
@@ -0,0 +1,156 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+module Synthesizer.LLVM.Frame where++import qualified Synthesizer.LLVM.Frame.Stereo as Stereo++import qualified LLVM.Extra.ScalarOrVector as SoV+import qualified LLVM.Extra.Vector as Vector+import qualified LLVM.Extra.Class as Class+import qualified LLVM.Extra.Control as C+import qualified LLVM.Extra.Arithmetic as A++import qualified LLVM.Core as LLVM+import LLVM.Core+          (CodeGenFunction, Value, Vector,+           IsPrimitive, IsArithmetic, )++import qualified Data.TypeLevel.Num as TypeNum+import Data.TypeLevel.Num (D2, D4, )++import Foreign.Storable.Tuple ()++import Data.Word (Word32, )++import qualified Data.Traversable as Trav++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 . listFromStereo+++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 listFromStereo . listFromStereo++listFromStereo :: Stereo.T a -> [a]+listFromStereo s =+   [Stereo.left s, Stereo.right s]+++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.Pos n) =>+   Value (Vector n a) ->+   CodeGenFunction r (Value a)+mixVector = Vector.sum++mixVectorToStereo ::+   (Vector.Arithmetic a, TypeNum.Pos 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.Pos 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)+++subsampleVector ::+   (Vector.Access n a v) =>+   v -> CodeGenFunction r a+subsampleVector =+   Vector.extract (LLVM.value LLVM.zero :: Value Word32)+++signum ::+   (SoV.IntegerConstant a,+    LLVM.IsFirstClass a,+    LLVM.CmpRet a Bool) =>+   Value a -> CodeGenFunction r (Value a)+signum x = do+   negative <- A.cmp LLVM.CmpLT x Class.zeroTuple+   positive <- A.cmp LLVM.CmpGT x Class.zeroTuple+   C.select negative (A.fromInteger' (-1))+      =<< C.select positive (A.fromInteger' 1) (A.fromInteger' 0)
src/Synthesizer/LLVM/Frame/Stereo.hs view
@@ -20,24 +20,22 @@  import qualified Synthesizer.Frame.Stereo as Stereo +import qualified LLVM.Extra.Arithmetic as A import qualified LLVM.Extra.Class as Class+import qualified LLVM.Extra.Memory as Memory+import qualified LLVM.Extra.Control as C+import qualified LLVM.Extra.Vector as Vector import qualified LLVM.Core as LLVM-import LLVM.Core-   (ValueTuple, buildTuple,-    Undefined, undefTuple,-    IsTuple, tupleDesc,-    MakeValueTuple, valueTupleOf,-    Struct, IsSized, )+import LLVM.Extra.Class+   (Undefined, undefTuple,+    MakeValueTuple, valueTupleOf, ) import LLVM.Util.Loop (Phi, phis, addPhis, ) -import qualified LLVM.Extra.Representation as Rep-import qualified LLVM.Extra.Control as C-import qualified LLVM.Extra.Vector as Vector import Data.TypeLevel.Num (d0, d1, )  import Control.Monad (liftM2, ) import Control.Applicative (liftA2, )-import qualified Control.Applicative as App+import qualified Data.Traversable as Trav   -- if it turns out to be useful, we may move it to sample-frame package@@ -51,29 +49,33 @@ instance (Class.Zero a) => Class.Zero (Stereo.T a) where    zeroTuple = Stereo.cons Class.zeroTuple Class.zeroTuple -instance ValueTuple a => ValueTuple (Stereo.T a) where-   buildTuple f =-      liftM2 Stereo.cons (buildTuple f) (buildTuple f)- instance (Undefined a) => Undefined (Stereo.T a) where    undefTuple = Stereo.cons undefTuple undefTuple  instance (C.Select a) => C.Select (Stereo.T a) where    select = C.selectTraversable +{- instance LLVM.CmpRet a b => LLVM.CmpRet (Stereo.T a) (Stereo.T b) where+-}  instance MakeValueTuple h l =>       MakeValueTuple (Stereo.T h) (Stereo.T l) where    valueTupleOf s =       Stereo.cons-         (LLVM.valueTupleOf $ Stereo.left s)-         (LLVM.valueTupleOf $ Stereo.right s)+         (Class.valueTupleOf $ Stereo.left s)+         (Class.valueTupleOf $ Stereo.right s) +{-+instance ValueTuple a => ValueTuple (Stereo.T a) where+   buildTuple f =+      liftM2 Stereo.cons (buildTuple f) (buildTuple f)+ instance IsTuple a => IsTuple (Stereo.T a) where    tupleDesc s =       tupleDesc (Stereo.left s) ++       tupleDesc (Stereo.right s)+-}  instance (Phi a) => Phi (Stereo.T a) where    phis bb v =@@ -94,26 +96,26 @@   memory ::-   (Rep.Memory l s, IsSized s ss) =>-   Rep.MemoryRecord r (Struct (s, (s, ()))) (Stereo.T l)+   (Memory.C l s, LLVM.IsSized s ss) =>+   Memory.Record r (LLVM.Struct (s, (s, ()))) (Stereo.T l) memory =    liftA2 Stereo.cons-      (Rep.memoryElement Stereo.left  d0)-      (Rep.memoryElement Stereo.right d1)+      (Memory.element Stereo.left  d0)+      (Memory.element Stereo.right d1)  instance-      (Rep.Memory l s, IsSized s ss) =>-      Rep.Memory (Stereo.T l) (Struct (s, (s, ()))) where-   load = Rep.loadRecord memory-   store = Rep.storeRecord memory-   decompose = Rep.decomposeRecord memory-   compose = Rep.composeRecord memory+      (Memory.C l s, LLVM.IsSized s ss) =>+      Memory.C (Stereo.T l) (LLVM.Struct (s, (s, ()))) where+   load = Memory.loadRecord memory+   store = Memory.storeRecord memory+   decompose = Memory.decomposeRecord memory+   compose = Memory.composeRecord memory   {- instance-      (Memory l s, IsSized s ss) =>-      Memory (Stereo.T l) (Struct (s, (s, ()))) where+      (Memory l s, LLVM.IsSized s ss) =>+      Memory (Stereo.T l) (LLVM.Struct (s, (s, ()))) where    load ptr =       liftM2 Stereo.cons          (load =<< getElementPtr0 ptr (d0, ()))@@ -122,3 +124,9 @@       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 = Trav.sequence $ liftA2 A.add x y+   sub x y = Trav.sequence $ liftA2 A.sub x y+   neg x   = Trav.sequence $ fmap A.neg x
+ src/Synthesizer/LLVM/Frame/StereoInterleaved.hs view
@@ -0,0 +1,227 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# 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.StereoInterleaved (+   T,+   Value,+   interleave,+   deinterleave,+   ) where++import qualified Synthesizer.LLVM.Frame.Stereo as Stereo++import qualified LLVM.Extra.Arithmetic as A+import qualified LLVM.Extra.Class as Class+import qualified LLVM.Core as LLVM+import LLVM.Extra.Class+   (Undefined, undefTuple,+    MakeValueTuple, valueTupleOf, )+import LLVM.Core+   (Vector, Struct, IsSized, )+import LLVM.Util.Loop (Phi, phis, addPhis, )++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.Vector as Vector+import qualified Data.TypeLevel.Num as TypeNum++import Foreign.Ptr (castPtr, )+import qualified Foreign.Storable as St+-- import Data.Word (Word32, )++import Control.Monad (liftM2, )+import Control.Applicative (liftA2, )++import Data.Tuple.HT (mapPair, )+++data T n a = Cons (Vector n a) (Vector n a)++data Value n a = Value (LLVM.Value (Vector n a)) (LLVM.Value (Vector n a))+++interleave ::+   (LLVM.IsPrimitive a, TypeNum.Pos n) =>+   Stereo.T (LLVM.Value (Vector n a)) ->+   LLVM.CodeGenFunction r (Value n a)+interleave x =+   uncurry (liftM2 Value) .+   mapPair (Vector.assemble, Vector.assemble) .+   splitAt (Vector.sizeInTuple x) .+   concatMap (\s -> [Stereo.left s, Stereo.right s]) =<<+   Vector.extractAll x++deinterleave ::+   (LLVM.IsPrimitive a, TypeNum.Pos n) =>+   Value n a ->+   LLVM.CodeGenFunction r (Stereo.T (LLVM.Value (Vector n a)))+deinterleave (Value v0 v1) =+   Vector.assemble .+   (let aux (l:r:xs) = Stereo.cons l r : aux xs+        aux [] = []+        aux _ = error "odd number of stereo elements"+    in  aux) =<<+   liftM2 (++)+      (Vector.extractAll v0)+      (Vector.extractAll v1)+++instance+   (TypeNum.Pos n, LLVM.IsPrimitive 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  liftM2 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.Pos n, LLVM.IsPrimitive a) => Class.Zero (Value n a) where+   zeroTuple = Value (LLVM.value LLVM.zero) (LLVM.value LLVM.zero)++instance (TypeNum.Pos n, LLVM.IsPrimitive a) => Undefined (Value n a) where+   undefTuple = Value (LLVM.value LLVM.undef) (LLVM.value LLVM.undef)++{-+Can only be implemented by ifThenElse+since the atomic 'select' command wants a bool vector.++instance (TypeNum.Pos n, LLVM.IsPrimitive a, Phi a) => C.Select (Value n a) where+   select b (Value x0 x1) (Value y0 y1) =+      liftM2 Value+         (C.select b x0 y0)+         (C.select b x1 y1)++instance LLVM.CmpRet a b => LLVM.CmpRet (Stereo.T a) (Stereo.T b) where+-}++instance (TypeNum.Pos n, LLVM.IsPrimitive a, LLVM.IsConst a) =>+      MakeValueTuple (T n a) (Value n a) where+   valueTupleOf (Cons v0 v1) =+      Value+         (LLVM.valueOf v0)+         (LLVM.valueOf v1)++instance (TypeNum.Pos n, LLVM.IsPrimitive a) => Phi (Value n a) where+   phis bb = mapV (phis bb)+   addPhis bb = zipV (\_ _ -> ()) (addPhis bb)++{-+instance Vector.ShuffleMatch n (Value n a) where+   shuffleMatch = Vector.shuffleMatchAccess+-}++{-+We cannot make an instance of Vector.Access,+since we defined the functional dependencies in a way,+that vector size and element type uniquely defines the vector type.++instance Vector.Access n (Stereo.T a) (Value n a) where++insert ::+   LLVM.Value Word32 ->+   LLVM.Value a ->+   Value n a ->+   LLVM.CodeGenFunction r (Value n a)+insert k a (Value v0 v1) = do+   k20 <- A.add k k+   k21 <- A.inc k20+   select (k20<Vector.size v0) ...+   Vector.insert k20 (Stereo.left a) v >>=+      Vector.insert k21 (Stereo.right a)++extract ::+   LLVM.Value Word32 ->+   Value n a ->+   LLVM.CodeGenFunction r (LLVM.Value a)+extract k (Value v0 v1) = do+   k20 <- A.add k k+   k21 <- A.inc k20+   liftM2 Value+      (Vector.extract k20 v)+      (Vector.extract k21 v)+++With this instance,+both 'interleave' and 'deinterleave' could then be written this way:++   Vector.assemble =<<+   mapM (flip Vector.extract x) (take (Vector.size x) [0..])+-}++memory ::+   (TypeNum.Pos n, LLVM.IsPrimitive a, LLVM.IsPrimitive am,+    Memory.FirstClass a am) =>+   Memory.Record r (Struct (Vector n am, (Vector n am, ()))) (Value n a)+memory =+   liftA2 Value+      (Memory.element (\(Value v _) -> v) TypeNum.d0)+      (Memory.element (\(Value _ v) -> v) TypeNum.d1)++instance+      (TypeNum.Pos n,+       Memory.FirstClass a am,+       LLVM.IsPrimitive a, IsSized a as,+       TypeNum.Mul n as vs, TypeNum.Pos vs,+       LLVM.IsPrimitive am, IsSized am amsize,+       TypeNum.Mul n amsize vmsize, TypeNum.Pos vmsize) =>+      Memory.C (Value n a) (Struct (Vector n am, (Vector n am, ()))) where+   load = Memory.loadRecord memory+   store = Memory.storeRecord memory+   decompose = Memory.decomposeRecord memory+   compose = Memory.composeRecord memory++{- |+This instance allows to run @arrange@ on interleaved stereo vectors.+-}+instance+   (TypeNum.Pos n, LLVM.IsPrimitive a, LLVM.IsArithmetic a) =>+      A.Additive (Value n a) where+   zero = Value A.zero A.zero+   add = zipV Value A.add+   sub = zipV Value A.sub+   neg = mapV A.neg+++mapV :: (Monad m) =>+   (LLVM.Value (Vector n a) -> m (LLVM.Value (Vector n a))) ->+   Value n a -> m (Value n a)+mapV f (Value x0 x1) =+   liftM2 Value (f x0) (f x1)++zipV :: (Monad m) =>+   (c -> c -> d) ->+   (LLVM.Value (Vector n a) ->+    LLVM.Value (Vector n b) ->+    m c) ->+   Value n a ->+   Value n b ->+   m d+zipV g f (Value x0 x1) (Value y0 y1) =+   liftM2 g (f x0 y0) (f x1 y1)
src/Synthesizer/LLVM/Generator/Exponential2.hs view
@@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {- | Exponential curve with controllable delay. -}@@ -22,42 +23,46 @@ import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP import qualified Synthesizer.LLVM.Simple.Value as Value import qualified Synthesizer.LLVM.Parameter as Param+import qualified Synthesizer.LLVM.SerialVector as Serial  import qualified LLVM.Extra.ScalarOrVector as SoV import qualified LLVM.Extra.Vector as Vector-import qualified LLVM.Extra.Representation as Rep-+import qualified LLVM.Extra.Memory as Memory import qualified LLVM.Extra.Class as Class import qualified LLVM.Extra.Arithmetic as A+import LLVM.Extra.Class (Undefined, undefTuple, )+ import qualified LLVM.Core as LLVM import LLVM.Core    (Value, valueOf, Vector,-    IsPowerOf2, IsConst, IsArithmetic, IsPrimitive, IsFirstClass, IsFloating, IsSized,-    Undefined, undefTuple,+    IsArithmetic, IsPrimitive, IsFloating, IsSized,     CodeGenFunction, ) import LLVM.Util.Loop (Phi, phis, addPhis, ) -import qualified Data.TypeLevel.Num      as TypeNum-import qualified Data.TypeLevel.Num.Sets as TypeSet+import qualified Data.TypeLevel.Num as TypeNum  import Foreign.Storable (Storable, )+import qualified Foreign.Storable+-- import qualified Foreign.Storable.Record as Store+import qualified Foreign.Storable.Traversable as Store  import qualified Control.Applicative as App import qualified Data.Foldable as Fold import qualified Data.Traversable as Trav import Control.Applicative (liftA2, (<*>), )-import Control.Arrow ((^<<), )+import Control.Arrow (arr, (^<<), (&&&), )+import Control.Monad (liftM2, )  import qualified Algebra.Transcendental as Trans-import qualified Algebra.Field as Field-import qualified Algebra.Ring as Ring+-- import qualified Algebra.Field as Field+-- import qualified Algebra.Ring as Ring  import NumericPrelude.Numeric import NumericPrelude.Base  -newtype Parameter a =-   Parameter a+newtype Parameter a = Parameter a+   deriving (Show, Storable)   instance Functor Parameter where@@ -92,22 +97,24 @@    zeroTuple = Class.zeroTuplePointed  instance-      (Rep.Memory a s, IsSized s ss) =>-      Rep.Memory (Parameter a) s where-   load = Rep.loadNewtype Parameter-   store = Rep.storeNewtype (\(Parameter k) -> k)-   decompose = Rep.decomposeNewtype Parameter-   compose = Rep.composeNewtype (\(Parameter k) -> k)+      (Memory.C a s, IsSized s ss) =>+      Memory.C (Parameter a) s where+   load = Memory.loadNewtype Parameter+   store = Memory.storeNewtype (\(Parameter k) -> k)+   decompose = Memory.decomposeNewtype Parameter+   compose = Memory.composeNewtype (\(Parameter k) -> k)  +{- instance LLVM.ValueTuple a => LLVM.ValueTuple (Parameter a) where    buildTuple f = Class.buildTupleTraversable (LLVM.buildTuple f)  instance LLVM.IsTuple a => LLVM.IsTuple (Parameter a) where    tupleDesc = Class.tupleDescFoldable+-} -instance (LLVM.MakeValueTuple ah al) =>-      LLVM.MakeValueTuple (Parameter ah) (Parameter al) where+instance (Class.MakeValueTuple ah al) =>+      Class.MakeValueTuple (Parameter ah) (Parameter al) where    valueTupleOf = Class.valueTupleOfFunctor  @@ -128,7 +135,7 @@   parameter ::-   (Trans.C a, IsConst a, IsFloating a) =>+   (Trans.C a, SoV.RationalConstant a, IsFloating a) =>    Value a ->    CodeGenFunction r (Parameter (Value a)) parameter halfLife =@@ -143,19 +150,14 @@   causalP ::-   (IsFirstClass a, IsSized a size,-    IsArithmetic a, IsConst a,-    Storable a, LLVM.MakeValueTuple a (Value a)) =>+   (Memory.FirstClass a am, IsSized a as, IsSized am ams, SoV.IntegerConstant a,+    IsArithmetic a,+    Storable a, Class.MakeValueTuple a (Value a)) =>    Param.T p a ->    CausalP.T p (Parameter (Value a)) (Value a) causalP initial =-   CausalP.mapAccum-      (\() (Parameter a) s -> do-         b <- A.mul a s-         return (s,b))-      return-      (return ())-      initial+   CausalP.loop initial+      (arr snd &&& CausalP.zipWithSimple (\(Parameter a) -> A.mul a))   data ParameterPacked a =@@ -197,31 +199,56 @@    zeroTuple = Class.zeroTuplePointed  +{-+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++ memory ::-   (Rep.Memory l s, IsSized s ss) =>-   Rep.MemoryRecord r (LLVM.Struct (s, (s, ()))) (ParameterPacked l)+   (Memory.C l s, IsSized s ss) =>+   Memory.Record r (LLVM.Struct (s, (s, ()))) (ParameterPacked l) memory =    liftA2 ParameterPacked-      (Rep.memoryElement ppFeedback TypeNum.d0)-      (Rep.memoryElement ppCurrent  TypeNum.d1)+      (Memory.element ppFeedback TypeNum.d0)+      (Memory.element ppCurrent  TypeNum.d1)  instance-      (Rep.Memory l s, IsSized s ss) =>-      Rep.Memory (ParameterPacked l) (LLVM.Struct (s, (s, ()))) where-   load = Rep.loadRecord memory-   store = Rep.storeRecord memory-   decompose = Rep.decomposeRecord memory-   compose = Rep.composeRecord memory+      (Memory.C l s, IsSized s ss) =>+      Memory.C (ParameterPacked l) (LLVM.Struct (s, (s, ()))) where+   load = Memory.loadRecord memory+   store = Memory.storeRecord memory+   decompose = Memory.decomposeRecord memory+   compose = Memory.composeRecord memory  +{- instance LLVM.ValueTuple a => LLVM.ValueTuple (ParameterPacked a) where    buildTuple f = Class.buildTupleTraversable (LLVM.buildTuple f)  instance LLVM.IsTuple a => LLVM.IsTuple (ParameterPacked a) where    tupleDesc = Class.tupleDescFoldable+-} -instance (LLVM.MakeValueTuple ah al) =>-      LLVM.MakeValueTuple (ParameterPacked ah) (ParameterPacked al) where+instance (Class.MakeValueTuple ah al) =>+      Class.MakeValueTuple (ParameterPacked ah) (ParameterPacked al) where    valueTupleOf = Class.valueTupleOfFunctor  @@ -248,8 +275,8 @@ withSize f = f undefined  parameterPacked ::-   (Trans.C a, IsConst a, IsFloating a,-    IsPrimitive a, IsPowerOf2 n) =>+   (Trans.C a, SoV.RationalConstant a, IsFloating a,+    IsPrimitive a, TypeNum.Pos n) =>    Value a ->    CodeGenFunction r (ParameterPacked (Value (Vector n a))) parameterPacked halfLife = withSize $ \n -> do@@ -275,29 +302,27 @@  parameterPackedPlain ::    (Trans.C a,-    IsPowerOf2 n) =>+    TypeNum.Pos n) =>    a -> ParameterPacked (Vector n a) parameterPackedPlain halfLife =    withSizePlain $ \n ->    ParameterPacked-      (LLVM.vector [0.5 ** (fromIntegral (TypeNum.toInt n) / halfLife)])+      (Serial.replicate (0.5 ** (fromIntegral (TypeNum.toInt n) / halfLife)))       (LLVM.vector $ iterate (0.5 ** recip halfLife *) one)   causalPackedP ::-   (IsFirstClass a, IsSized a size,-    IsArithmetic a, IsConst a,-    Storable a, LLVM.MakeValueTuple a (Value a),-    IsPrimitive a, IsPowerOf2 n,-    TypeNum.Mul n size pss, TypeNum.Pos pss) =>+   (Memory.FirstClass a am, IsSized a as, IsSized am ams, SoV.IntegerConstant a,+    Storable a, Class.MakeValueTuple a (Value a),+    IsArithmetic a, TypeNum.Pos n,+    IsPrimitive a,  TypeNum.Mul n as  vs,  TypeNum.Pos vs,+    IsPrimitive am, TypeNum.Mul n ams vms, TypeNum.Pos vms) =>    Param.T p a ->    CausalP.T p (ParameterPacked (Value (Vector n a))) (Value (Vector n a)) causalPackedP initial =-   CausalP.mapAccum-      (\() p s0 -> do-         s1 <- A.mul (ppFeedback p) s0-         b  <- A.mul (ppCurrent p) s0-         return (b,s1))-      return-      (return ())-      (LLVM.vector . (:[]) ^<< initial)+   CausalP.loop+      (Serial.replicate ^<< initial)+      (CausalP.mapSimple $+       \(p, s0) -> liftM2 (,)+          (A.mul (ppCurrent p) s0)+          (A.mul (ppFeedback p) s0))
+ src/Synthesizer/LLVM/LAC2011.hs view
@@ -0,0 +1,328 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_GHC -fno-warn-unused-imports #-}+module Synthesizer.LLVM.LAC2011 where++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.CausalParameterized.Controlled as CtrlP+import qualified Synthesizer.LLVM.CausalParameterized.ControlledPacked as CtrlPS+import qualified Synthesizer.LLVM.CausalParameterized.ProcessPacked as CausalPS+import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP+import qualified Synthesizer.LLVM.Causal.Process as Causal+import qualified Synthesizer.LLVM.Simple.Signal as Gen+import qualified Synthesizer.LLVM.Storable.Signal as SigStL+import qualified Synthesizer.LLVM.Frame as Frame+import qualified Synthesizer.LLVM.Wave as Wave+import qualified Synthesizer.LLVM.Parameter as Param++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.Class as C+import LLVM.Core (Value, value, valueOf, Vector, constVector, constOf, )+import LLVM.Util.Arithmetic () -- Floating instance for TValue+import qualified LLVM.Core as LLVM+import Data.TypeLevel.Num (D4, D8, D16, d0, d1, d2, d3, d4, d5, d6, d7, d8, )+import qualified Data.TypeLevel.Num as TypeNum++import qualified Synthesizer.LLVM.Parameterized.SignalPacked as GenPS+import qualified Synthesizer.LLVM.Parameterized.Signal as GenP+import Synthesizer.LLVM.CausalParameterized.Process (($<), ($*), ($*#), )+import Synthesizer.LLVM.Parameterized.Signal (($#), )++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 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.Storable.ALSA.Play as Play++import Data.Word (Word32, )+-- import qualified Data.Function.HT as F+import Data.List (genericLength, )+import System.Random (randomRs, mkStdGen, )++import qualified System.IO as IO+-- import System.Exit (ExitCode, )++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+++asMono :: vector Float -> vector Float+asMono = id++asStereo :: vector (Stereo.T Float) -> vector (Stereo.T Float)+asStereo = id++asMonoPacked :: vector (LLVM.Vector D4 Float) -> vector (LLVM.Vector D4 Float)+asMonoPacked = id++asMonoPacked16 :: vector (LLVM.Vector D16 Float) -> vector (LLVM.Vector D16 Float)+asMonoPacked16 = id++asWord32 :: vector Word32 -> vector Word32+asWord32 = id++asWord32Packed :: vector (LLVM.Vector D4 Word32) -> vector (LLVM.Vector D4 Word32)+asWord32Packed = id+++playStereo :: Gen.T (Stereo.T (Value Float)) -> IO ()+playStereo =+   playStereoStream .+   Gen.renderChunky (SVL.chunkSize 100000)++playStereoStream :: SVL.Vector (Stereo.T Float) -> IO ()+playStereoStream = playStreamSox++playMono :: Gen.T (Value Float) -> IO ()+playMono =+   playMonoStream .+   Gen.renderChunky (SVL.chunkSize 100000)++playMonoParam :: GenP.T () (Value Float) -> IO ()+playMonoParam =+   playMonoStream .+   ($ ()) .+   ($ SVL.chunkSize 100000) <=<+   GenP.runChunky++playMonoPacked :: GenP.T () (Value (Vector D4 Float)) -> IO ()+playMonoPacked =+   playMonoStream .+   SigStL.unpack .+   ($ ()) .+   ($ SVL.chunkSize 100000) <=<+   GenP.runChunky++playMonoStream :: SVL.Vector Float -> IO ()+playMonoStream = playStreamSox+++{-+play ::+   (C.MakeValueTuple y a, Memory.C a struct) =>+   Gen.T 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 =+   fmap (const ()) .+   SoxPlay.simple SVL.hPut SoxOption.none 44100+++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++{-+second :: Float -> Param.T p Float+second t = return (t * sampleRate)++hertz :: Float -> Param.T p Float+hertz f = return (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))+++fst :: Arrow arrow => arrow (a,b) a+fst = arr P.fst++snd :: Arrow arrow => arrow (a,b) b+snd = arr P.snd+++pingParam :: IO (Float -> SVL.Vector Float)+pingParam =+   fmap ($ SVL.chunkSize 1024) $+   GenP.runChunky $+   GenP.exponential2 (second 0.3) 1 * GenP.osciSimple Wave.triangle 0 id++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) $+   GenP.runChunky $+   GenP.exponential2 (second 0.3) fst * GenP.osciSimple Wave.triangle 0 snd++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 :: GenP.T p (Value Float) -> GenP.T p (Value Float)+retard xs =+   CausalP.frequencyModulationLinear xs .+   CausalP.mapSimple (A.fdiv (LLVM.valueOf 1)) $*+   GenP.rampCore (1 / second 10) 1++playRetarded :: IO ()+playRetarded = do+   mel <- melody+   playMonoParam $ retard $ GenP.fromStorableVectorLazy $ pure $ mel++++pingGen :: GenP.T p (Value Float)+pingGen =+   GenP.exponential2 (second 0.5) 0.7 *+   GenP.osciSimple Wave.triangle 0 (hertz 440)++zerop :: Param.T p Float+zerop = pure zero++delayp :: Param.T p Int -> CausalP.T p (Value Float) (Value Float)+delayp = CausalP.delay zerop++delay :: IO ()+delay =+   playMonoParam $+      pingGen + 0.7 * (delayp (intSecond 0.5) $* pingGen)++delayArrow :: IO ()+delayArrow =+   playMonoParam+      ((id + 0.7 * delayp (intSecond 0.5)) $* pingGen)++comb :: IO ()+comb =+   playMonoParam $+      (CausalP.loop zerop+          (id  &&&  0.7 * delayp (intSecond 0.5)+             <<< CausalP.mix) $*+       pingGen)+++lfoSine ::+   Param.T p Float ->+   GenP.T p (Moog.Parameter D8 (Value Float))+lfoSine reduct =+   CausalP.mapSimple (Moog.parameter d8 (valueOf (30::Float))) .+   CausalP.mapExponential 2 (hertz 700) $*+   GenP.osciSimple Wave.sine 0 (reduct * hertz 0.1)++filterSweep :: IO ()+filterSweep =+   playMonoParam $+      (0.2 * CtrlP.processCtrlRate 128 lfoSine+       $* GenP.noise 0 0.3)+++pingPacked :: IO ()+pingPacked =+   playMonoPacked (GenPS.exponential2 (second 1) 1 * GenPS.osciSimple Wave.triangle 0 (hertz 440))++++{-+Module can be loaded into GHCi only when synthesizer-llvm was installed with+$ cabal install --enable-shared++In contrast to that, you have to install with+$ cabal install -fbuildTests -fbuildExamples --enable-shared --disable-library-profiling --ghc-option=-dynamic+for build the executables.+But then GHCi complains:++$ ghci+GHCi, version 6.12.3: http://www.haskell.org/ghc/  :? for help+Loading package ghc-prim ... linking ... done.+Loading package integer-gmp ... linking ... done.+Loading package base ... linking ... done.+Loading package ffi-1.0 ... linking ... done.+[1 of 1] Compiling Main             ( src/Synthesizer/LLVM/Test.hs, interpreted )++src/Synthesizer/LLVM/Test.hs:4:0:+    Bad interface file: /home/thielema/.cabal/lib/synthesizer-llvm-0.3/ghc-6.12.3/Synthesizer/LLVM/Filter/ComplexFirstOrderPacked.hi+        mismatched interface file ways (wanted "", got "dyn")+Failed, modules loaded: none.+-}
+ src/Synthesizer/LLVM/LNdW2011.hs view
@@ -0,0 +1,543 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_GHC -fno-warn-unused-imports #-}+module Synthesizer.LLVM.LNdW2011 where++import qualified Synthesizer.LLVM.Plug.Input as PIn+import qualified Synthesizer.LLVM.Plug.Output as POut+import qualified Synthesizer.PiecewiseConstant.ALSA.MIDIControllerSet as PCS+import qualified Synthesizer.CausalIO.ALSA.MIDIControllerSelection as MCS+import qualified Synthesizer.CausalIO.ALSA.Process as PALSA+import qualified Synthesizer.CausalIO.Process as PIO+import qualified Synthesizer.MIDIValue as MV+import qualified Synthesizer.Zip as Zip+import Synthesizer.EventList.ALSA.MIDI (ClientName(ClientName))++import qualified Sound.MIDI.Controller as Ctrl+import qualified Sound.MIDI.Message.Channel as ChannelMsg++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.CausalParameterized.Controlled as CtrlP+import qualified Synthesizer.LLVM.CausalParameterized.ControlledPacked as CtrlPS+import qualified Synthesizer.LLVM.CausalParameterized.ProcessPacked as CausalPS+import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP+import qualified Synthesizer.LLVM.Causal.Process as Causal+import qualified Synthesizer.LLVM.Simple.Signal as Gen+import qualified Synthesizer.LLVM.Simple.Value as Value+import qualified Synthesizer.LLVM.Storable.Signal as SigStL+import qualified Synthesizer.LLVM.Frame as Frame+import qualified Synthesizer.LLVM.Wave as Wave+import qualified Synthesizer.LLVM.Parameter as Param++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.Class as C+import LLVM.Core (Value, value, valueOf, constVector, constOf, )+import LLVM.Util.Arithmetic () -- Floating instance for TValue+import qualified LLVM.Core as LLVM+import Data.TypeLevel.Num (D4, D8, D16, d0, d1, d2, d3, d4, d5, d6, d7, d8, )+import qualified Data.TypeLevel.Num as TypeNum++import qualified Synthesizer.LLVM.Parameterized.SignalPacked as GenPS+import qualified Synthesizer.LLVM.Parameterized.Signal as GenP+import Synthesizer.LLVM.CausalParameterized.Process (($<), ($*), ($*#), ($<#), )+import Synthesizer.LLVM.Parameterized.Signal (($#), )++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.Arrow as Arr+import Control.Arrow (Arrow, arr, (&&&), (^<<), )+import Control.Category ((<<<), (.), id, (>>>), )+import Control.Monad ((<=<), )+import Control.Applicative (liftA2, pure, )+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 Data.EventList.Relative.TimeTime  as EventListTT+import qualified Numeric.NonNegative.Wrapper as NonNegW+import qualified Numeric.NonNegative.Class as NonNeg++import qualified Control.Monad.Trans.State as State++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.Storable.ALSA.Play as Play++import Data.Word (Word32, )+-- import qualified Data.Function.HT as F+import Data.List (genericLength, )+import System.Random (randomRs, mkStdGen, )++import qualified System.IO as IO+-- import System.Exit (ExitCode, )++import qualified Algebra.NormedSpace.Euclidean as NormedEuc+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+++asMono :: vector Float -> vector Float+asMono = id++asStereo :: vector (Stereo.T Float) -> vector (Stereo.T Float)+asStereo = id++asMonoPacked :: vector Vector -> vector Vector+asMonoPacked = id++asMonoPacked16 :: vector (LLVM.Vector D16 Float) -> vector (LLVM.Vector D16 Float)+asMonoPacked16 = id++asWord32 :: vector Word32 -> vector Word32+asWord32 = id++asWord32Packed :: vector (LLVM.Vector D4 Word32) -> vector (LLVM.Vector D4 Word32)+asWord32Packed = id+++playStereo :: Gen.T (Stereo.T (Value Float)) -> IO ()+playStereo =+   playStereoStream .+   Gen.renderChunky (SVL.chunkSize 100000)++playStereoStream :: SVL.Vector (Stereo.T Float) -> IO ()+playStereoStream = playStreamSox++playMono :: Gen.T (Value Float) -> IO ()+playMono =+   playMonoStream .+   Gen.renderChunky (SVL.chunkSize 100000)++playMonoParam :: GenP.T () (Value Float) -> IO ()+playMonoParam =+   playMonoStream .+   ($ ()) .+   ($ SVL.chunkSize 100000) <=<+   GenP.runChunky++playMonoPacked :: GenP.T () (Value Vector) -> IO ()+playMonoPacked =+   playMonoStream .+   SigStL.unpack .+   ($ ()) .+   ($ SVL.chunkSize 100000) <=<+   GenP.runChunky++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 =+   fmap (const ()) .+   SoxPlay.simple SVL.hPut SoxOption.none 44100+++sampleRate :: Ring.C a => a+sampleRate = 44100++type Vector = LLVM.Vector VectorSize Float+type VectorSize = TypeNum.D4++vectorSize :: Int+vectorSize = TypeNum.toInt (undefined :: 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 <-+      CausalP.processIO+         (0.95 * (CausalP.osciSimple Wave.approxSine4 $< 0))+   playFromEvents 0.01 (0.015::Double)+      ((proc () :: PIO.T (EventListBT.T NonNegW.Int Float) (SV.Vector Float))+       .+       PALSA.controllerExponential+         (ChannelMsg.toChannel 0)+         Ctrl.modulation+         (hertz 500, hertz 2000) (hertz 1000))+++vectorBlockSize :: Double+vectorBlockSize = fromIntegral $ 150*vectorSize++subsample :: (Integral.C t) => t -> t -> State.State t t+subsample step t =+   State.state $ \r -> divMod (r+t) step+{-+   do modify (t+)+      (q,r) <- gets (flip divMod step)+      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 <-+      CausalP.processIO+         (0.95 * (CausalPS.osciSimple Wave.approxSine4 $< 0)+          .+          CausalP.mapSimple SoV.replicate)+   playFromEvents 0.01 (vectorBlockSize/sampleRate)+      (arr SigStL.unpackStrict+       .+       (proc () :: PIO.T (EventListBT.T NonNegW.Int Float) (SV.Vector Vector))+       .+       arr subsampleBT+       .+       PALSA.controllerExponential+         (ChannelMsg.toChannel 0)+         Ctrl.modulation+         (hertz 500, hertz 2000) (hertz 1000))+++bubbles :: IO ()+bubbles = do+   proc <-+      CausalP.processIO+         (0.95 * (CausalP.osciSimple Wave.sine $< 0)+          .+          (fst.fst * (1 + snd.fst * snd))+          .+          Arr.second (CausalP.osciSimple 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+             (PALSA.controllerExponential+                 (ChannelMsg.toChannel 0)+                 Ctrl.modulation+                 (hertz 500, hertz 2000) (hertz 1000))+             (PALSA.controllerLinear+                 (ChannelMsg.toChannel 0)+                 Ctrl.timbre+                 (-1, 1) (-0.1)))+          (PALSA.controllerExponential+             (ChannelMsg.toChannel 0)+             Ctrl.soundVariation+             (hertz 1, hertz 10) (hertz 1)))++bubblesSet :: IO ()+bubblesSet = do+   proc <-+      CausalP.processIOCore+         (PIn.controllerSet d6)+         (CausalP.arrayElement d0 *+          (CausalP.osciSimple Wave.sine $< 0)+          .+          (CausalP.arrayElement d1+           *+           (1 - CausalP.arrayElement d2 *+              (CausalP.osciSimple Wave.saw $< 0) .+              CausalP.arrayElement d3)+           *+           (1 - CausalP.arrayElement d4 *+              (CausalP.osciSimple Wave.saw $< 0) .+              CausalP.arrayElement d5)))+         POut.storableVector+   playFromEvents 0.01 (0.015::Double)+      ((proc () :: PIO.T (PCS.T Int Float) (SV.Vector Float))+       .+       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))+++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 <-+      CausalP.processIOCore+         (PIn.controllerSet d6)+         (CausalPS.arrayElement d0 *+          (CausalPS.osciSimple Wave.approxSine4 $< 0)+          .+          (CausalPS.arrayElement d1+           *+           (1 - CausalPS.arrayElement d2 *+              (CausalPS.osciSimple Wave.saw $< 0) .+              CausalPS.arrayElement d3)+           *+           (1 - CausalPS.arrayElement d4 *+              (CausalPS.osciSimple Wave.saw $< 0) .+              CausalPS.arrayElement d5)))+         POut.storableVector+   playFromEvents 0.01 (vectorBlockSize/sampleRate)+      (arr SigStL.unpackStrict+       .+       (proc () :: PIO.T (PCS.T Int Float) (SV.Vector Vector))+       .+       arr subsamplePCS+       .+       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))+++moveAround2dFloat ::+   Float -> Float -> (Float, Float) ->+   CausalP.T p+      (Value Float, Value Float)+      (Value Float, Value Float)+moveAround2dFloat att sonicDelay (earX,earY) =+   CausalP.mapSimple+      (Value.flatten .+       Spatial.moveAround+          (Value.constant att) (Value.constant sonicDelay)+          (Value.constant earX, Value.constant earY) .+       Value.unfold)++moveAround2d ::+   (Ring.C a, LLVM.IsConst a, SoV.Replicate a v, LLVM.IsFloating v) =>+   a -> a -> (a, a) ->+   CausalP.T p+      (Value v, Value v)+      (Value v, Value v)+moveAround2d att sonicDelay (earX,earY) =+-- (\dist -> (sonicDelay*dist, 1/(att+dist)^2)) . Euc.norm . subtract ear+   CausalP.mapSimple $ \(objX,objY) -> do+      dist <-+         euclideanNorm2d =<< liftA2 (,)+            (A.sub objX (SoV.replicateOf earX))+            (A.sub objY (SoV.replicateOf earY))+      delay <- A.mul dist (SoV.replicateOf sonicDelay)+      volume <- A.fdiv (SoV.replicateOf Ring.one)+         =<< A.square =<< A.add dist (SoV.replicateOf att)+      return (delay, volume)++euclideanNorm2d ::+   (LLVM.IsFloating a) =>+   (Value a, Value a) ->+   LLVM.CodeGenFunction r (Value a)+euclideanNorm2d (x,y) = do+   x2 <- A.square x+   y2 <- A.square y+   A.sqrt =<< A.add x2 y2++flyChannel ::+   (Float, Float) ->+   CausalP.T p (Value Float, Value Float) (Value Float)+flyChannel ear =+   ((moveAround2d 1 0.1 ear >>> Arr.first (negate id))+    &&&+    (250/sampleRate ++     2 * (CausalP.mapSimple euclideanNorm2d <<< (CausalP.differentiate $# (0::Float, 0::Float)))))+   >>>+   arr (\((phase,volume), speed) -> (volume, (phase,speed)))+   >>>+   Arr.second (CausalP.osciSimple Wave.saw)+   >>>+   CausalP.envelope+   >>>+   CausalP.amplify 10++fly :: IO ()+fly = do+   let slow =+          Filt1.lowpassCausalP $<#+          Filt1Core.parameter (1/sampleRate::Float)+   let fast =+          Filt1.lowpassCausalP $<#+          Filt1Core.parameter (30/sampleRate::Float)+   proc <-+      CausalP.processIOCore+         (PIn.controllerSet d4)+         ((CausalP.arrayElement d0 &&&+           (liftA2 (,)+               ((CausalP.arrayElement d2 >>> slow)+                ++                CausalP.arrayElement d1 *+                (CausalP.fromSignal (GenP.noise 366210 0.3) >>> fast >>> fast))+               ((CausalP.arrayElement d3 >>> slow)+                ++                CausalP.arrayElement d1 *+                (CausalP.fromSignal (GenP.noise 234298 0.3) >>> fast >>> fast))+            >>>+            liftA2 Stereo.cons+               (flyChannel (-1,0))+               (flyChannel ( 1,0))))+          >>>+          CausalP.envelopeStereo)+         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 (hertz 500, hertz 2000) (hertz 1000),+-}+          MCS.controllerLinear Ctrl.vectorX (-10, 10) 0,+          MCS.controllerLinear Ctrl.vectorY (-10, 10) 0]+       .+       MCS.fromChannel (ChannelMsg.toChannel 0))+++flyChannelPacked ::+   (Float, Float) ->+   CausalP.T p (Value Vector, Value Vector) (Value Vector)+flyChannelPacked ear =+   ((moveAround2d 1 0.1 ear >>> Arr.first (negate id))+    &&&+    (250/sampleRate ++     2 * (CausalP.mapSimple euclideanNorm2d <<< (CausalPS.differentiate $# (0::Float, 0::Float)))))+   >>>+   arr (\((phase,volume), speed) -> (volume, (phase,speed)))+   >>>+   Arr.second (CausalPS.osciSimple Wave.saw)+   >>>+   CausalP.envelope+   >>>+   CausalPS.amplify 10++flyPacked :: IO ()+flyPacked = do+   let slow =+          Filt1.lowpassCausalPackedP $<#+          Filt1Core.parameter (1/sampleRate::Float)+   let fast =+          Filt1.lowpassCausalPackedP $<#+          Filt1Core.parameter (30/sampleRate::Float)+   proc <-+      CausalP.processIOCore+         (PIn.controllerSet d4)+         ((CausalPS.arrayElement d0 &&&+           (liftA2 (,)+               ((CausalPS.arrayElement d2 >>> slow)+                ++                CausalPS.arrayElement d1 *+                (CausalP.fromSignal (GenPS.noise 366210 0.3) >>> fast >>> fast))+               ((CausalPS.arrayElement d3 >>> slow)+                ++                CausalPS.arrayElement d1 *+                (CausalP.fromSignal (GenPS.noise 234298 0.3) >>> fast >>> fast))+            >>>+            liftA2 Stereo.cons+               (flyChannelPacked (-1,0))+               (flyChannelPacked ( 1,0))))+          >>>+          CausalP.envelopeStereo+          >>>+          CausalP.mapSimple StereoInt.interleave)+         POut.storableVector+   playFromEvents 0.01 (vectorBlockSize/sampleRate)+      (arr SigStL.unpackStereoStrict+       .+       (proc () :: PIO.T (PCS.T Int Float) (SV.Vector (StereoInt.T VectorSize Float)))+       .+       arr subsamplePCS+       .+       MCS.filter [+          MCS.controllerExponential Ctrl.volume (0.001, 0.99) 0.2,+          MCS.controllerLinear Ctrl.modulation (0, 5) 2,+{-+          MCS.pitchBend (hertz 500, hertz 2000) (hertz 1000),+-}+          MCS.controllerLinear Ctrl.vectorX (-10, 10) 0,+          MCS.controllerLinear Ctrl.vectorY (-10, 10) 0]+       .+       MCS.fromChannel (ChannelMsg.toChannel 0))
src/Synthesizer/LLVM/Parameter.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE NoImplicitPrelude #-} module Synthesizer.LLVM.Parameter where -import qualified LLVM.Core as LLVM+import qualified LLVM.Extra.Class as Class  import qualified Algebra.Transcendental as Trans import qualified Algebra.Algebraic as Algebraic@@ -68,9 +68,9 @@ For small loop counts and simple loop bodies the loop might get unrolled. -} value ::-   LLVM.MakeValueTuple tuple value =>+   Class.MakeValueTuple tuple value =>    T p tuple -> value -> value-value (Constant a) _ = LLVM.valueTupleOf a+value (Constant a) _ = Class.valueTupleOf a value (Variable _) v = v
src/Synthesizer/LLVM/Parameterized/Signal.hs view
@@ -1,34 +1,35 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ForeignFunctionInterface #-} module Synthesizer.LLVM.Parameterized.Signal (-   T(Cons), simple, map, mapSimple, iterate,+   T(Cons), simple, map, mapSimple, zipWith, zipWithSimple, iterate,    module Synthesizer.LLVM.Parameterized.Signal    ) where  import Synthesizer.LLVM.Parameterized.SignalPrivate import qualified Synthesizer.LLVM.CausalParameterized.ProcessPrivate as Causal import qualified Synthesizer.LLVM.Parameter as Param+import qualified Synthesizer.LLVM.ConstantPiece as Const  import qualified Synthesizer.LLVM.Random as Rnd import qualified Synthesizer.LLVM.Wave as Wave-import qualified Synthesizer.LLVM.Sample as Sample+import qualified Synthesizer.LLVM.Frame as Frame import qualified Synthesizer.LLVM.Execution as Exec-import qualified LLVM.Extra.ScalarOrVector as SoV+ import qualified LLVM.Extra.MaybeContinuation as Maybe-import qualified LLVM.Extra.Representation as Rep+import qualified LLVM.Extra.ForeignPtr as ForeignPtr+import qualified LLVM.Extra.Memory as Memory import LLVM.Extra.Control (whileLoop, ifThen, )  import qualified Synthesizer.LLVM.Storable.ChunkIterator as ChunkIt-import qualified Synthesizer.LLVM.Storable.LazySizeIterator as SizeIt import qualified Data.StorableVector.Lazy.Pattern as SVP import qualified Data.StorableVector.Lazy as SVL import qualified Data.StorableVector as SV import qualified Data.StorableVector.Base as SVB -import qualified Synthesizer.LLVM.EventIterator as EventIt import qualified Data.EventList.Relative.BodyTime as EventList import qualified Numeric.NonNegative.Chunky as Chunky import qualified Numeric.NonNegative.Wrapper as NonNeg@@ -38,12 +39,14 @@ import qualified LLVM.Extra.Arithmetic as A import qualified LLVM.Extra.ScalarOrVector as SoV import LLVM.Extra.Arithmetic (advanceArrayElementPtr, )+import LLVM.Extra.Class (MakeValueTuple, Undefined, undefTuple, )  import LLVM.Core as LLVM import qualified LLVM.Util.Loop as Loop import qualified Data.TypeLevel.Num as TypeNum -import Control.Monad (liftM2, liftM3, )+import Control.Monad.HT ((<=<), )+import Control.Monad (liftM2, liftM3, when, ) import Control.Arrow ((^<<), ) import Control.Applicative (liftA2, ) @@ -54,24 +57,28 @@ import qualified Algebra.Ring as Ring import qualified Algebra.Additive as Additive -import Data.Word (Word32, )+import Data.Word (Word8, Word32, )+import Data.Int (Int32, ) import Foreign.Storable.Tuple ()-import Foreign.Storable (Storable, poke, )+import Foreign.Storable (Storable, ) import Foreign.Marshal.Array (advancePtr, )-import qualified Foreign.Marshal.Array as Array-import qualified Foreign.Marshal.Alloc as Alloc+import qualified Synthesizer.LLVM.Alloc as Alloc import Foreign.ForeignPtr           (unsafeForeignPtrToPtr, touchForeignPtr, withForeignPtr, ) import Foreign.Ptr (FunPtr, nullPtr, ) import Control.Exception (bracket, ) import System.IO.Unsafe (unsafePerformIO, unsafeInterleaveIO, ) -import Data.Tuple.HT (swap, )+import qualified Synthesizer.LLVM.Debug.Storable as DebugSt+import qualified Synthesizer.LLVM.Debug.Counter as Counter  import NumericPrelude.Numeric import NumericPrelude.Base hiding (and, iterate, map, zip, zipWith, ) +-- for debugMain+import qualified Control.Monad.Trans.Reader as R + infixl 0 $#  ($#) :: (Param.T p a -> b) -> (a -> b)@@ -79,9 +86,9 @@   mapAccum ::-   (Storable pnh, MakeValueTuple pnh pnl, Rep.Memory pnl pnp, IsSized pnp pns,-    Storable psh, MakeValueTuple psh psl, Rep.Memory psl psp, IsSized psp pss,-    Rep.Memory s struct, IsSized struct sa) =>+   (Storable pnh, MakeValueTuple pnh pnl, Memory.C pnl pnp, IsSized pnp pns,+    Storable psh, MakeValueTuple psh psl, Memory.C psl psp, IsSized psp pss,+    Memory.C s struct, IsSized struct sa) =>    (forall r. pnl -> a -> s -> CodeGenFunction r (b,s)) ->    (forall r. psl -> CodeGenFunction r s) ->    Param.T p pnh ->@@ -103,42 +110,8 @@       deleteIOContext  -zipWith ::-   (Storable ph, MakeValueTuple ph pl, Rep.Memory pl pp, IsSized pp ps) =>-   (forall r. pl -> a -> b -> CodeGenFunction r c) ->-   Param.T p ph ->-   T p a -> T p b -> T p c-zipWith f selectParamF-      (Cons nextA startA createIOContextA deleteIOContextA)-      (Cons nextB startB createIOContextB deleteIOContextB) =-   Cons-      (\(parameterF, (parameterA, parameterB)) (sa0,sb0) -> do-         (a,sa1) <- nextA parameterA sa0-         (b,sb1) <- nextB parameterB sb0-         c <- Maybe.lift $ f (Param.value selectParamF parameterF) a b-         return (c, (sa1,sb1)))-      (\(parameterA, parameterB) ->-         liftM2 (,)-            (startA parameterA)-            (startB parameterB))-      (\p -> do-         (ca,(nextParamA,startParamA)) <- createIOContextA p-         (cb,(nextParamB,startParamB)) <- createIOContextB p-         return ((ca,cb),-            ((Param.get selectParamF p, (nextParamA,  nextParamB)),-             (startParamA, startParamB))))-      (\(ca,cb) ->-         deleteIOContextA ca >>-         deleteIOContextB cb)--zipWithSimple ::-   (forall r. a -> b -> CodeGenFunction r c) ->-   T p a -> T p b -> T p c-zipWithSimple f =-   zipWith (const f) (return ())- zip :: T p a -> T p b -> T p (a,b)-zip = zipWithSimple (\a b -> return (a,b))+zip = liftA2 (,)   -- * timeline edit@@ -172,7 +145,7 @@          whileLoop (valueOf True, Param.value n32 i0, s0)             (\(cont,i1,_s1) ->                A.and cont =<<-                  A.icmp IntUGT i1 (value LLVM.zero))+                  A.cmp CmpGT i1 (value LLVM.zero))             (\(_cont,i1,s1) -> do                (cont, s2) <-                   Maybe.resolve (next nextParameter s1)@@ -199,7 +172,7 @@ for the states of the first and the second signal generator. -} append ::-   (Loop.Phi a) =>+   (Loop.Phi a, Undefined a) =>    T p a -> T p a -> T p a append       (Cons nextA startA createIOContextA deleteIOContextA)@@ -243,11 +216,11 @@ or if the input value differs from the last processed one by a certain amount. -} interpolateConstant ::-   (Rep.Memory a struct, IsSized struct size,+   (Memory.C a struct, IsSized struct size,     Ring.C b,     IsFloating b, CmpRet b Bool,-    Storable b, MakeValueTuple b (Value b),-    IsConst b, IsFirstClass b, IsSized b sb) =>+    Storable b, MakeValueTuple b (Value b), IsConst b,+    Memory.FirstClass b bm, IsSized b bsize, IsSized bm bmsize) =>    Param.T p b -> T p a -> T p a interpolateConstant k       (Cons next start createIOContext deleteIOContext) =@@ -281,50 +254,44 @@   mix ::-   (IsArithmetic a) =>-   T p (Value a) -> T p (Value a) -> T p (Value a)+   (A.Additive a) =>+   T p a -> T p a -> T p a mix =-   zipWithSimple Sample.mixMono--mixStereo ::-   (IsArithmetic a) =>-   T p (Stereo.T (Value a)) -> T p (Stereo.T (Value a)) -> T p (Stereo.T (Value a))-mixStereo =-   zipWithSimple Sample.mixStereo+   zipWithSimple Frame.mix   envelope ::-   (IsArithmetic a) =>-   T p (Value a) -> T p (Value a) -> T p (Value a)+   (A.PseudoRing a) =>+   T p a -> T p a -> T p a envelope =-   zipWithSimple Sample.amplifyMono+   zipWithSimple Frame.amplifyMono  envelopeStereo ::-   (IsArithmetic a) =>-   T p (Value a) -> T p (Stereo.T (Value a)) -> T p (Stereo.T (Value a))+   (A.PseudoRing a) =>+   T p a -> T p (Stereo.T a) -> T p (Stereo.T a) envelopeStereo =-   zipWithSimple Sample.amplifyStereo+   zipWithSimple Frame.amplifyStereo  amplify ::-   (IsArithmetic a, Storable a,-    MakeValueTuple a (Value a), IsFirstClass a, IsSized a size) =>-   Param.T p a -> T p (Value a) -> T p (Value a)+   (A.PseudoRing al, Storable a,+    MakeValueTuple a al, Memory.C al am, IsSized am as) =>+   Param.T p a -> T p al -> T p al amplify =-   map Sample.amplifyMono+   map Frame.amplifyMono  amplifyStereo ::-   (IsArithmetic a, Storable a,-    MakeValueTuple a (Value a), IsFirstClass a, IsSized a size) =>-   Param.T p a -> T p (Stereo.T (Value a)) -> T p (Stereo.T (Value a))+   (A.PseudoRing al, Storable a,+    MakeValueTuple a al, Memory.C al am, IsSized am as) =>+   Param.T p a -> T p (Stereo.T al) -> T p (Stereo.T al) amplifyStereo =-   map Sample.amplifyStereo+   map Frame.amplifyStereo   -- * signal generators  constant ::    (Storable a, MakeValueTuple a al,-    Rep.Memory al packed, IsSized packed s) =>+    Memory.C al packed, IsSized packed s) =>    Param.T p a -> T p al constant x =    simple@@ -335,28 +302,29 @@   exponentialCore ::-   (Storable a, MakeValueTuple a (Value a),-    IsFirstClass a, IsSized a s, IsArithmetic a, IsConst a) =>-   Param.T p a -> Param.T p a -> T p (Value a)+   (Storable a, MakeValueTuple a al,+    Memory.C al am, IsSized am as, A.PseudoRing al) =>+   Param.T p a -> Param.T p a -> T p al exponentialCore =    iterate A.mul  exponential2 ::    (Trans.C a, Storable a, MakeValueTuple a (Value a),-    IsFirstClass a, IsSized a s, IsArithmetic a, IsConst a) =>+    Memory.FirstClass a am, IsSized a s, IsSized am amsize,+    IsArithmetic a, IsConst a) =>    Param.T p a -> Param.T p a -> T p (Value a) exponential2 halfLife =    exponentialCore (0.5 ** recip halfLife)   exponentialBoundedCore ::-   (Storable a, MakeValueTuple a (Value a),-    IsFirstClass a, IsSized a s, SoV.Real a, IsConst a) =>+   (Storable a, MakeValueTuple a al,+    Memory.C al am, IsSized am as, A.PseudoRing al, A.Real al) =>    Param.T p a -> Param.T p a -> Param.T p a ->-   T p (Value a)+   T p al exponentialBoundedCore bound decay =    iterate-      (\(b,k) y -> SoV.max b =<< A.mul k y)+      (\(b,k) y -> A.max b =<< A.mul k y)       (liftA2 (,) bound decay)  {- |@@ -367,7 +335,8 @@ -} exponentialBounded2 ::    (Trans.C a, Storable a, MakeValueTuple a (Value a),-    IsFirstClass a, IsSized a s, SoV.Real a, IsConst a) =>+    Memory.FirstClass a am, IsSized a s, IsSized am amsize,+    SoV.Real a, IsConst a) =>    Param.T p a -> Param.T p a -> Param.T p a ->    T p (Value a) exponentialBounded2 bound halfLife =@@ -375,18 +344,17 @@   osciCore ::-   (Storable t, MakeValueTuple t (Value t),-    IsFirstClass t, IsSized t size,-    SoV.Fraction t, IsConst t) =>-   Param.T p t -> Param.T p t -> T p (Value t)+   (Storable t, MakeValueTuple t tl,+    Memory.C tl tm, IsSized tm ts, A.Fraction tl) =>+   Param.T p t -> Param.T p t -> T p tl osciCore phase freq =-   iterate SoV.incPhase freq phase+   iterate A.incPhase freq phase  osci ::    (Storable t, MakeValueTuple t (Value t),     Storable c, MakeValueTuple c cl,-    IsFirstClass t, IsSized t size,-    Rep.Memory cl cp, IsSized cp cs,+    Memory.FirstClass t tm, IsSized t tsize, IsSized tm tmsize,+    Memory.C cl cp, IsSized cp cs,     SoV.Fraction t, IsConst t) =>    (forall r. cl -> Value t -> CodeGenFunction r y) ->    Param.T p c ->@@ -397,7 +365,7 @@  osciSimple ::    (Storable t, MakeValueTuple t (Value t),-    IsFirstClass t, IsSized t size,+    Memory.FirstClass t tm, IsSized t tsize, IsSized tm tmsize,     SoV.Fraction t, IsConst t) =>    (forall r. Value t -> CodeGenFunction r y) ->    Param.T p t -> Param.T p t -> T p y@@ -407,7 +375,7 @@ osciSaw ::    (Ring.C a0, IsConst a0, SoV.Replicate a0 a,     Storable a, MakeValueTuple a (Value a),-    IsFirstClass a, IsSized a size,+    Memory.FirstClass a am, IsSized a asize, IsSized am amsize,     SoV.Fraction a, IsPrimitive a, IsConst a) =>    Param.T p a -> Param.T p a -> T p (Value a) osciSaw =@@ -417,13 +385,15 @@  rampCore ::    (Storable a, MakeValueTuple a (Value a),-    IsFirstClass a, IsSized a s, IsArithmetic a, IsConst a) =>+    Memory.FirstClass a am, IsSized a asize, IsSized am amsize,+    IsArithmetic a, IsConst a) =>    Param.T p a -> Param.T p a -> T p (Value a) rampCore = iterate A.add  parabolaCore ::    (Storable a, MakeValueTuple a (Value a),-    IsFirstClass a, IsSized a s, IsArithmetic a, IsConst a) =>+    Memory.FirstClass a am, IsSized a asize, IsSized am amsize,+    IsArithmetic a, IsConst a) =>    Param.T p a -> Param.T p a -> Param.T p a -> T p (Value a) parabolaCore d2 d1 start =    Causal.apply (Causal.integrate start) $@@ -434,7 +404,8 @@ rampInf, rampSlope,  parabolaFadeInInf, parabolaFadeOutInf ::    (Field.C a, Storable a, MakeValueTuple a (Value a),-    IsFirstClass a, IsSized a s, IsArithmetic a, IsConst a) =>+    Memory.FirstClass a am, IsSized a asize, IsSized am amsize,+    IsArithmetic a, IsConst a) =>    Param.T p a -> T p (Value a) rampSlope slope  =  rampCore slope Additive.zero rampInf dur  =  rampSlope (recip dur)@@ -469,7 +440,8 @@  parabolaFadeIn, parabolaFadeOut,  parabolaFadeInMap, parabolaFadeOutMap ::    (RealField.C a, Storable a, MakeValueTuple a (Value a),-    IsFirstClass a, IsSized a s, IsArithmetic a, IsConst a) =>+    Memory.FirstClass a am, IsSized a asize, IsSized am amsize,+    IsArithmetic a, IsConst a) =>    Param.T p a -> T p (Value a)  ramp dur =@@ -515,6 +487,7 @@ noise ::    (Algebraic.C a, IsFloating a, IsConst a,     NumberOfElements TypeNum.D1 a,+    Memory.C (Value a) as, IsSized as sas,     IsSized a ps, MakeValueTuple a (Value a), Storable a) =>    Param.T p Word32 ->    Param.T p a ->@@ -524,15 +497,22 @@    in  map (\r y ->           A.mul r            =<< flip A.sub (valueOf $ m2+1)-          {--          In principle it must be uitofp,-          but sitofp is a single instruction on x86-          and our numbers are below 2^31.-          -}-           =<< sitofp y)+           =<< int31tofp y)           (sqrt (3 * rate) / return m2) $        noiseCore seed +{-+sitofp is a single instruction on x86+and thus we use it, since the arguments are below 2^31.+-}+int31tofp ::+   (IsFloating a, LLVM.NumberOfElements TypeNum.D1 a) =>+   Value Word32 -> CodeGenFunction r (Value a)+int31tofp =+   LLVM.inttofp <=<+   (LLVM.bitcastUnify ::+       Value Word32 -> CodeGenFunction r (Value Int32))+ noiseCore, noiseCoreAlt ::    Param.T p Word32 ->    T p (Value Word32)@@ -548,15 +528,15 @@ -- * conversion from and to storable vectors  fromStorableVector ::-   (Storable a, MakeValueTuple a value, Rep.Memory value struct) =>+   (Storable a, MakeValueTuple a value, Memory.C value struct) =>    Param.T p (SV.Vector a) ->    T p value fromStorableVector selectVec =    Cons       (\() (p0,l0) -> do-         cont <- Maybe.lift $ A.icmp IntUGT l0 (valueOf 0)+         cont <- Maybe.lift $ A.cmp CmpGT l0 (valueOf 0)          Maybe.withBool cont $ do-            y1 <- Rep.load p0+            y1 <- Memory.load p0             p1 <- advanceArrayElementPtr p0             l1 <- A.dec l0             return (y1,(p1,l1)))@@ -565,7 +545,7 @@          let (fp,s,l) = SVB.toForeignPtr $ Param.get selectVec p          in  return (fp,                 ((),-                 (Rep.castStorablePtr $ unsafeForeignPtrToPtr fp `advancePtr` s,+                 (Memory.castStorablePtr $ unsafeForeignPtrToPtr fp `advancePtr` s,                   fromIntegral l :: Word32))))       -- keep the foreign ptr alive       touchForeignPtr@@ -576,7 +556,7 @@ and advances to the next chunk in the sequence. -} fromStorableVectorLazy ::-   (Storable a, MakeValueTuple a value, Rep.Memory value struct) =>+   (Storable a, MakeValueTuple a value, Memory.C value struct) =>    Param.T p (SVL.Vector a) ->    T p value fromStorableVectorLazy sig =@@ -584,14 +564,14 @@       (\(stable, lenPtr) (buffer0,length0) -> do          (buffer1,length1) <- Maybe.lift $ do             nextChunkFn <- staticFunction ChunkIt.nextCallBack-            needNext <- A.icmp IntEQ length0 (valueOf 0)+            needNext <- A.cmp CmpEQ length0 (valueOf 0)             ifThen needNext (buffer0,length0)                (liftM2 (,)                    (call nextChunkFn stable lenPtr)                    (load lenPtr))-         valid <- Maybe.lift $ A.icmp IntNE buffer1 (valueOf nullPtr)+         valid <- Maybe.lift $ A.cmp CmpNE buffer1 (valueOf nullPtr)          Maybe.withBool valid $ do-            x <- Rep.load buffer1+            x <- Memory.load buffer1             buffer2 <- advanceArrayElementPtr buffer1             length2 <- A.dec length1             return (x, (buffer2,length2)))@@ -604,40 +584,13 @@           Alloc.free lenPtr)  + piecewiseConstant ::-   (Storable a, MakeValueTuple a value, Rep.Memory value struct, IsSized struct size) =>+   (Storable a, MakeValueTuple a value, Memory.C value struct, IsSized struct size) =>    Param.T p (EventList.T NonNeg.Int a) ->    T p value-piecewiseConstant evs =-   Cons-      (\(stable, yPtr) (y0,length0) -> do-         (y1,length1) <- Maybe.lift $ do-            nextFn <- staticFunction EventIt.nextCallBack-            needNext <- A.icmp IntEQ length0 (valueOf 0)-            ifThen needNext (y0,length0)-               (fmap swap $-                liftM2 (,)-                   (call nextFn stable yPtr)-                   (Rep.load yPtr))-         Maybe.guard =<<-            Maybe.lift (A.icmp IntNE length1 (valueOf 0))-         length2 <- Maybe.lift (A.dec length1)-         return (y1, (y1,length2)))-      (\() -> return (undefTuple, valueOf 0))-      (\p -> do-         stable <- EventIt.new (Param.get evs p)-         yPtr <- Alloc.malloc-         return ((stable, asTypeOfEventListElement yPtr evs),-                 ((stable, Rep.castStorablePtr yPtr), ())))-      (\(stable,yPtr) -> do-         EventIt.dispose stable-         Alloc.free yPtr)--asTypeOfEventListElement ::-   Ptr a ->-   Param.T p (EventList.T NonNeg.Int a) ->-   Ptr a-asTypeOfEventListElement ptr _ = ptr+piecewiseConstant =+   Const.flatten . Const.piecewiseConstant   @@ -649,31 +602,15 @@ lazySize ::    Param.T p SVP.LazySize ->    T p ()-lazySize size =-   Cons-      (\stable length0 -> do-         length1 <- Maybe.lift $ do-            nextFn <- staticFunction SizeIt.nextCallBack-            needNext <- A.icmp IntEQ length0 (valueOf 0)-            ifThen needNext length0-               (call nextFn stable)-         Maybe.guard =<<-            Maybe.lift (A.icmp IntNE length1 (valueOf 0))-         length2 <- Maybe.lift (A.dec length1)-         return ((), length2))-      (\() -> return (valueOf 0))-      (\p -> do-         stable <- SizeIt.new (Param.get size p)-         return (stable, (stable, ())))-      (\stable ->-         SizeIt.dispose stable)+lazySize =+   Const.flatten . Const.lazySize   foreign import ccall safe "dynamic" derefFillPtr ::    Exec.Importer (Ptr param -> Word32 -> Ptr a -> IO Word32)  run ::-   (Storable a, MakeValueTuple a value, Rep.Memory value struct) =>+   (Storable a, MakeValueTuple a value, Memory.C value struct) =>    T p value ->    IO (Int -> p -> SV.Vector a) run (Cons next start createIOContext deleteIOContext) =@@ -681,13 +618,13 @@       fill <-          fmap derefFillPtr .          Exec.compileModule .-         createFunction ExternalLinkage $+         createNamedFunction ExternalLinkage "fillsignalblock" $          \paramPtr size bPtr -> do-            (nextParam,startParam) <- Rep.load paramPtr+            (nextParam,startParam) <- Memory.load paramPtr             s <- start startParam             (pos,_) <- Maybe.arrayLoop size bPtr s $ \ ptri s0 -> do                (y,s1) <- next nextParam s0-               Maybe.lift $ Rep.store y ptri+               Maybe.lift $ Memory.store y ptri                return s1             ret (pos :: Value Word32) @@ -696,17 +633,16 @@          bracket (createIOContext p) (deleteIOContext . fst) $          \ (_,params) ->             SVB.createAndTrim len $ \ ptr ->-            Alloc.alloca $ \paramPtr ->-               poke paramPtr params >>+            Alloc.with params $ \paramPtr ->                (fmap fromIntegral $-                  fill (Rep.castStorablePtr paramPtr)-                     (fromIntegral len) (Rep.castStorablePtr ptr))+                  fill (Memory.castStorablePtr paramPtr)+                     (fromIntegral len) (Memory.castStorablePtr ptr))  {- | This is not really a function, see 'renderChunky'. -} render ::-   (Storable a, MakeValueTuple a value, Rep.Memory value struct) =>+   (Storable a, MakeValueTuple a value, Memory.C value struct) =>    T p value -> Int -> p -> SV.Vector a render gen = unsafePerformIO $ run gen @@ -715,12 +651,49 @@    Exec.Importer (Ptr nextParamStruct -> Ptr stateStruct -> Word32 -> Ptr struct -> IO Word32)  +moduleChunky ::+   (Memory.C value struct,+    Memory.C state stateStruct,+    IsSized stateStruct stateSize,+    Memory.C startParamValue startParamStruct,+    Memory.C nextParamValue  nextParamStruct,+    IsSized    startParamStruct startParamSize,+    IsSized    nextParamStruct  nextParamSize) =>+   (forall r.+    nextParamValue ->+    state -> Maybe.T r (Value Bool, state) (value, state)) ->+   (forall r.+    startParamValue ->+    CodeGenFunction r state) ->+   CodeGenModule+      (Function (Ptr startParamStruct -> IO (Ptr stateStruct)),+       Function (Ptr stateStruct -> IO ()),+       Function (Ptr nextParamStruct -> Ptr stateStruct -> Word32 -> Ptr struct -> IO Word32))+moduleChunky next start = liftM3 (,,)+   (createNamedFunction ExternalLinkage "startsignal" $+    \paramPtr -> do+       pptr <- LLVM.malloc+       flip Memory.store pptr =<< start =<< Memory.load paramPtr+       ret pptr)+   (createNamedFunction ExternalLinkage "stopsignal" $+    \ pptr -> LLVM.free pptr >> ret ())+   (createNamedFunction ExternalLinkage "fillsignal" $+    \ paramPtr sptr loopLen ptr -> do+       param <- Memory.load paramPtr+       sInit <- Memory.load sptr+       (pos,sExit) <- Maybe.arrayLoop loopLen ptr sInit $ \ ptri s0 -> do+          (y,s1) <- next param s0+          Maybe.lift $ Memory.store y ptri+          return s1+       Memory.store sExit sptr+       ret (pos :: Value Word32))+ compileChunky ::-   (Rep.Memory value struct,-    Rep.Memory state stateStruct,+   (Memory.C value struct,+    Memory.C state stateStruct,     IsSized stateStruct stateSize,-    Rep.Memory startParamValue startParamStruct,-    Rep.Memory nextParamValue  nextParamStruct,+    Memory.C startParamValue startParamStruct,+    Memory.C nextParamValue  nextParamStruct,     IsSized    startParamStruct startParamSize,     IsSized    nextParamStruct  nextParamSize) =>    (forall r.@@ -733,35 +706,82 @@        FunPtr (Ptr stateStruct -> IO ()),        FunPtr (Ptr nextParamStruct -> Ptr stateStruct -> Word32 -> Ptr struct -> IO Word32)) compileChunky next start =-   Exec.compileModule $-      liftM3 (,,)-         (createFunction ExternalLinkage $-          \paramPtr -> do-             -- danger: size computation in LLVM currently does not work for structs!-             pptr <- Rep.malloc-             flip Rep.store pptr =<< start =<< Rep.load paramPtr-             ret pptr)-         (createFunction ExternalLinkage $-          \ pptr -> Rep.free pptr >> ret ())-         (createFunction ExternalLinkage $-          \ paramPtr sptr loopLen ptr -> do-             param <- Rep.load paramPtr-             sInit <- Rep.load sptr-             (pos,sExit) <- Maybe.arrayLoop loopLen ptr sInit $ \ ptri s0 -> do-                (y,s1) <- next param s0-                Maybe.lift $ Rep.store y ptri-                return s1-             Rep.store sExit sptr-             ret (pos :: Value Word32))+   Exec.compileModule $ moduleChunky next start +debugMain ::+   forall+      struct stateStruct+      startParamValue startParamStruct startParamSize+      nextParamValue  nextParamStruct  nextParamSize.+   (Storable startParamValue,+    Storable nextParamValue,+    LLVM.IsType struct,+    LLVM.IsType stateStruct,+    LLVM.IsType startParamStruct,+    LLVM.IsType nextParamStruct,+    IsSized    startParamStruct startParamSize,+    IsSized    nextParamStruct  nextParamSize) =>+   CodeGenModule+      (Function (Ptr startParamStruct -> IO (Ptr stateStruct)),+       Function (Ptr stateStruct -> IO ()),+       Function (Ptr nextParamStruct -> Ptr stateStruct -> Word32 -> Ptr struct -> IO Word32)) ->+   (nextParamValue, startParamValue) ->+   IO (Function (Word32 -> Ptr (Ptr Word8) -> IO Word32))+debugMain sigModule (nextParam, startParam) = do+{-+This does not work, since we cannot add (Mul n D32 s) constraint+to the function argument in reifyIntegral.+   nextArray <-+      DebugSt.withConstArray nextParam (\arr -> do+         ptr <- LLVM.alloca+         LLVM.store (value arr) ptr+         LLVM.bitcastUnify ptr)+-}+   nextArray <-+      DebugSt.withConstArray nextParam (\arr -> do+         ptr <- LLVM.alloca+         LLVM.store (value arr) =<< LLVM.bitcastUnify ptr+         return ptr)+   startArray <-+      DebugSt.withConstArray startParam (\arr -> do+         ptr <- LLVM.alloca+         LLVM.store (value arr) =<< LLVM.bitcastUnify ptr+         return ptr) +   m <- LLVM.newModule++   mainFunc <- defineModule m (do+      mallocBytes <- LLVM.newNamedFunction ExternalLinkage "malloc" ::+         LLVM.TFunction (Ptr Word8 -> IO (Ptr struct))+      (start, stop, fill) <- sigModule+      createNamedFunction ExternalLinkage "main" $ \ _argc _argv -> do+         state <- LLVM.call start =<< startArray+         let chunkSize = LLVM.valueOf 100000+             basePtr = LLVM.valueOf nullPtr+         buffer <-+            LLVM.call mallocBytes =<<+            LLVM.bitcastUnify =<<+            LLVM.getElementPtr basePtr (chunkSize, ())+         nextPtr <- nextArray+         _done <-+            LLVM.call fill nextPtr state chunkSize (asTypeOf buffer basePtr)+         _ <- LLVM.call stop state+         ret (LLVM.value LLVM.zero :: LLVM.Value Word32))++   Counter.with Exec.counter $ R.ReaderT $ \cnt -> do+      writeBitcodeToFile ("main" ++ Counter.format 3 cnt ++ ".bc") m++   return mainFunc+++ {- | Renders a signal generator to a chunky storable vector with given pattern. If the pattern is shorter than the generated signal this means that the signal is shortened. -} runChunkyPattern ::-   (Storable a, MakeValueTuple a value, Rep.Memory value struct) =>+   (Storable a, MakeValueTuple a value, Memory.C value struct) =>    T p value ->    IO (SVP.LazySize -> p -> SVL.Vector a) runChunkyPattern (Cons next start createIOContext deleteIOContext) = do@@ -770,9 +790,20 @@       \ lazysize p -> SVL.fromChunks $ unsafePerformIO $ do          (ioContext, (nextParam, startParam)) <- createIOContext p -         statePtr <- Rep.newForeignPtrParam stopFunc startFunc startParam-         nextParamPtr <- Rep.newForeignPtr (deleteIOContext ioContext) nextParam+{-+         putStr "nextParam: "+         DebugSt.format nextParam >>= putStrLn+-}+         when False $ Counter.with DebugSt.dumpCounter $ do+            DebugSt.dump "next-param" nextParam+            DebugSt.dump "start-param" startParam +         when False $ fmap (const ()) $+            debugMain (moduleChunky next start) (nextParam, startParam)++         statePtr <- ForeignPtr.newParam stopFunc startFunc startParam+         nextParamPtr <- ForeignPtr.new (deleteIOContext ioContext) nextParam+          let go cs =                 unsafeInterleaveIO $                 case cs of@@ -780,11 +811,11 @@                    SVL.ChunkSize size : rest -> do                       v <-                          withForeignPtr statePtr $ \sptr ->-                         Rep.withForeignPtr nextParamPtr $ \nptr ->+                         ForeignPtr.with nextParamPtr $ \nptr ->                          SVB.createAndTrim size $                          fmap fromIntegral .                          derefChunkPtr fill nptr sptr (fromIntegral size) .-                         Rep.castStorablePtr+                         Memory.castStorablePtr                       (if SV.length v > 0                          then fmap (v:)                          else id) $@@ -794,7 +825,7 @@          go (Chunky.toChunks lazysize)  runChunky ::-   (Storable a, MakeValueTuple a value, Rep.Memory value struct) =>+   (Storable a, MakeValueTuple a value, Memory.C value struct) =>    T p value ->    IO (SVL.ChunkSize -> p -> SVL.Vector a) runChunky sig =@@ -812,7 +843,7 @@ and I assume that you use this package exclusively for performance reasons. -} renderChunky ::-   (Storable a, MakeValueTuple a value, Rep.Memory value struct) =>+   (Storable a, MakeValueTuple a value, Memory.C value struct) =>    SVL.ChunkSize -> T p value ->    p -> SVL.Vector a renderChunky size gen =
src/Synthesizer/LLVM/Parameterized/SignalPacked.hs view
@@ -28,22 +28,23 @@ import Synthesizer.LLVM.Parameterized.Signal (T(Cons), ) import qualified Synthesizer.LLVM.Parameterized.Signal as Sig import qualified Synthesizer.LLVM.Parameter as Param+import qualified Synthesizer.LLVM.SerialVector as Serial  import qualified Synthesizer.LLVM.Random as Rnd-import qualified LLVM.Extra.Representation as Rep+import qualified LLVM.Extra.Memory as Memory import qualified LLVM.Extra.ScalarOrVector as SoV import qualified LLVM.Extra.Vector as Vector import qualified LLVM.Extra.MaybeContinuation as Maybe import qualified LLVM.Extra.Control as U-import LLVM.Extra.Control (whileLoop, )--import qualified Data.TypeLevel.Num as TypeNum- import qualified LLVM.Extra.Class as Class import qualified LLVM.Extra.Arithmetic as A+import LLVM.Extra.Class (MakeValueTuple, Undefined, undefTuple, ) +import qualified Data.TypeLevel.Num as TypeNum+ import LLVM.Core as LLVM +import Control.Monad.HT ((<=<), ) -- we can also use <$> for parameters import Control.Arrow ((^<<), ) import Control.Applicative (liftA2, )@@ -51,10 +52,10 @@ import qualified Algebra.Transcendental as Trans import qualified Algebra.Algebraic as Algebraic import qualified Algebra.RealField as RealField-import qualified Algebra.Field as Field import qualified Algebra.Ring as Ring  import Data.Word (Word32, )+import Data.Int (Int32, ) import Foreign.Storable (Storable, )  import qualified Data.List as List@@ -84,7 +85,7 @@              in  (v, valueOf $ (fromIntegral $ Vector.sizeInTuple v :: Word32), s))             (\(cont,(_v0,i0,_s0)) ->                A.and cont =<<-                  A.icmp IntUGT i0 (value LLVM.zero))+                  A.cmp CmpGT i0 (value LLVM.zero))             (\(_,(v0,i0,s0)) -> Maybe.toBool $ do                (a,s1) <- next param s0                Maybe.lift $ do@@ -104,7 +105,7 @@             (valueOf True, (undefTuple, value LLVM.zero, s))             (\(cont,(v0,i0,_s0)) ->                A.and cont =<<-                  A.icmp IntULT i0+                  A.cmp CmpLT i0                      (valueOf $ fromIntegral $ Vector.sizeInTuple v0))             (\(_,(v0,i0,s0)) -> Maybe.toBool $ do                (a,s1) <- next param s0@@ -144,14 +145,14 @@   unpack, unpackRotate, unpackIndex ::-   (Vector.Access n a v, Rep.Memory v vp, IsSized vp vs) =>+   (Vector.Access n a v, Memory.C v vp, IsSized vp vs) =>    T p v -> T p a unpack = unpackRotate  unpackRotate (Cons next start createIOContext deleteIOContext) = Cons    (\param (i0,v0,s0) -> do       endOfVector <--         Maybe.lift $ A.icmp IntEQ i0 (valueOf 0)+         Maybe.lift $ A.cmp CmpEQ i0 (valueOf 0)       (i2,v2,s2) <-          Maybe.fromBool $          U.ifThen endOfVector (valueOf True, (i0,v0,s0)) $ do@@ -171,7 +172,7 @@ unpackIndex (Cons next start createIOContext deleteIOContext) = Cons    (\param (i0,v0,s0) -> do       endOfVector <--         Maybe.lift $ A.icmp IntUGE i0+         Maybe.lift $ A.cmp CmpGE i0             (valueOf $ fromIntegral $ Vector.sizeInTuple v0)       (i2,v2,s2) <-          Maybe.fromBool $@@ -195,43 +196,60 @@    T p (Value (Vector n a)) withSize f = f undefined +withSizeRing ::+   (Ring.C b, TypeNum.Nat n) =>+   (b -> T p (Value (Vector n a))) ->+   T p (Value (Vector n a))+withSizeRing f =+   withSize $ \n -> f (fromIntegral $ TypeNum.toInt n) + constant ::    (Storable a,  MakeValueTuple a (Value a),-    IsConst a, IsPrimitive a,-    IsPowerOf2 n, IsSized (Vector n a) s) =>---    IsPowerOf2 n, IsSized a s, TypeNum.Pos vs, TypeNum.Mul n s vs) =>+    IsConst a,+    Memory.FirstClass a am,+    IsPrimitive a,  IsSized a as,+    IsPrimitive am, IsSized am amsize,+    TypeNum.Mul n as vas, TypeNum.Pos vas,+    TypeNum.Mul n amsize vmsize, TypeNum.Pos vmsize,+    TypeNum.Pos n) =>    Param.T p a -> T p (Value (Vector n a)) constant x =-   Sig.constant (LLVM.vector . (:[]) ^<< x)+   Sig.constant (Serial.replicate ^<< x)   exponential2 ::    (Trans.C a, Storable a, MakeValueTuple a (Value a),-    IsFirstClass a, IsSized a s, IsSized (Vector n a) vs,-    IsPrimitive a, IsArithmetic a, IsConst a,-    IsPowerOf2 n) =>+    IsArithmetic a, IsConst a,+    Memory.FirstClass a am,+    IsPrimitive a,  IsSized a as,+    IsPrimitive am, IsSized am amsize,+    TypeNum.Mul n as vas, TypeNum.Pos vas,+    TypeNum.Mul n amsize vmsize, TypeNum.Pos vmsize,+    TypeNum.Pos n) =>    Param.T p a -> Param.T p a -> T p (Value (Vector n a))-exponential2 halfLife start = withSize $ \n ->+exponential2 halfLife start = withSizeRing $ \n ->    Sig.exponentialCore-      (LLVM.vector . (:[]) ^<<-         0.5 ** (fromIntegral (TypeNum.toInt n) / halfLife))+      (Serial.replicate ^<< 0.5 ** (n / halfLife))       (liftA2          (\h -> LLVM.vector . List.iterate (0.5 ** recip h *))          halfLife start)  exponentialBounded2 ::    (Trans.C a, Storable a, MakeValueTuple a (Value a),-    IsFirstClass a, IsSized a s, IsSized (Vector n a) vs,-    IsPrimitive a, Vector.Real a, IsConst a,-    IsPowerOf2 n) =>+    Vector.Real a, IsConst a,+    Memory.FirstClass a am,+    IsPrimitive a,  IsSized a as,+    IsPrimitive am, IsSized am amsize,+    TypeNum.Mul n as vas, TypeNum.Pos vas,+    TypeNum.Mul n amsize vmsize, TypeNum.Pos vmsize,+    TypeNum.Pos n) =>    Param.T p a -> Param.T p a -> Param.T p a ->    T p (Value (Vector n a))-exponentialBounded2 bound halfLife start = withSize $ \n ->+exponentialBounded2 bound halfLife start = withSizeRing $ \n ->    Sig.exponentialBoundedCore-      (fmap (LLVM.vector . (:[])) bound)-      (LLVM.vector . (:[]) ^<<-         0.5 ** (fromIntegral (TypeNum.toInt n) / halfLife))+      (fmap (Serial.replicate) bound)+      (Serial.replicate ^<< 0.5 ** (n / halfLife))       (liftA2          (\h -> LLVM.vector . List.iterate (0.5 ** recip h *))          halfLife start)@@ -239,26 +257,34 @@  osciCore ::    (Storable t, MakeValueTuple t (Value t),-    IsFirstClass t, IsSized t size, IsSized (Vector n t) vsize,+    Memory.FirstClass t tm,+    IsPrimitive t,  IsSized t tsize,+    IsPrimitive tm, IsSized tm tmsize,+    TypeNum.Mul n tsize vtsize, TypeNum.Pos vtsize,+    TypeNum.Mul n tmsize vmsize, TypeNum.Pos vmsize,     Vector.Real t, IsFloating t, RealField.C t, IsConst t,-    IsPowerOf2 n) =>+    TypeNum.Pos n) =>    Param.T p t -> Param.T p t -> T p (Value (Vector n t))-osciCore phase freq = withSize $ \n ->+osciCore phase freq = withSizeRing $ \n ->    Sig.osciCore       (liftA2          (\f -> LLVM.vector . List.iterate (fraction . (f +)))          freq phase)       (fmap-         (\f -> LLVM.vector [fraction (fromIntegral (TypeNum.toInt n) * f)])+         (\f -> LLVM.vector [fraction (n * f)])          freq)  osci ::    (Storable t, MakeValueTuple t (Value t),     Storable c, MakeValueTuple c cl,-    IsFirstClass t, IsSized t size, IsSized (Vector n t) vsize,-    Rep.Memory cl cp, IsSized cp cs,+    Memory.FirstClass t tm,+    IsPrimitive t,  IsSized t tsize,+    IsPrimitive tm, IsSized tm tmsize,+    TypeNum.Mul n tsize vtsize, TypeNum.Pos vtsize,+    TypeNum.Mul n tmsize vmsize, TypeNum.Pos vmsize,+    Memory.C cl cp, IsSized cp cs,     Vector.Real t, IsFloating t, RealField.C t, IsConst t,-    IsPowerOf2 n) =>+    TypeNum.Pos n) =>    (forall r. cl -> Value (Vector n t) -> CodeGenFunction r y) ->    Param.T p c ->    Param.T p t -> Param.T p t -> T p y@@ -268,9 +294,13 @@  osciSimple ::    (Storable t, MakeValueTuple t (Value t),-    IsFirstClass t, IsSized t size, IsSized (Vector n t) vsize,+    Memory.FirstClass t tm,+    IsPrimitive t,  IsSized t tsize,+    IsPrimitive tm, IsSized tm tmsize,+    TypeNum.Mul n tsize vtsize, TypeNum.Pos vtsize,+    TypeNum.Mul n tmsize vmsize, TypeNum.Pos vmsize,     Vector.Real t, IsFloating t, RealField.C t, IsConst t,-    IsPowerOf2 n) =>+    TypeNum.Pos n) =>    (forall r. Value (Vector n t) -> CodeGenFunction r y) ->    Param.T p t -> Param.T p t -> T p y osciSimple wave =@@ -280,57 +310,63 @@ rampInf, rampSlope,  parabolaFadeInInf, parabolaFadeOutInf ::    (RealField.C a, Storable a, MakeValueTuple a (Value a),-    IsPrimitive a, IsArithmetic a, IsConst a,-    IsPowerOf2 n, IsSized (Vector n a) s) =>+    Memory.FirstClass a am,+    IsPrimitive a,  IsSized a as,+    IsPrimitive am, IsSized am amsize,+    TypeNum.Mul n as vas, TypeNum.Pos vas,+    TypeNum.Mul n amsize vmsize, TypeNum.Pos vmsize,+    IsArithmetic a, IsConst a, TypeNum.Pos n) =>    Param.T p a -> T p (Value (Vector n a))-rampSlope slope = withSize $ \n ->+rampSlope slope = withSizeRing $ \n ->    Sig.rampCore-      (fmap (\s -> LLVM.vector [fromIntegral (TypeNum.toInt n) * s]) slope)+      (fmap (\s -> LLVM.vector [n * s]) slope)       (fmap (\s -> LLVM.vector (List.iterate (s +) 0)) slope) rampInf dur = rampSlope (recip dur) -parabolaFadeInInf dur = withSize $ \ni ->-   let n = fromIntegral (TypeNum.toInt ni)-   in  Sig.parabolaCore-          (fmap-             (\dr ->-                let d = n / dr-                in  LLVM.vector [-2*d*d]) dur)-          (fmap-             (\dr ->-                let d = n / dr-                in  LLVM.vector $ List.iterate (subtract $ 2 / dr ^ 2) (d*(2-d)))-             dur)-          (fmap-             (\dr ->-                LLVM.vector $ List.map (\t -> t*(2-t)) $ List.iterate (recip dr +) 0)-             dur)+parabolaFadeInInf dur = withSizeRing $ \n ->+   Sig.parabolaCore+      (fmap+         (\dr ->+            let d = n / dr+            in  LLVM.vector [-2*d*d]) dur)+      (fmap+         (\dr ->+            let d = n / dr+            in  LLVM.vector $ List.iterate (subtract $ 2 / dr ^ 2) (d*(2-d)))+         dur)+      (fmap+         (\dr ->+            LLVM.vector $ List.map (\t -> t*(2-t)) $ List.iterate (recip dr +) 0)+         dur) -parabolaFadeOutInf dur = withSize $ \ni ->-   let n = fromIntegral (TypeNum.toInt ni)-   in  Sig.parabolaCore-          (fmap-             (\dr ->-                let d = n / dr-                in  LLVM.vector [-2*d*d]) dur)-          (fmap-             (\dr ->-                let d = n / dr-                in  LLVM.vector $ List.iterate (subtract $ 2 / dr ^ 2) (-d*d))-             dur)-          (fmap-             (\dr ->-                LLVM.vector $ List.map (\t -> 1-t*t) $ List.iterate (recip dr +) 0)-             dur)+parabolaFadeOutInf dur = withSizeRing $ \n ->+   Sig.parabolaCore+      (fmap+         (\dr ->+            let d = n / dr+            in  LLVM.vector [-2*d*d]) dur)+      (fmap+         (\dr ->+            let d = n / dr+            in  LLVM.vector $ List.iterate (subtract $ 2 / dr ^ 2) (-d*d))+         dur)+      (fmap+         (\dr ->+            LLVM.vector $ List.map (\t -> 1-t*t) $ List.iterate (recip dr +) 0)+         dur)   {- | For the mysterious rate parameter see 'Sig.noise'. -} noise ::-   (Algebraic.C a, IsFloating a, IsConst a, IsPrimitive a,-    IsPowerOf2 n, IsSized (Vector n Word32) s,-    IsSized a as, TypeNum.Mul n as vas, TypeNum.Pos vas,+   (Algebraic.C a, IsFloating a, IsConst a,+    TypeNum.Pos n, TypeNum.Mul n TypeNum.D32 s, TypeNum.Pos s,+    Memory.FirstClass a am,+    IsPrimitive a,  IsSized a as,+    IsPrimitive am, IsSized am amsize,+    TypeNum.Mul n as vas, TypeNum.Pos vas,+    TypeNum.Mul n amsize vmsize, TypeNum.Pos vmsize,     MakeValueTuple a (Value a), Storable a) =>    Param.T p Word32 ->    Param.T p a ->@@ -340,17 +376,27 @@    in  Sig.map (\r y ->           A.mul r            =<< flip A.sub (SoV.replicateOf $ m2+1)-           {--           In principle it must be uitofp,-           but sitofp is a single instruction on x86-           and our numbers are below 2^31.-           -}-           =<< sitofp y)-          (LLVM.vector . (:[]) ^<< sqrt (3 * rate) / return m2) $+           =<< int31tofp y)+          (Serial.replicate ^<< sqrt (3 * rate) / return m2) $        noiseCore seed +{-+sitofp is a single instruction on x86+and thus we use it, since the arguments are below 2^31.+-}+int31tofp ::+   (IsFloating a, IsPrimitive a,+    TypeNum.Pos n, TypeNum.Mul n TypeNum.D32 s, TypeNum.Pos s) =>+   Value (Vector n Word32) -> CodeGenFunction r (Value (Vector n a))+int31tofp =+   LLVM.inttofp <=<+   (LLVM.bitcastUnify ::+       (TypeNum.Pos n, TypeNum.Mul n TypeNum.D32 s, TypeNum.Pos s) =>+       Value (Vector n Word32) ->+       CodeGenFunction r (Value (Vector n Int32)))+ noiseCore, noiseCoreAlt ::-   (IsPowerOf2 n, IsSized (Vector n Word32) s) =>+   (TypeNum.Pos n, TypeNum.Mul n TypeNum.D32 s, TypeNum.Pos s) =>    Param.T p Word32 ->    T p (Value (Vector n Word32)) noiseCore seed =
src/Synthesizer/LLVM/Parameterized/SignalPrivate.hs view
@@ -5,16 +5,25 @@  import qualified Synthesizer.LLVM.Parameter as Param import qualified LLVM.Extra.MaybeContinuation as Maybe-import qualified LLVM.Extra.Representation as Rep+import qualified LLVM.Extra.Memory as Memory+import qualified LLVM.Extra.Arithmetic as A -import LLVM.Core (MakeValueTuple, IsSized, CodeGenFunction, )+import LLVM.Extra.Class (MakeValueTuple, )+import LLVM.Core (IsSized, CodeGenFunction, ) import LLVM.Util.Loop (Phi, )  import Control.Arrow ((&&&), )+import Control.Monad (liftM2, )+import Control.Applicative (Applicative, pure, (<*>), )  import Foreign.Storable.Tuple () import Foreign.Storable (Storable, ) +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 (and, iterate, map, zip, zipWith, )  @@ -53,11 +62,11 @@        Storable nextParamTuple,        MakeValueTuple startParamTuple startParamValue,        MakeValueTuple nextParamTuple  nextParamValue,-       Rep.Memory     startParamValue startParamPacked,-       Rep.Memory     nextParamValue  nextParamPacked,+       Memory.C     startParamValue startParamPacked,+       Memory.C     nextParamValue  nextParamPacked,        IsSized        startParamPacked startParamSize,        IsSized        nextParamPacked  nextParamSize,-       Rep.Memory state packed,+       Memory.C state packed,        IsSized packed size) =>    Cons       (forall r c.@@ -82,11 +91,11 @@     Storable nextParamTuple,     MakeValueTuple startParamTuple startParamValue,     MakeValueTuple nextParamTuple nextParamValue,-    Rep.Memory startParamValue startParamPacked,-    Rep.Memory nextParamValue nextParamPacked,+    Memory.C startParamValue startParamPacked,+    Memory.C nextParamValue nextParamPacked,     IsSized    startParamPacked startParamSize,     IsSized    nextParamPacked  nextParamSize,-    Rep.Memory state packed,+    Memory.C state packed,     IsSized packed size) =>    (forall r c.     (Phi c) =>@@ -105,7 +114,7 @@   map ::-   (Storable ph, MakeValueTuple ph pl, Rep.Memory pl pp, IsSized pp ps) =>+   (Storable ph, MakeValueTuple ph pl, Memory.C pl pp, IsSized pp ps) =>    (forall r. pl -> a -> CodeGenFunction r b) ->    Param.T p ph ->    T p a -> T p b@@ -128,15 +137,78 @@ mapSimple f = map (const f) (return ())  +zipWith ::+   (Storable ph, MakeValueTuple ph pl, Memory.C pl pp, IsSized pp ps) =>+   (forall r. pl -> a -> b -> CodeGenFunction r c) ->+   Param.T p ph ->+   T p a -> T p b -> T p c+zipWith f selectParamF+      (Cons nextA startA createIOContextA deleteIOContextA)+      (Cons nextB startB createIOContextB deleteIOContextB) =+   Cons+      (\(parameterF, (parameterA, parameterB)) (sa0,sb0) -> do+         (a,sa1) <- nextA parameterA sa0+         (b,sb1) <- nextB parameterB sb0+         c <- Maybe.lift $ f (Param.value selectParamF parameterF) a b+         return (c, (sa1,sb1)))+      (\(parameterA, parameterB) ->+         liftM2 (,)+            (startA parameterA)+            (startB parameterB))+      (\p -> do+         (ca,(nextParamA,startParamA)) <- createIOContextA p+         (cb,(nextParamB,startParamB)) <- createIOContextB p+         return ((ca,cb),+            ((Param.get selectParamF p, (nextParamA,  nextParamB)),+             (startParamA, startParamB))))+      (\(ca,cb) ->+         deleteIOContextA ca >>+         deleteIOContextB cb)++zipWithSimple ::+   (forall r. a -> b -> CodeGenFunction r c) ->+   T p a -> T p b -> T p c+zipWithSimple f =+   zipWith (const f) (return ())++ instance Functor (T p) where    fmap f = mapSimple (return . f) +{- |+ZipList semantics+-}+instance Applicative (T p) where+   pure x =+      simple+         (\() () -> return (x, ()))+         return+         (return ())+         (return ())+   (<*>) = zipWithSimple (\f a -> return (f a)) ++instance (A.Additive a) => Additive.C (T p a) where+   zero = pure A.zero+   negate = mapSimple A.neg+   (+) = zipWithSimple A.add+   (-) = zipWithSimple A.sub++instance (A.PseudoRing a, A.IntegerConstant a) => Ring.C (T p a) where+   one = pure A.one+   fromInteger n = pure (A.fromInteger' n)+   (*) = zipWithSimple A.mul++instance (A.Field a, A.RationalConstant a) => Field.C (T p a) where+   fromRational' x = pure (A.fromRational' $ Ratio.toRational98 x)+   (/) = zipWithSimple A.fdiv++ iterate ::    (Storable ph, MakeValueTuple ph pl,-    Rep.Memory pl pp, IsSized pp ps,+    Memory.C pl pp, IsSized pp ps,     Storable a,  MakeValueTuple a al,-    Rep.Memory al packed, IsSized packed s) =>+    Memory.C al packed, IsSized packed s) =>    (forall r. pl -> al -> CodeGenFunction r al) ->    Param.T p ph ->    Param.T p a -> T p al
− src/Synthesizer/LLVM/Parameterized/Value.hs 
@@ -1,133 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-}-module Synthesizer.LLVM.Parameterized.Value where--import qualified Synthesizer.LLVM.Simple.Value as Value--import LLVM.Core hiding (zero, )-import LLVM.Util.Arithmetic (TValue, )-import qualified LLVM.Util.Arithmetic as Arith--{--import qualified Synthesizer.Basic.Phase as Phase-import qualified Synthesizer.LLVM.Frame.Stereo as Stereo--import Control.Monad (liftM2, liftM3, )--}--import qualified Algebra.Transcendental as Trans-import qualified Algebra.Algebraic as Algebraic--- import qualified Algebra.RealRing as RealRing-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 (map, zipWith, writeFile, )---newtype T p a = Cons {decons :: forall r. p -> TValue r a}--instance (Additive.C a, IsArithmetic a, IsConst a) =>-      Additive.C (T p a) where-   zero = lift0 zero-   (+) = lift2 (+)-   (-) = lift2 (-)-   negate = lift1 negate--instance (Ring.C a, IsArithmetic a, IsConst a) =>-      Ring.C (T p a) where-   one = lift0 one-   (*) = lift2 (*)-   fromInteger = constant . fromInteger--instance (Ring.C a, IsArithmetic a, IsConst a) => Enum (T p a) where-   succ x = x + one-   pred x = x - one-   fromEnum _ = error "CodeGenFunction Value: fromEnum"-   toEnum = fromIntegral--{--instance (IsArithmetic a, Cmp a b, Num a, IsConst a) => Real (T p a) where-   toRational _ = error "CodeGenFunction Value: toRational"--instance (Cmp a b, Num a, IsConst a, IsInteger a) => Integral (T p a) where-   quot = binop (if (isSigned (undefined :: a)) then sdiv else udiv)-   rem  = binop (if (isSigned (undefined :: a)) then srem else urem)-   quotRem x y = (quot x y, rem x y)-   toInteger _ = error "CodeGenFunction Value: toInteger"--}--instance (Field.C a, IsConst a, IsFloating a) => Field.C (T p a) where-   (/) = lift2 (/)-   fromRational' = constant . fromRational'--{--instance (Cmp a b, Fractional a, IsConst a, IsFloating a) => RealFrac (T p a) where-   properFraction _ = error "CodeGenFunction Value: properFraction"--}--instance (Algebraic.C a, IsConst a, IsFloating a) => Algebraic.C (T p a) where-   sqrt = lift1 sqrt--instance (Trans.C a, IsConst a, IsFloating a) => Trans.C (T p a) where-   pi = constant pi-   sin = lift1 sin-   cos = lift1 cos-   tan = lift1 tan--   asin = lift1 asin-   acos = lift1 acos-   atan = lift1 atan--   sinh  = lift1 sinh-   cosh  = lift1 cosh-   asinh = lift1 asinh-   acosh = lift1 acosh-   atanh = lift1 atanh--   (**) = lift2 (**)-   exp = lift1 exp-   log = lift1 log---twoPi ::-   (Trans.C a, IsConst a, IsFloating a) =>-   T p a-twoPi = 2*pi-{--twoPi ::-   (Cmp a b, P.Floating a, IsConst a, IsFloating a) =>-   TValue r a-twoPi = P.fromInteger 2 P.* P.pi--}---lift0 :: Value.T a -> T p a-lift0 x =-   Cons $ const $ Value.decons x--lift1 :: (Value.T a -> Value.T b) -> (T p a -> T p b)-lift1 f x =-   Cons (\p -> Value.decons $ f (Value.Cons $ decons x p))--lift2 :: (Value.T a -> Value.T b -> Value.T c) -> (T p a -> T p b -> T p c)-lift2 f x y =-   Cons $ \p -> Value.decons $-      f (Value.Cons $ decons x p) (Value.Cons $ decons y p)---constantValue :: Value a -> T p a-constantValue x =-   Cons (const $ return x)--constant :: (IsConst a) => a -> T p a-constant = constantValue . valueOf--choose :: (IsConst a) => (p -> a) -> T p a-choose x =-   Cons (return . valueOf . x)
+ src/Synthesizer/LLVM/Plug/Input.hs view
@@ -0,0 +1,277 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+module Synthesizer.LLVM.Plug.Input where++import qualified Synthesizer.Zip as Zip++import qualified Synthesizer.LLVM.ConstantPiece as Const++import qualified LLVM.Extra.Memory as Memory+import qualified LLVM.Extra.Arithmetic as A+import qualified LLVM.Extra.Class as Class+import qualified LLVM.Extra.Control as C++import qualified LLVM.Core as LLVM+import LLVM.Extra.Class (MakeValueTuple, )++import qualified Data.TypeLevel.Num as TypeNum++import Control.Applicative (liftA2, )++import qualified Data.Map as Map++import Data.Tuple.HT (mapFst, mapPair, swap, )++import qualified Synthesizer.PiecewiseConstant.ALSA.MIDIControllerSet 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 Data.StorableVector as SV+import qualified Data.StorableVector.Base as SVB++import qualified Foreign.Marshal.Array as Array+import qualified Foreign.Marshal.Alloc as Alloc+import qualified Foreign.ForeignPtr as FPtr+import Foreign.Storable (Storable, pokeElemOff, )++import Data.Word (Word32, )+++{-+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 packed size ioContext+        paramTuple  paramValue  paramPacked  paramSize.+      (Storable paramTuple,+       MakeValueTuple paramTuple  paramValue,+       Memory.C     paramValue  paramPacked,+       LLVM.IsSized   paramPacked paramSize,+       Memory.C state packed,+       LLVM.IsSized packed size) =>+   Cons+      (forall r.+       paramValue ->+       state -> LLVM.CodeGenFunction r (b, state))+          -- compute next value+      (forall r.+       paramValue ->+       LLVM.CodeGenFunction r state)+          -- initial state+      (a -> IO (ioContext, paramTuple))+          {- initialization from IO monad+          This is called once input chunk.+          This will be run within unsafePerformIO,+          so no observable In/Out actions please!+          -}+      (ioContext -> IO ())+          {-+          finalization from IO monad, also run within unsafePerformIO+          -}+++instance Functor (T a) where+   fmap f (Cons next start create delete) =+      Cons (\p s -> fmap (mapFst f) $ next p s) start create delete+++class Default a b | a -> b where+   deflt :: T a b++instance+   (Default a c, Default b d) =>+      Default (Zip.T a b) (c,d) where+   deflt = split deflt deflt++instance Default SigG.LazySize () where+   deflt = lazySize++instance+   (Storable a, MakeValueTuple a value, Memory.C value struct) =>+      Default (SV.Vector a) value where+   deflt = storableVector+++{-+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+   (Storable a, MakeValueTuple a value,+    Memory.C value struct, LLVM.IsSized struct size) =>+      Default (EventListBT.T NonNegW.Int a) value where+   deflt = piecewiseConstant++++rmap :: (a -> b) -> T b c -> T a c+rmap f (Cons next start create delete) =+   Cons next start (create . f) delete+++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+   (\(parameterA, parameterB) (sa0,sb0) -> do+      (a,sa1) <- nextA parameterA sa0+      (b,sb1) <- nextB parameterB sb0+      return ((a,b), (sa1,sb1)))+   (\(parameterA, parameterB) ->+      liftA2 (,)+         (startA parameterA)+         (startB parameterB))+   (\(Zip.Cons a b) -> do+      (ca,paramA) <- createA a+      (cb,paramB) <- createB b+      return ((ca,cb), (paramA, paramB)))+   (\(ca,cb) ->+      deleteA ca >>+      deleteB cb)++lazySize ::+   T SigG.LazySize ()+lazySize =+   Cons+      (\ _ _ -> return ((), ()))+      return+      (\ _lazySize -> return ((), ()))+      (const $ return ())++storableVector ::+   (Storable a, MakeValueTuple a value, Memory.C value struct) =>+   T (SV.Vector a) value+storableVector =+   Cons+      (\ _ p ->+         liftA2 (,)+            (Memory.load p)+            (A.advanceArrayElementPtr p))+      return+      (\vec ->+         let (fp,s,_l) = SVB.toForeignPtr vec+         in  return (fp,+                Memory.castStorablePtr $+                FPtr.unsafeForeignPtrToPtr fp `Array.advancePtr` s))+      -- keep the foreign ptr alive+      FPtr.touchForeignPtr++{-+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 ::+   (Storable a, MakeValueTuple a value,+    Memory.C value struct, LLVM.IsSized struct size) =>+   T (EventListBT.T NonNegW.Int a) value+piecewiseConstant =+   case rmap (uncurry Zip.Cons .+              mapPair (SV.pack . map ((fromIntegral :: Int -> Word32) .+                                      NonNegW.toNumber),+                       SV.pack) .+              swap . unzip . EventListBT.toPairList) $+        fmap (uncurry Const.Cons) $+        split storableVector storableVector of+      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 Class.zeroTuple,+                      next param s))+            length2 <- A.dec length1+            return (y1, (Const.Cons length2 y1, s1)))+         (\param ->+            fmap ((,) (Const.Cons Class.zeroTuple Class.undefTuple)) $+            start param)+         create delete+++{- |+Return an Array and not a pointer to an array,+in order to forbid writing to the array.+-}+controllerSet ::+   (TypeNum.Nat n, Memory.FirstClass a b,+    Storable a, MakeValueTuple a (LLVM.Value a),+    LLVM.IsSized a asize,+    LLVM.IsSized b bsize) =>+   n -> T (PCS.T Int a) (LLVM.Value (LLVM.Array n a))+controllerSet n =+   case storableVector of+      Cons next start create delete -> Cons+         (\((arrPtr, _), param) state0 -> do+            (length2, s2) <-+               C.whileLoopShared state0+                  (\(len0, s0) ->+                     (A.cmp LLVM.CmpEQ len0 Class.zeroTuple,+                      do ((len1, (i,a)), s1) <- next param s0+                         LLVM.store a =<<+                            LLVM.getElementPtr arrPtr (i, ())+                         return (len1, s1)))+            length3 <- A.dec length2+            arr <- LLVM.load =<< LLVM.bitcastUnify arrPtr+            return (arr, (length3, s2)))+         (\((_, initialTime), param) -> do+            state <- start param+            return (initialTime, state))++         (\pcs ->+            EventListMT.switchTimeL+               (\initialTime bt -> do+                  (context, param) <-+                     create+                        (SV.pack .+                         map (\((i,a),len) ->+                            (fromIntegral len :: Word32,+                             (fromIntegral i :: Word32, a))) .+                         EventListBT.toPairList $+                         bt)++                  -- FIXME: handle memory exhaustion+                  arr <- Array.mallocArray (TypeNum.toInt n)+                  flip mapM_ (Map.toList $ PCS.initial pcs) $ \(i,a) ->+                     if i >= TypeNum.toInt n+                       then error "Plug.Input.controllerSet: array too small"+                       else pokeElemOff arr i a++                  return+                     ((arr, context),+                      ((arr, fromIntegral initialTime :: Word32), param)))+                  {-+                  It would be more elegant,+                  if we could pass Arrays around just like Vectors.++                  return (context, ((sampleArray (\i -> maybe Class.undefTuple Class.valueTupleOf $ 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,120 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+module Synthesizer.LLVM.Plug.Output where++import qualified Synthesizer.Zip as Zip++import qualified LLVM.Extra.Memory as Memory+import qualified LLVM.Extra.Arithmetic as A++import qualified LLVM.Core as LLVM+import LLVM.Extra.Class (MakeValueTuple, )++import Control.Monad (liftM2, )++import qualified Data.StorableVector as SV+import qualified Data.StorableVector.Base as SVB++import qualified Foreign.Marshal.Array as Array+import qualified Foreign.ForeignPtr as FPtr+import Foreign.Storable.Tuple ()+import Foreign.Storable (Storable, )++import NumericPrelude.Numeric+import NumericPrelude.Base hiding (and, iterate, map, zip, zipWith, take, takeWhile, )+++data T a b =+   forall state packed size ioContext+        paramTuple paramValue paramPacked paramSize.+      (Storable paramTuple,+       MakeValueTuple paramTuple  paramValue,+       Memory.C     paramValue  paramPacked,+       LLVM.IsSized   paramPacked paramSize,+       Memory.C state packed,+       LLVM.IsSized packed size) =>+   Cons+      (forall r.+       paramValue ->+       a -> state -> LLVM.CodeGenFunction r state)+          -- compute next value+      (forall r.+       paramValue ->+       LLVM.CodeGenFunction r state)+          -- initial state+      (Int -> IO (ioContext, paramTuple))+          {- 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 unsafePerformIO,+          so no observable In/Out actions please!+          -}+      (Int -> ioContext -> IO b)+          {-+          finalization from IO monad, also run within unsafePerformIO+          The integer argument is the actually produced size of data.+          We must clip the allocated output vectors accordingly.+          -}+++class Default a b | b -> a where+   deflt :: T a b++instance+   (Default a c, Default b d) =>+      Default (a,b) (Zip.T c d) where+   deflt = split deflt deflt++instance+   (Storable a, MakeValueTuple a value, Memory.C value struct) =>+      Default value (SV.Vector a) where+   deflt = storableVector+++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+   (\(parameterA, parameterB) (a,b) (sa0,sb0) -> do+      sa1 <- nextA parameterA a sa0+      sb1 <- nextB parameterB b sb0+      return (sa1,sb1))+   (\(parameterA, parameterB) ->+      liftM2 (,)+         (startA parameterA)+         (startB parameterB))+   (\len -> do+      (ca,paramA) <- createA len+      (cb,paramB) <- createB len+      return ((ca,cb), (paramA, paramB)))+   (\len (ca,cb) ->+      liftM2 Zip.Cons+         (deleteA len ca)+         (deleteB len cb))+++storableVector ::+   (Storable a, MakeValueTuple a value, Memory.C value struct) =>+   T value (SV.Vector a)+storableVector = Cons+   (\ _ a p ->+      Memory.store a p >> A.advanceArrayElementPtr p)+   return+   (\len -> do+      vec <- SVB.create len (const $ return ())+      -- s should be always zero, but we must not rely on that+      let (fp,s,_l) = SVB.toForeignPtr vec+      return (vec,+         Memory.castStorablePtr $+         FPtr.unsafeForeignPtrToPtr fp `Array.advancePtr` s))+   (\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/Random.hs view
@@ -13,11 +13,16 @@  import qualified LLVM.Extra.Arithmetic as A -import LLVM.Core as LLVM+import LLVM.Core+          (CodeGenFunction, Value, Vector,+           zext, trunc, lshr, value, valueOf, vector,+           undef, constOf, constVector, bitcast, )+import qualified LLVM.Core as LLVM import qualified Data.TypeLevel.Num as TypeNum  import Data.Function.HT (nest, ) +import Data.Int (Int32, ) import Data.Word (Word32, Word64, )  @@ -56,9 +61,9 @@  nextCG32 :: Value Word32 -> CodeGenFunction r (Value Word32) nextCG32 s = do-   sHigh <- A.mul (valueOf splitRem) =<< udiv s split-   sLow  <- A.mul (valueOf factor)   =<< urem s split-   flip A.urem (valueOf modulus) =<< A.add sHigh sLow+   sHigh <- A.mul (valueOf splitRem) =<< LLVM.idiv s split+   sLow  <- A.mul (valueOf factor)   =<< LLVM.irem s split+   flip A.irem (valueOf modulus) =<< A.add sHigh sLow  nextCG64 :: Value Word32 -> CodeGenFunction r (Value Word32) nextCG64 s =@@ -69,7 +74,7 @@    We know that there cannot be an overflow,    but I do not know how to tell LLVM.    -}-   flip A.urem (valueOf (modulus :: Word64)) =<<+   flip A.irem (valueOf (modulus :: Word64)) =<<    A.mul (valueOf factor) =<<    zext s @@ -97,10 +102,9 @@       < 2*modulus    Thus modulo by modulus needs at most one subtraction.    -}-   prodMod <- A.add low =<< A.mul (valueOf fac) high-   prodModS <- A.sub prodMod (valueOf modulus)-   b <- A.icmp IntSLT prodModS (value zero)-   select b prodMod prodModS+   subtractIfPossible (valueOf modulus)+      =<< A.add low+      =<< A.mul (valueOf fac) high   {-@@ -115,7 +119,7 @@    fromIntegral $ nest n next 1  vectorSeed ::-   (IsPowerOf2 n) =>+   (TypeNum.Pos n) =>    Word32 -> Vector n Word32 vectorSeed seed =    let n = Vector.size $ valueOf v@@ -126,7 +130,7 @@ vector64 = id  nextVector ::-   (IsPowerOf2 n) =>+   (TypeNum.Pos n) =>    Value (Vector n Word32) ->    CodeGenFunction r (Value (Vector n Word32)) nextVector s =@@ -164,12 +168,12 @@     (lowEven, highEven) <-       mulAndReduce =<<-      shufflevector s (value undef)+      LLVM.shufflevector s (value undef)          (constVector [constOf 0, undef, constOf 2, undef])     (lowOdd, highOdd) <-       mulAndReduce =<<-      shufflevector s (value undef)+      LLVM.shufflevector s (value undef)          (constVector [constOf 1, undef, constOf 3, undef])     low  <- truncAndInterleave2x64to4x32 lowEven  lowOdd@@ -195,7 +199,7 @@ truncAndInterleave2x64to4x32 even2x64 odd2x64 = do    even4x32 <- bitcast even2x64    odd4x32  <- bitcast odd2x64-   LLVM.shufflevector even4x32 odd4x32+   Vector.shuffleMatchPlain2 even4x32 odd4x32       (constVector [constOf 0, constOf 4, constOf 2, constOf 6])  @@ -214,7 +218,7 @@    (low0, high0) <-       splitVector31to64 =<<       muludq (prepConstFactor (vectorParameter n)) =<<-      Vector.shuffle s+      LLVM.shufflevector s (value undef)          (constVector [constOf 0, undef, constOf 1, undef])    -- fac = mod (2^31) modulus    let fac = 2^(31::Int) - modulus@@ -251,12 +255,13 @@    and 'min' chooses the value before subtraction.    -}    result <- Vector.min prodModS prodMod-   Vector.shuffle+   LLVM.shufflevector       (result :: Value (Vector TypeNum.D4 Word32))+      (LLVM.value LLVM.undef)       (constVector $ map constOf [0,2])  splitVector31to64 ::-   (IsPowerOf2 n) =>+   (TypeNum.Pos n) =>    Value (Vector n Word64) ->    CodeGenFunction r (Value (Vector n Word64), Value (Vector n Word64)) splitVector31to64 x = do@@ -308,7 +313,7 @@ as in the approach that is implemented here. -} nextVectorGeneric ::-   (IsPowerOf2 n) =>+   (TypeNum.Pos n) =>    Value (Vector n Word32) ->    CodeGenFunction r (Value (Vector n Word32)) nextVectorGeneric s = do@@ -328,36 +333,46 @@       (\x -> A.add x =<< Vector.map zext low0) =<<       Vector.umul32to64 (SoV.replicateOf fac) high0 -   prodMod <--      A.add low1 =<<-      Vector.mul (SoV.replicateOf fac) high1-   prodModS <- A.sub prodMod (SoV.replicateOf modulus)+   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.    -}-   Vector.min prodModS prodMod+   SoV.min x =<< A.sub x d    -- alternatively (slower):-   --   selectNonNegativeGeneric prodModS prodMod+   --   flip selectNonNegativeGeneric x =<< A.sub x d  {- | Select non-negative elements from the first vector, otherwise select corresponding elements from the second vector. -} selectNonNegativeGeneric ::-   (IsPowerOf2 n) =>-   Value (Vector n Word32) ->-   Value (Vector n Word32) ->-   CodeGenFunction r (Value (Vector n Word32))+   (TypeNum.Pos n) =>+   Value (Vector n Int32) ->+   Value (Vector n Int32) ->+   CodeGenFunction r (Value (Vector n Int32)) selectNonNegativeGeneric x y = do-   b <- A.icmp IntSGE x (value zero)+   b <- A.cmp LLVM.CmpGE x (value LLVM.zero)    Vector.select b x y   splitVector31 ::-   (IsPowerOf2 n) =>+   (TypeNum.Pos n) =>    Value (Vector n Word64) ->    CodeGenFunction r (Value (Vector n Word32), Value (Vector n Word32)) splitVector31 x = do@@ -370,10 +385,10 @@ but unfortunately calls the expensive __umoddi3. -} nextVector64 ::-   (IsPowerOf2 n) =>+   (TypeNum.Pos n) =>    Value (Vector n Word32) ->    CodeGenFunction r (Value (Vector n Word32)) nextVector64 s =    Vector.map trunc =<<-   flip A.urem (SoV.replicateOf modulus) =<<+   flip A.irem (SoV.replicateOf modulus) =<<    Vector.umul32to64 (SoV.replicateOf (vectorParameter (Vector.size s))) s
+ src/Synthesizer/LLVM/RingBuffer.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE FlexibleContexts #-}+module Synthesizer.LLVM.RingBuffer (+   T, track,+   index, oldest,+   ) where++import qualified Synthesizer.LLVM.CausalParameterized.ProcessPrivate as CausalP+import qualified Synthesizer.LLVM.Parameter as Param++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.Class as Class++import qualified LLVM.Core as LLVM+import LLVM.Core (CodeGenFunction, Value, IsSized, )++import Data.Word (Word32, )+import Foreign.Storable.Tuple ()+import Foreign.Storable (Storable, )+import qualified Synthesizer.LLVM.Alloc as Alloc+import Foreign.Ptr (Ptr, )++import Prelude hiding (length, )+++data T ap =+   Cons {+      buffer :: Value (Ptr ap),+      length :: Value Word32,+      current :: Value Word32,+      oldest_ :: Value Word32+   }++{- |+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 ::+   (Memory.C al ap,+    IsSized ap as) =>+   Value Word32 -> T ap -> CodeGenFunction r al+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 al ap,+    IsSized ap as) =>+   T ap -> CodeGenFunction r al+oldest rb =+   Memory.load =<< LLVM.getElementPtr (buffer rb) (oldest_ rb, ())+++{- |+@track initial time@ tracks the last @time@ sample values+including the current one.+The values before the actual input data are filled with @initial@.+The values can be accessed using 'index' with indices+ranging from 0 to @time@.++The @time@ parameter must be non-negative.++The initial value is also needed for determining the ring buffer element type.+-}+track ::+   (Storable a,+    Class.MakeValueTuple a al,+    Memory.C al ap,+    IsSized ap as) =>+   Param.T p a -> Param.T p Int -> CausalP.T p al (T ap)+track initial time =+   let time32 = fmap (fromIntegral :: Int -> Word32) time in+   CausalP.Cons+      (\(size,ptr) a remain0 -> Maybe.lift $ do+         Memory.store a =<< LLVM.getElementPtr ptr (remain0, ())+         cont <- A.cmp LLVM.CmpGT remain0 (LLVM.value LLVM.zero)+         remain1 <-+            C.ifThenSelect cont (Param.value time32 size)+               (A.dec remain0)+         size1 <- A.inc (Param.value time32 size)+         return (Cons ptr size1 remain0 remain1, remain1))+      (\(x, (size,ptr)) -> do+         size1 <- A.inc (Param.value time32 size)+         -- cf. LLVM.Storable.Signal.fill+         C.arrayLoop size1 ptr () $ \ ptri () ->+            Memory.store (Param.value initial x) ptri >> return ()+         return size)+      (\p -> do+         let size = Param.get time p+             x = Param.get initial p+         {-+         We allocate one element more than necessary+         in order to simplify handling of delay time zero+         -}+         ptr <- Alloc.mallocArray (size+1)+         let param =+               (fromIntegral size :: Word32,+                Memory.castStorablePtr (ptrAsTypeOf ptr x))+         return ((size,ptr), (param, (x, param))))+      (\(size,ptr) -> Alloc.freeArray (size + 1) ptr)++ptrAsTypeOf :: Ptr a -> a -> Ptr a+ptrAsTypeOf p _ = p
− src/Synthesizer/LLVM/Sample.hs 
@@ -1,187 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-module Synthesizer.LLVM.Sample where--import qualified LLVM.Extra.Vector as Vector--import Foreign.Storable.Tuple ()--import qualified Synthesizer.LLVM.Frame.Stereo as Stereo--import qualified LLVM.Extra.Arithmetic as A--import qualified LLVM.Core as LLVM-import LLVM.Core-          (Value, valueOf, value, undef,-           Vector, insertelement, extractelement,-           IsPrimitive, IsPowerOf2, IsArithmetic,-           CodeGenFunction, )-import Data.TypeLevel.Num (D2, D4, )--import Data.Word (Word32, )--import Control.Monad (liftM2, )--import NumericPrelude.Numeric hiding (zero, )-import NumericPrelude.Base---{- |-Copy mono signal to both stereo channels.--}-stereoFromMono ::-   Value a ->-   CodeGenFunction r (Stereo.T (Value a))-stereoFromMono x =-   return $ Stereo.cons x x--mixMonoFromStereo ::-   (IsArithmetic a) =>-   Stereo.T (Value a) ->-   CodeGenFunction r (Value a)-mixMonoFromStereo s =-   mixMono (Stereo.left s) (Stereo.right s)--zipStereo ::-   Value a -> Value a ->-   CodeGenFunction r (Stereo.T (Value a))-zipStereo l r =-   return (Stereo.cons l r)---stereoFromVector ::-   (IsPrimitive a) =>-   Value (Vector D2 a) ->-   CodeGenFunction r (Stereo.T (Value a))-stereoFromVector x =-   liftM2 Stereo.cons-      (extractelement x (valueOf 0))-      (extractelement x (valueOf 1))--vectorFromStereo ::-   (IsPrimitive a) =>-   Stereo.T (Value a) ->-   CodeGenFunction r (Value (Vector D2 a))-vectorFromStereo s = do-   x <- insertelement (value undef) (Stereo.left s) (valueOf 0)-   insertelement x (Stereo.right s) (valueOf 1)---quadroFromVector ::-   (IsPrimitive a) =>-   Value (Vector D4 a) ->-   CodeGenFunction r (Stereo.T (Stereo.T (Value a)))-quadroFromVector x =-   liftM2 Stereo.cons-      (liftM2 Stereo.cons-         (extractelement x (valueOf 0))-         (extractelement x (valueOf 1)))-      (liftM2 Stereo.cons-         (extractelement x (valueOf 2))-         (extractelement x (valueOf 3)))--vectorFromQuadro ::-   (IsPrimitive a) =>-   Stereo.T (Stereo.T (Value a)) ->-   CodeGenFunction r (Value (Vector D4 a))-vectorFromQuadro s = do-   let x0 = value undef-       sl = Stereo.left s-       sr = Stereo.right s-   x1 <- insertelement x0 (Stereo.left  sl) (valueOf 0)-   x2 <- insertelement x1 (Stereo.right sl) (valueOf 1)-   x3 <- insertelement x2 (Stereo.left  sr) (valueOf 2)-   insertelement       x3 (Stereo.right sr) (valueOf 3)---mixMono ::-   (IsArithmetic a) =>-   Value a -> Value a ->-   CodeGenFunction r (Value a)-mixMono = A.add--mixStereo ::-   (IsArithmetic a) =>-   Stereo.T (Value a) -> Stereo.T (Value a) ->-   CodeGenFunction r (Stereo.T (Value a))-mixStereo x y =-   liftM2 Stereo.cons-      (A.add (Stereo.left  x) (Stereo.left  y))-      (A.add (Stereo.right x) (Stereo.right y))---class Additive a where-   zero :: a-   add :: a -> a -> CodeGenFunction r a--instance (IsArithmetic a) => Additive (Value a) where-   zero = LLVM.value LLVM.zero-   add = A.add--instance (Additive a) => Additive (Stereo.T a) where-   zero = Stereo.cons zero zero-   add x y =-      liftM2 Stereo.cons-         (add (Stereo.left  x) (Stereo.left  y))-         (add (Stereo.right x) (Stereo.right y))----{- |-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, IsPowerOf2 n) =>-   Value (Vector n a) ->-   CodeGenFunction r (Value a)-mixVector = Vector.sum--mixVectorToStereo ::-   (Vector.Arithmetic a, IsPowerOf2 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, IsPowerOf2 n) =>-   Value (Vector n a) ->-   CodeGenFunction r (Stereo.T (Value a))-mixInterleavedVectorToStereo =-   fmap (uncurry Stereo.cons) .-   Vector.sumInterleavedToPair---amplifyMono ::-   (IsArithmetic a) =>-   Value a -> Value a ->-   CodeGenFunction r (Value a)-amplifyMono = A.mul--amplifyStereo ::-   (IsArithmetic a) =>-   Value a -> Stereo.T (Value a) ->-   CodeGenFunction r (Stereo.T (Value a))-amplifyStereo x y =-   liftM2 Stereo.cons-      (A.mul x (Stereo.left  y))-      (A.mul x (Stereo.right y))--subsampleVector ::-   (Vector.Access n a v) =>-   v -> CodeGenFunction r a-subsampleVector =-   Vector.extract (LLVM.value LLVM.zero :: Value Word32)
+ src/Synthesizer/LLVM/SerialVector.hs view
@@ -0,0 +1,17 @@+{- |+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.SerialVector where++import qualified Data.TypeLevel.Num.Sets as TypeSet+import qualified LLVM.Core as LLVM+++replicate :: (TypeSet.Pos n) => a -> LLVM.Vector n a+replicate x = LLVM.vector [x]
src/Synthesizer/LLVM/Server.hs view
@@ -1,5 +1,7 @@ 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@@ -7,16 +9,12 @@  import qualified LLVM.Core as LLVM -import Control.Monad (when, ) - part :: Int part = 106  main :: IO () main =-   when (part<200)-      (putStrLn "run 'aconnect' to connect to the MIDI controller") >>    LLVM.initializeNativeTarget >>    case part of       000 -> ServerScalar.pitchBend@@ -31,7 +29,11 @@       103 -> ServerPacked.keyboardFM       104 -> ServerPacked.keyboardFMMulti       105 -> ServerPacked.keyboardDetuneFM-      106 -> ServerPacked.keyboardFilter+      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       200 -> ServerScalarTest.pitchBend0       201 -> ServerScalarTest.pitchBend1       202 -> ServerScalarTest.pitchBend2@@ -54,4 +56,14 @@       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+      408 -> ServerCausalTest.sampledSound       _   -> error "not implemented server part"
+ src/Synthesizer/LLVM/Server/CausalPacked/Instrument.hs view
@@ -0,0 +1,901 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE Rank2Types #-}+module Synthesizer.LLVM.Server.CausalPacked.Instrument where++import Synthesizer.LLVM.Server.Packed.Instrument+          (Vector, vectorTime, vectorSize,+           SampleInfo, SampledSound(..), loadSound,+           sampleStart, sampleLength,+           sampleLoopStart, sampleLoopLength,+           stereoNoise, noiseReference, sumNested, )+import Synthesizer.LLVM.Server.Common hiding (Instrument, )++import qualified Synthesizer.LLVM.Storable.Process as PSt+import qualified Synthesizer.CausalIO.ALSA.Process as PAlsa+import qualified Synthesizer.CausalIO.Gate as Gate+import qualified Synthesizer.CausalIO.Process as PIO++import Synthesizer.LLVM.CausalParameterized.Functional (($&), (&|&), )+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.Generator.Exponential2 as Exp+import qualified Synthesizer.LLVM.Frame.Stereo as Stereo+import qualified Synthesizer.LLVM.Frame as Frame+import qualified Synthesizer.LLVM.CausalParameterized.Functional as F+import qualified Synthesizer.LLVM.CausalParameterized.ControlledPacked as CtrlPS+import qualified Synthesizer.LLVM.CausalParameterized.ProcessPacked as CausalPS+import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP+import qualified Synthesizer.LLVM.Parameterized.SignalPacked as SigPS+import qualified Synthesizer.LLVM.Parameterized.Signal as SigP+import qualified Synthesizer.LLVM.Parameter as Param+import qualified Synthesizer.LLVM.Wave as WaveL++import qualified Synthesizer.LLVM.ALSA.BendModulation as BM+import qualified Synthesizer.LLVM.ALSA.MIDI as MIDIL+import qualified Synthesizer.PiecewiseConstant.Signal as PC+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 System.FilePath ((</>), )++import qualified LLVM.Extra.ScalarOrVector as SoV+import qualified LLVM.Extra.Arithmetic as A+import qualified LLVM.Extra.Monad as LM++import qualified LLVM.Core as LLVM++import qualified Data.TypeLevel.Num as TypeNum++import qualified Data.Traversable as Trav+import Control.Arrow (Arrow, arr, first, second, (&&&), (***), (<<^), (^<<), )+import Control.Category (id, (.), )+import Control.Monad (liftM2, liftM3, (<=<), )+import Control.Applicative (Applicative, pure, liftA2, liftA3, )+import Data.Monoid (mappend, )+import Data.Tuple.HT (swap, mapPair, )++import qualified Number.DimensionTerm as DN++{-+import qualified Numeric.NonNegative.Class   as NonNeg+import qualified Numeric.NonNegative.Wrapper as NonNegW+import qualified Numeric.NonNegative.Chunky  as NonNegChunky+-}+import qualified Algebra.Additive as Additive++import NumericPrelude.Numeric+import NumericPrelude.Base hiding (id, (.), )+++type Param p = Param.T (SampleRate Real, p)+type CausalP p = CausalP.T (SampleRate Real, p)++type Instrument a sig = SampleRate a -> PAlsa.Instrument a sig++type Control = EventListBT.T PC.ShortStrictTime++type Time = DN.Time Real+type Frequency = DN.Frequency Real+++stereoFrequenciesFromDetuneBendModulation ::+   Param p Real ->+   CausalP p+      (LLVM.Value Real, BM.T (LLVM.Value Real))+      (Stereo.T (LLVM.Value Vector))+stereoFrequenciesFromDetuneBendModulation speed =+   CausalP.envelopeStereo+   .+   (MIDIL.frequencyFromBendModulationPacked speed+    ***+    CausalP.mapSimple (Trav.mapM SoV.replicate)+    .+    liftA2 Stereo.cons (one + id) (one - id))+   .+   arr swap+++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 ::+   Param.T p Real ->+   CausalP.T p (LLVM.Value Vector) (LLVM.Value Vector)+takeThreshold =+   CausalP.takeWhile+      (\threshold y ->+         A.cmp LLVM.CmpLE threshold =<< Frame.subsampleVector y)+++liftStereo ::+   (Applicative f) =>+   (f a -> f b) -> f (Stereo.T a) -> f (Stereo.T b)+liftStereo proc freqs =+   liftA2 Stereo.cons+      (proc $ fmap Stereo.left freqs)+      (proc $ fmap Stereo.right freqs)++fanoutShorten ::+   (CutG.Transform a, CutG.Transform b, CutG.Transform c) =>+   PIO.T a b -> PIO.T a c -> PIO.T a (Zip.T b c)+fanoutShorten a b =+   Zip.arrowFirstShorten a .+   Zip.arrowSecondShorten b .+   arr (\x -> Zip.Cons x x)++reorderEnvelopeControl ::+   (Arrow arrow, CutG.Read remainder) =>+   arrow+      (Zip.T PAlsa.GateChunk+         (Zip.T+            (Zip.T (Control Time) (Control Time))+            remainder))+      (Zip.T+         (Zip.T PAlsa.GateChunk+            (Zip.T (Control Time) (Control Time)))+         remainder)+reorderEnvelopeControl =+   arr $ \(Zip.Cons gate (Zip.Cons times ctrl)) ->+      Zip.consChecked "ping gate ctrl"+         (Zip.consChecked "ping gate times" gate times) ctrl++ping :: IO (Instrument Real (SV.Vector Vector))+ping =+   fmap (\proc sampleRate vel freq ->+      proc (sampleRate, (vel,freq))+      .+      Gate.toStorableVector) $+   CausalP.processIO $+      let vel = number fst+          freq = frequency snd+      in  CausalP.fromSignal $+          SigP.envelope+             (SigPS.exponential2 (timeConst 0.2) (fmap amplitudeFromVelocity vel)) $+          SigPS.osciSimple WaveL.saw zero freq+++pingReleaseEnvelope ::+   IO (Real -> Real ->+       SampleRate Real -> Real ->+       PIO.T PAlsa.GateChunk (SV.Vector Vector))+pingReleaseEnvelope =+   liftM2+      (\sustain release dec rel sr vel ->+         PSt.continuePacked+            (sustain (sr,(dec,vel))+             .+             Gate.toChunkySize)+            (\y ->+               release (sr,(rel,y))+               .+               Gate.allToChunkySize))+      (CausalP.processIO $+         let vel = number snd+             decay = vectorTime fst+         in  CausalP.fromSignal $+             SigPS.exponential2 decay+                (fmap amplitudeFromVelocity vel))+      (CausalP.processIO $+         let level = number snd+             release = time fst+         in  CausalP.take (fmap round (vectorTime (const 1)))+             .+             CausalP.fromSignal+                (SigPS.exponential2 release level))++pingRelease ::+   IO (Real -> Real ->+       Instrument Real (SV.Vector Vector))+pingRelease =+   liftM2+      (\osci envelope dec rel sr vel freq ->+         osci (sr, freq)+         .+         envelope dec rel sr vel)+      (CausalP.processIO $+         let freq = frequency id+         in  CausalP.envelope+             .+             CausalP.feedFst (SigPS.osciSimple WaveL.saw zero freq))+      pingReleaseEnvelope+++pingControlledEnvelope ::+   Maybe Real ->+   IO (SampleRate Real -> Real ->+       PIO.T+          (Zip.T PAlsa.GateChunk+             (Zip.T (Control Time) (Control Time)))+          (SV.Vector Vector))+pingControlledEnvelope threshold =+   liftM2+      (\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))+      (CausalP.processIO $+         let vel = number id+         in  Exp.causalPackedP+                (fmap amplitudeFromVelocity vel))+      (CausalP.processIO $+         let level = number id+             expo = Exp.causalPackedP level+         in  case threshold of+                Just y -> takeThreshold (pure y) . expo+                Nothing -> expo)+++pingStereoReleaseFM ::+   IO (SampleRate Real -> Real -> Real ->+       PIO.T+          (Zip.T PAlsa.GateChunk+             (Zip.T+                (Zip.T (Control Time) (Control Time))+                (Zip.T+                   (Zip.T (Control Real) (Control Time))+                   (Zip.T+                      (Zip.T (Control Real) (Control Time))+                      (Zip.T (Control Real) (Control (BM.T Real)))))))+          (SV.Vector (Stereo.T Vector)))+pingStereoReleaseFM =+   liftA2+      (\osc env sr vel freq ->+         osc (sr, ())+         .+         (Zip.arrowSecond $ Zip.arrowSecond $+          Zip.arrowSecond $ Zip.arrowSecond $+            arr $ transposeModulation sr freq)+         .+         (Zip.arrowSecond $ Zip.arrowSecond $+          Zip.arrowFirst $ Zip.arrowSecond $+            arr $ halfLifeControl sr)+         .+         (Zip.arrowSecond $+          Zip.arrowFirst $ Zip.arrowSecond $+            arr $ halfLifeControl sr)+         .+         Zip.arrowFirstShorten (env sr vel)+         .+         reorderEnvelopeControl)+      (CausalP.processIO+         (CausalP.envelopeStereo+          .+          second+             (let fm = F.lift (arr (snd.snd))+                  shape = F.lift (CausalP.mapSimple SoV.replicate . arr (fst.fst))+                  shapeDecay = F.lift (arr (snd.fst))+                  shapeCtrl =+                     1/3.14 + (shape-1/3.14) *+                        (Exp.causalPackedP (1::Param.T p Real) $& shapeDecay)+                  freqs =+                     stereoFrequenciesFromDetuneBendModulation+                        (frequencyConst 10) $& fm+                  phase = F.lift (arr (fst.fst.snd))+                  phaseDecay = F.lift (arr (snd.fst.snd))+                  expo =+                     (CausalP.mapSimple SoV.replicate $& phase) *+                     (Exp.causalPackedP (1::Param.T p Real) $& phaseDecay)+                  osci = CausalPS.shapeModOsci WaveL.rationalApproxSine1+              in  F.compile $+                  liftA2 Stereo.cons+                     (osci $&  shapeCtrl &|& (expo &|& fmap Stereo.left freqs))+                     (osci $&  shapeCtrl &|& (Additive.negate expo &|& fmap Stereo.right freqs)))))+      (pingControlledEnvelope (Just 0.01))++++filterSawStereoFM ::+   IO (SampleRate Real -> Real -> Real ->+       PIO.T+          (Zip.T PAlsa.GateChunk+             (Zip.T+                (Zip.T (Control Time) (Control Time))+                (Zip.T+                   (Zip.T (Control Frequency) (Control Time))+                   (Zip.T (Control Real) (Control (BM.T Real))))))+          (SV.Vector (Stereo.T Vector)))+filterSawStereoFM =+   liftA2+      (\osc env sr vel freq ->+         osc (sr, ())+         .+         (Zip.arrowSecond $ Zip.arrowSecond $+          Zip.arrowSecond $+            arr $ transposeModulation sr freq)+         .+         (Zip.arrowSecond $+          Zip.arrowFirst $ Zip.arrowSecond $+            arr $ halfLifeControl sr)+         .+         (Zip.arrowSecond $+          Zip.arrowFirst $ Zip.arrowFirst $+            arr $ frequencyControl sr)+         .+         Zip.arrowFirstShorten (env sr vel)+         .+         reorderEnvelopeControl)+      (CausalP.processIO+         (CausalP.envelopeStereo+          .+          second+             (let fm = F.lift (arr snd)+                  cutoff = F.lift (CausalP.mapSimple SoV.replicate . arr (fst.fst))+                  cutoffDecay = F.lift (arr (snd.fst))+                  freqs =+                     stereoFrequenciesFromDetuneBendModulation+                        (frequencyConst 10) $& fm+                  {- bound control in order to avoid too low resonant frequency,+                     which makes the filter instable -}+                  expo =+                     takeThreshold (frequencyConst 100) $&+                     (CausalP.mapSimple SoV.replicate $& cutoff) *+                     (Exp.causalPackedP (1::Param.T p Real) $& cutoffDecay)+              in  F.compile $+                  CausalP.stereoFromMonoControlled+                     (UniFilter.lowpass ^<< CtrlPS.process)+                  $&+                  (CausalP.quantizeLift (100 / fromIntegral vectorSize :: Param.T p Real)+                      (CausalP.mapSimple+                          (UniFilter.parameter (LLVM.valueOf 10)+                           <=<+                           Frame.subsampleVector))+                   $&+                   expo)+                  &|&+                  (CausalP.stereoFromMono+                     (CausalPS.osciSimple WaveL.saw . CausalP.feedFst zero) $&+                     freqs))))+      (pingControlledEnvelope (Just 0.01))++tineStereoFM ::+   IO (SampleRate Real -> Real -> Real ->+       PIO.T+          (Zip.T PAlsa.GateChunk+             (Zip.T+                (Zip.T (Control Time) (Control Time))+                (Zip.T+                   (Zip.T (Control Real) (Control Real))+                   (Zip.T (Control Real) (Control (BM.T Real))))))+          (SV.Vector (Stereo.T Vector)))+tineStereoFM =+   liftA2+      (\osc env sr vel freq ->+         osc (sr, vel)+         .+         (Zip.arrowSecond $ Zip.arrowSecond $+          Zip.arrowSecond $+            arr $ transposeModulation sr freq)+         .+         Zip.arrowFirstShorten (env sr vel)+         .+         reorderEnvelopeControl)+      (CausalP.processIO+         (CausalP.envelopeStereo+          .+          second+             (let vel = number id+                  fm = F.lift (arr snd)+                  freqs =+                     stereoFrequenciesFromDetuneBendModulation+                        (frequencyConst 5) $& fm+                  index = F.lift (CausalP.mapSimple SoV.replicate . arr (fst.fst))+                  depth = F.lift (CausalP.mapSimple SoV.replicate . arr (snd.fst))+                  expo =+                     F.lift $ CausalP.fromSignal $+                     SigPS.exponential2 (timeConst 1) (1 + vel)+                  osci freq =+                     CausalPS.osciSimple WaveL.approxSine2 $&+                        expo * depth *+                           (CausalPS.osciSimple WaveL.approxSine2+                            $& zero &|& index*freq)+                        &|&+                        freq+              in  F.compile $ liftStereo osci freqs)))+      (pingControlledEnvelope (Just 0.01))+++bellNoiseStereoFM ::+   IO (SampleRate Real -> Real -> Real ->+       PIO.T+          (Zip.T PAlsa.GateChunk+             (Zip.T+                (Zip.T (Control Time) (Control Time))+                (Zip.T+                   (Zip.T (Control Real) (Control Real))+                   (Zip.T (Control Real) (Control (BM.T Real))))))+          (SV.Vector (Stereo.T Vector)))+bellNoiseStereoFM =+   liftA3+      (\osc env envInf sr vel freq ->+         osc (sr, ())+         .+         (Zip.arrowSecond $ Zip.arrowSecond $+          Zip.arrowSecond $+            arr $ transposeModulation sr freq)+         .+         Zip.arrowFirstShorten+            (fanoutShorten+               (env sr (vel*0.5))+               (let shortenTimes ::+                       Real ->+                       PIO.T+                          (Zip.T (Control Time) (Control Time))+                          (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))))+         .+         reorderEnvelopeControl)+      (CausalP.processIO+         (let env1 = F.lift (arr (fst.fst))+              env4 = F.lift (arr (fst.snd.fst))+              env7 = F.lift (arr (snd.snd.fst))+              fm = F.lift (arr (snd.snd))+              noiseAmp = F.lift (CausalP.mapSimple SoV.replicate . arr (fst.fst.snd))+              noiseReson = F.lift (arr (snd.fst.snd))+              noiseParam =+                 CausalP.quantizeLift+                    (100 / fromIntegral vectorSize :: Param.T p Real)+                    (CausalP.zipWithSimple (Moog.parameter TypeNum.d8))+              noise =+                 F.lift+                    (CausalP.fromSignal+                       (SigPS.noise 12 (noiseReference 20000)))+              freqs =+                 stereoFrequenciesFromDetuneBendModulation+                    (frequencyConst 5) $& fm+              osci amp env n =+                 CausalPS.amplifyStereo amp $&+                 CausalP.envelopeStereo $&+                 env &|&+                 (CausalP.stereoFromMono+                    (CausalPS.osciSimple WaveL.approxSine4 .+                     CausalP.feedFst zero)+                  $&+                  CausalPS.amplifyStereo n+                  $&+                  freqs)+          in  F.compile $+              (CausalP.envelopeStereo $&+                 (noiseAmp * env1)+                 &|&+                 liftStereo+                    (\freq ->+                       CtrlPS.process $&+                          (noiseParam $& noiseReson &|&+                           (CausalP.mapSimple Frame.subsampleVector $& 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+          (Zip.T PAlsa.GateChunk+             (Zip.T (Control Time) (Control Time)))+          (SV.Vector Vector))+stringControlledEnvelope =+   liftM3+      (\attack sustain release sr vel ->+         let amp = amplitudeFromVelocity vel+         in  PSt.continuePacked+                (mappend+                    (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))+      (CausalP.processIO $+         let amp = number id+         in  CausalP.fromSignal (SigPS.constant amp)+             -+             takeThreshold (1e-4 :: Param.T p Real)+             .+             Exp.causalPackedP amp)+      (CausalP.processIO $+         let amp = number id+         in  CausalP.fromSignal (SigPS.constant amp))+      (CausalP.processIO $+         let level = number id+         in  takeThreshold (0.01 :: Param.T p Real)+             .+             Exp.causalPackedP level)+++windCore ::+   F.T (SampleRate Real, p) a (LLVM.Value Real) ->+   F.T (SampleRate Real, p) a (BM.T (LLVM.Value Real)) ->+   F.T (SampleRate Real, p) a (Stereo.T (LLVM.Value Vector))+windCore reson fm =+   let modu =+          CausalP.mapSimple Frame.subsampleVector $&+          (fmap (`asTypeOf` (undefined :: LLVM.Value Vector)) $+           (MIDIL.frequencyFromBendModulationPacked+              (frequencyConst 0.2) $& fm))+   in  CausalP.stereoFromMonoControlled CtrlPS.process $&+          (CausalP.zipWithSimple+                (Moog.parameter TypeNum.d8) $&+             reson &|& modu)+          &|&+          F.lift (CausalP.fromSignal stereoNoise)++wind ::+   IO (SampleRate Real -> Real -> Real ->+       PIO.T+          (Zip.T PAlsa.GateChunk+             (Zip.T+                (Zip.T (Control Time) (Control Time))+                (Zip.T (Control Real) (Control (BM.T Real)))))+          (SV.Vector (Stereo.T Vector)))+wind =+   liftA2+      (\osc env sr vel freq ->+         osc (sr, ())+         .+         (Zip.arrowSecond $ Zip.arrowSecond $+            arr $ transposeModulation sr freq)+         .+         Zip.arrowFirstShorten (env sr vel)+         .+         reorderEnvelopeControl)+      (CausalP.processIO+         (let env = F.lift (arr fst)+              reson = F.lift (arr (fst.snd))+              fm = F.lift (arr (snd.snd))++          in  F.compile $+              CausalP.envelopeStereo $&+                 env &|&+                 windCore reson fm))+      stringControlledEnvelope+++windPhaser ::+   IO (SampleRate Real -> Real -> Real ->+       PIO.T+          (Zip.T PAlsa.GateChunk+             (Zip.T+                (Zip.T (Control Time) (Control Time))+                (Zip.T (Control Real)+                   (Zip.T (Control Frequency)+                      (Zip.T (Control Real) (Control (BM.T Real)))))))+          (SV.Vector (Stereo.T Vector)))+windPhaser =+   liftA2+      (\osc env sr vel freq ->+         osc (sr, ())+         .+         (Zip.arrowSecond $ Zip.arrowSecond $+          Zip.arrowSecond $ Zip.arrowSecond $+            arr $ transposeModulation sr freq)+         .+         (Zip.arrowSecond $ Zip.arrowSecond $+          Zip.arrowFirst $+            arr $ fmap (Allpass.flangerParameterPlain TypeNum.d8) .+                  frequencyControl sr)+         .+         Zip.arrowFirstShorten (env sr vel)+         .+         reorderEnvelopeControl)+      (CausalP.processIO+         (let env = F.lift (arr fst)+              phaserMix =+                 F.lift (CausalP.mapSimple SoV.replicate . arr (fst.snd))+              phaserFreq = F.lift (arr (fst.snd.snd))+              reson = F.lift (arr (fst.snd.snd.snd))+              fm = F.lift (arr (snd.snd.snd.snd))+              noise = windCore reson fm++          in  F.compile $+              CausalP.envelopeStereo $&+                 env &|&+                 ((CausalP.envelopeStereo $& (1 - phaserMix) &|& noise)+                  ++                  (CausalP.envelopeStereo $&+                     phaserMix &|&+                     (Stereo.arrowFromMonoControlled CtrlPS.process $&+                        phaserFreq &|& noise)))))+      stringControlledEnvelope+++phaserOsci ::+   (Param.T p Real -> Param.T p Real -> CausalP.T p a (LLVM.Value Vector)) ->+   CausalP.T p a (Stereo.T (LLVM.Value Vector))+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+         (Zip.T PAlsa.GateChunk+            (Zip.T+               (Zip.T (Control Time) (Control Time))+               (Zip.T+                  (Control Real)+                  (Zip.T (Control Real) (Control (BM.T Real))))))+         (SV.Vector (Stereo.T Vector))++softStringShapeCore ::+   (forall r.+    LLVM.Value Vector ->+    LLVM.Value Vector ->+    LLVM.CodeGenFunction r (LLVM.Value Vector)) ->+   IO StringInstrument+softStringShapeCore wave =+   liftA2+      (\osc env sr vel freq ->+         osc (sr, ())+         .+         (Zip.arrowSecond $ Zip.arrowSecond $+          Zip.arrowSecond $+            arr $ transposeModulation sr freq)+         .+         Zip.arrowFirstShorten (env sr vel)+         .+         reorderEnvelopeControl)+      (CausalP.processIO+         (CausalP.envelopeStereo+          .+          second+             (let fm = F.lift (arr (snd.snd))+                  det = F.lift (CausalP.mapSimple SoV.replicate . arr (fst.snd))+                  shape = F.lift (CausalP.mapSimple SoV.replicate . arr fst)+                  modu =+                     MIDIL.frequencyFromBendModulationPacked+                        (frequencyConst 5) $& fm+                  osci ::+                     Param.T (mod,fm) Real ->+                     Param.T (mod,fm) Real ->+                     CausalP.T (mod,fm)+                        (LLVM.Value Vector,+                              {- wave shape parameter -}+                         (LLVM.Value Vector, LLVM.Value Vector)+                              {- detune, frequency modulation -})+                        (LLVM.Value Vector)+                  osci p d =+                     CausalPS.shapeModOsci wave+                     .+                     second+                        (CausalP.feedFst (SigPS.constant p)+                         .+                         CausalP.envelope+                         .+                         first (one + CausalPS.amplify d))++              in  F.compile $+                  phaserOsci osci $&  shape &|& det &|& modu)))+      stringControlledEnvelope++arcStringStereoFM ::+   (forall r.+    LLVM.Value Vector ->+    LLVM.CodeGenFunction r (LLVM.Value Vector)) ->+   IO StringInstrument+arcStringStereoFM wave =+   softStringShapeCore+      (\k p ->+         LM.liftR2 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+          (Zip.T PAlsa.GateChunk+             (Zip.T+                (Zip.T (Control Time) (Control Time))+                (Zip.T+                   (Zip.T (Control Real) (Control Real))+                   (Zip.T (Control Real) (Control (BM.T Real))))))+          (SV.Vector (Stereo.T Vector)))+fmStringStereoFM =+   liftA2+      (\osc env sr vel freq ->+         osc (sr, ())+         .+         (Zip.arrowSecond $ Zip.arrowSecond $+          Zip.arrowSecond $+            arr $ transposeModulation sr freq)+         .+         Zip.arrowFirstShorten (env sr vel)+         .+         reorderEnvelopeControl)+      (CausalP.processIO+         (let env = F.lift (arr fst)+              fm = F.lift (arr (snd.snd.snd))+              det = F.lift (CausalP.mapSimple SoV.replicate . arr (fst.snd.snd))+              shape = F.lift (CausalP.mapSimple SoV.replicate . arr (snd.fst.snd))+              depth =+                 CausalP.envelope $&+                    env &|&+                    F.lift (CausalP.mapSimple SoV.replicate . arr (fst.fst.snd))+              modu =+                 MIDIL.frequencyFromBendModulationPacked+                    (frequencyConst 5) $& fm++              osci ::+                 Param.T (mod,fm) Real ->+                 Param.T (mod,fm) Real ->+                 CausalP.T (mod,fm)+                    ((LLVM.Value Vector, LLVM.Value Vector)+                          {- phase modulation depth, modulator distortion -},+                     (LLVM.Value Vector, LLVM.Value Vector)+                          {- detune, frequency modulation -})+                    (LLVM.Value Vector)+              osci p d =+                 CausalPS.osciSimple WaveL.approxSine2+                 .+                 ((CausalP.envelope+                  .+                  second+                     (CausalPS.shapeModOsci WaveL.rationalApproxSine1+                        . second (CausalP.feedFst (SigPS.constant p)))+                  <<^+                  (\((dp, ds), f) -> (dp, (ds, f))))+                  &&& arr snd)+                 .+                 second+                    (CausalP.envelope .+                     first (one + CausalPS.amplify d))++          in  F.compile $+              CausalP.envelopeStereo $&+                 env &|&+                 (phaserOsci osci $&  (depth &|& shape) &|& (det &|& modu))))+      stringControlledEnvelope++++sampledSound ::+   IO (SampledSound ->+       SampleRate Real -> Real -> Real ->+       PIO.T+          (Zip.T PAlsa.GateChunk+             (Zip.T (Control Real) (Control (BM.T Real))))+          (SV.Vector (Stereo.T Vector)))+sampledSound =+   liftA2+      (\osc freqMod smp sr vel freq ->+         {-+         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 pos = samplePositions smp+             amp = 2 * amplitudeFromVelocity vel+             (attack,sustain) =+                mapPair+                   (SigSt.drop (sampleStart pos),+                    SigSt.take (sampleLoopLength pos)) $+                SigSt.splitAt (sampleLoopStart pos) $+                sampleData smp+             release =+                SigSt.drop (sampleLoopStart pos + sampleLoopLength pos) $+                SigSt.take (sampleStart     pos + sampleLength     pos) $+                sampleData smp+             osci smpBody = osc (sr, (amp, smpBody))+         in  mappend+                (osci+                   (attack `SigSt.append`+                    SVL.cycle (SigSt.take (sampleLoopLength pos) sustain))+                 .+                 Gate.shorten)+                (osci release <<^ Zip.second)+             .+             Zip.arrowSecond+                ((id :: PIO.T+                           (SV.Vector (Stereo.T Vector))+                           (SV.Vector (Stereo.T Vector)))+                 .+                 freqMod (sr, ())+                 .+                 (Zip.arrowSecond $ arr $+                    transposeModulation sr (freq * samplePeriod smp))))+      (CausalP.processIO+         (let amp = number fst+              smp = signal snd+          in  CausalPS.amplifyStereo amp+              .+              CausalP.stereoFromMono+                 (CausalPS.pack+                    (CausalP.frequencyModulationLinear+                       {-+                       (SigP.fromStorableVector $+                          fmap (SV.concat . SVL.chunks . SVL.take 1000000) smp)+                       -}+                       (SigP.fromStorableVectorLazy smp)+                       {- (SigP.osciSimple WaveL.saw 0 (1 / 324 {- samplePeriod smp -})) -}))))+      (CausalP.processIO+         (stereoFrequenciesFromDetuneBendModulation (frequencyConst 3)))++makeSampledSounds ::+   FilePath ->+   SampleInfo ->+   IO [SampleRate Real -> Real -> Real ->+       PIO.T+          (Zip.T PAlsa.GateChunk+             (Zip.T (Control Real) (Control (BM.T Real))))+          (SV.Vector (Stereo.T Vector))]+makeSampledSounds dir (file, positions, period) = do+   liftA2+      (\makeSmp smp ->+          map (\pos -> makeSmp (SampledSound smp pos period))+             positions)+      sampledSound+      (loadSound (dir </> file))
+ src/Synthesizer/LLVM/Server/CausalPacked/Run.hs view
@@ -0,0 +1,424 @@+module Synthesizer.LLVM.Server.CausalPacked.Run where++import Synthesizer.LLVM.Server.Packed.Run+          (StereoVector,+           controllerVolume, controllerDetune,+           controllerTimbre0, controllerTimbre1, )+import qualified Sound.MIDI.Controller as Ctrl++import qualified Synthesizer.LLVM.Server.CausalPacked.Instrument as Instr+import qualified Synthesizer.LLVM.Server.Packed.Instrument as InstrP+import qualified Synthesizer.LLVM.Server.Packed.Run as RunP+import qualified Synthesizer.LLVM.Server.Option as Option+import Synthesizer.LLVM.Server.Common++import qualified Sound.ALSA.Sequencer.Event as Event+import qualified Synthesizer.EventList.ALSA.MIDI as Ev++import qualified Synthesizer.CausalIO.ALSA.MIDIControllerSet as MCS+import qualified Synthesizer.CausalIO.ALSA.Process as PAlsa+import qualified Synthesizer.CausalIO.Process as PIO++import qualified Synthesizer.LLVM.CausalParameterized.ProcessPacked as CausalPS+import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP+import qualified Synthesizer.LLVM.Storable.Process as CausalSt+import qualified Synthesizer.LLVM.Storable.Signal as SigStL+import Synthesizer.LLVM.Parameterized.Signal (($#), )++import qualified Synthesizer.LLVM.Frame.StereoInterleaved as StereoInt++import qualified LLVM.Extra.ScalarOrVector as SoV++import qualified Data.StorableVector as SV++import qualified Data.EventList.Relative.TimeTime  as EventListTT++-- import qualified Synthesizer.LLVM.ALSA.BendModulation as BM+import qualified Synthesizer.Zip as Zip++import qualified Sound.ALSA.PCM as PCM++import qualified Synthesizer.Dimensional.MIDIValuePlain as MV+import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg+import qualified Sound.MIDI.Message.Channel as ChannelMsg+import qualified Sound.MIDI.ALSA.Check as Check++import Control.Arrow (Arrow, (<<<), (<<^), (^<<), (***), arr, first, )+import Control.Category (id, )++import qualified Data.Map as Map+{-+import Data.Tuple.HT (mapPair, fst3, snd3, thd3, )+-}++import qualified Number.DimensionTerm as DN+import qualified Algebra.DimensionTerm as Dim++import qualified Algebra.Transcendental as Trans+import qualified Algebra.Additive as Additive++{-+import qualified Numeric.NonNegative.Class   as NonNeg+import qualified Numeric.NonNegative.Chunky  as NonNegChunky+-}+import qualified Numeric.NonNegative.Wrapper as NonNegW++import Prelude hiding (Real, id, )+++++playFromEvents ::+   (PCM.SampleFmt a, Additive.C a) =>+   Option.T ->+   PIO.T (EventListTT.T Ev.StrictTime [Event.T]) (SV.Vector a) ->+   IO ()+playFromEvents opt =+   PAlsa.playFromEvents+      (Option.device opt)+      (Option.clientName opt)+      0.01+      (Option.periodTime opt::Double)+      (case Option.sampleRate opt of+          SampleRate sr -> fromInteger sr)++keyboard :: IO ()+keyboard = do+   opt <- Option.get+   arrange <- CausalSt.makeArranger+   amp <- CausalP.processIO (CausalPS.amplify $# 0.2)++   ping <- Instr.pingRelease++   playFromEvents opt $+      arr SigStL.unpackStrict+      <<<+      amp ()+      <<<+      arrange+      <<<+      arr (EventListTT.mapTime+         (NonNegW.fromNumberUnsafe . fromInteger . NonNegW.toNumber))+      <<<+      PAlsa.sequenceCore+         (Option.channel opt)+         (\ _pgm -> ping 0.8 0.1 (Option.sampleRate opt))+++infixr 3 &+&++(&+&) ::+   (Arrow arrow) =>+   arrow a b -> arrow a c -> arrow a (Zip.T b c)+(&+&) = Zip.arrowFanout++controllerExponentialDirect ::+   (Trans.C y, Dim.C v) =>+   Option.T ->+   VoiceMsg.Controller ->+   (DN.T v y, DN.T v y) ->+   DN.T v y ->+   PIO.T PAlsa.Events (Instr.Control (DN.T v y))+controllerExponentialDirect opt ctrl bnds initial =+   PAlsa.slice+      (Check.controller (Option.channel opt) ctrl)+      (MV.controllerExponential bnds)+      initial++keyboardFM :: IO ()+keyboardFM = do+   opt <- Option.get+   arrange <- CausalSt.makeArranger+   amp <-+      CausalP.processIO+         (CausalP.mapSimple StereoInt.interleave <<<+          (CausalPS.amplifyStereo $# 0.2))++   ping <- Instr.pingStereoReleaseFM++   playFromEvents opt $+      arr SigStL.unpackStereoStrict+      <<<+      amp ()+      <<<+      arrange+      <<<+      arr (EventListTT.mapTime+         (NonNegW.fromNumberUnsafe . fromInteger . NonNegW.toNumber))+      <<<+      -- ToDo: fetch parameters from controllers+      PAlsa.sequenceModulated+         (Option.channel opt)+         (\ _pgm -> ping (Option.sampleRate opt))+      <<<+      id &+&+         ((controllerExponentialDirect opt+             Ctrl.attackTime (DN.time 0.25, DN.time 2.5) (DN.time 0.8)+           &+&+           controllerExponentialDirect opt+             Ctrl.releaseTime (DN.time 0.03, DN.time 0.3) (DN.time 0.1))+          &+&+          ((PAlsa.controllerExponential (Option.channel opt) controllerTimbre0 (1/pi,0.01) 0.05+            &+&+            controllerExponentialDirect opt controllerTimbre1+               (DN.time 0.01, DN.time 10)+               (DN.time 5))+           &+&+           ((PAlsa.controllerLinear (Option.channel opt) Ctrl.soundController5 (0,2) 1+             &+&+             controllerExponentialDirect opt Ctrl.soundController7+                (DN.time 0.25, DN.time 2.5)+                (DN.time 0.8))+            &+&+            (PAlsa.controllerLinear (Option.channel opt) controllerDetune (0,0.005) 0.001+             &+&+             PAlsa.bendWheelPressure (Option.channel opt) 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)+      (MV.controllerExponential bnds)+      initial++keyboardDetuneFMCore ::+   FilePath ->+   IO (ChannelMsg.Channel -> VoiceMsg.Program ->+       SampleRate Real ->+       PIO.T+          (EventListTT.T Ev.StrictTime [Event.T])+          (SV.Vector StereoVector))+keyboardDetuneFMCore smpDir = do+   arrange <- CausalSt.makeArranger+   amp <-+      CausalP.processIO+         (CausalP.mapSimple StereoInt.interleave <<<+          CausalP.envelopeStereo <<<+          first (CausalP.mapSimple SoV.replicate))++   tine <- Instr.tineStereoFM+   ping <- Instr.pingStereoReleaseFM+   filterSaw <- Instr.filterSawStereoFM+   bellNoise <- Instr.bellNoiseStereoFM++   wind <- Instr.wind+   windPhaser <- Instr.windPhaser+   string <- Instr.softStringShapeFM+   fmString <- Instr.fmStringStereoFM+   arcs <- sequence $+      Instr.cosineStringStereoFM :+      Instr.arcSawStringStereoFM :+      Instr.arcSineStringStereoFM :+      Instr.arcSquareStringStereoFM :+      Instr.arcTriangleStringStereoFM :+      []++   tmt0 <- Instr.makeSampledSounds smpDir InstrP.tomatensalat+   hal0 <- Instr.makeSampledSounds smpDir InstrP.hal+   grp0 <- Instr.makeSampledSounds smpDir InstrP.graphentheorie++   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)++       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)++       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 RunP.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))++       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++       bank =+          Map.fromAscList $ zip [VoiceMsg.toProgram 0 ..] $+          [tineProc, pingProc, filterSawProc, bellNoiseProc,+           stringProc, fmStringProc] +++          map makeArc arcs ++ windProc : windPhaserProc :+          map sampled (tmt0 ++ hal0 ++ grp0)++   return $ \chan initPgm rate ->+      amp ()+      <<<+      (MCS.controllerExponential controllerVolume (0.001, 1) (0.2::Float)+       <<^ Zip.second)+      &+&+      (arrange+       <<<+       arr (EventListTT.mapTime+          (NonNegW.fromNumberUnsafe . fromInteger . NonNegW.toNumber))+       <<<+       PAlsa.sequenceModulatedMultiProgram chan initPgm+          (\pgm -> Map.findWithDefault pingProc pgm bank rate))+      <<<+      id &+& MCS.fromChannel chan++keyboardDetuneFM :: IO ()+keyboardDetuneFM = do+   opt <- Option.get+   proc <- keyboardDetuneFMCore (Option.sampleDirectory opt)+   playFromEvents opt $+      arr SigStL.unpackStereoStrict+      <<<+      proc (Option.channel opt) (VoiceMsg.toProgram 0) (Option.sampleRate opt)++keyboardMultiChannel :: IO ()+keyboardMultiChannel = do+   opt <- Option.get+   proc <- keyboardDetuneFMCore (Option.sampleDirectory opt)+   mix <-+      CausalP.processIO $+         CausalP.mapSimple StereoInt.interleave <<<+         CausalP.mix <<<+            CausalP.mapSimple StereoInt.deinterleave ***+            CausalP.mapSimple StereoInt.deinterleave++   playFromEvents opt $+      arr SigStL.unpackStereoStrict+      <<<+      foldl1+         (\x y -> mix () <<< Zip.arrowFanout x y)+         (map+             (\chan ->+                proc (ChannelMsg.toChannel chan) (VoiceMsg.toProgram 0)+                     (Option.sampleRate opt))+             [0 .. 3])
+ src/Synthesizer/LLVM/Server/CausalPacked/Test.hs view
@@ -0,0 +1,346 @@+module Synthesizer.LLVM.Server.CausalPacked.Test where++import qualified Synthesizer.LLVM.Server.CausalPacked.Instrument as Instr+import qualified Synthesizer.LLVM.Server.CausalPacked.Run as Run+import qualified Synthesizer.LLVM.Server.Packed.Instrument as InstrP+import qualified Synthesizer.LLVM.Server.Option as Option+import Synthesizer.LLVM.Server.Packed.Instrument+          (vectorSize, )+import Synthesizer.LLVM.Server.Packed.Run+          (controllerVolume, controllerDetune,+           controllerTimbre0, controllerTimbre1, )+import Synthesizer.LLVM.Server.CausalPacked.Run ((&+&), )+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.Generic.ALSA.MIDI as Gen++import qualified Synthesizer.LLVM.Frame.StereoInterleaved as StereoInt++import qualified Sound.MIDI.Controller as Ctrl++import qualified Synthesizer.CausalIO.Gate as Gate+import qualified Synthesizer.Zip as Zip++import qualified Synthesizer.Storable.ALSA.Play as Play+import Synthesizer.Storable.ALSA.MIDI (Instrument, )++import qualified Synthesizer.PiecewiseConstant.ALSA.MIDIControllerSet as PCS+import qualified Synthesizer.CausalIO.ALSA.MIDIControllerSet as MCS+import qualified Synthesizer.CausalIO.ALSA.Process as PAlsa+import qualified Synthesizer.CausalIO.Process as PIO++import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP+import qualified Synthesizer.LLVM.Storable.Process as CausalSt+import qualified Synthesizer.LLVM.Storable.Signal as SigStL++import qualified LLVM.Extra.ScalarOrVector as SoV++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 Control.Arrow ((<<<), (<<^), arr, first, )+import Control.Category (id, )+import Control.Monad.Trans.State (evalState, )++import qualified Data.Map as Map++import qualified Numeric.NonNegative.Class   as NonNeg+import qualified Numeric.NonNegative.Wrapper as NonNegW+-- import qualified Numeric.NonNegative.Chunky  as NonNegChunky++import qualified Number.DimensionTerm as DN++import Algebra.IntegralDomain (divUp, )+{-+import qualified Algebra.RealRing as RealRing+import qualified Algebra.Additive  as Additive+-}++import Data.Word (Word8, Word32, )+import Data.Int (Int32, )++import Foreign.Storable (Storable, )+import qualified System.IO as IO+import Control.Exception (bracket, )++-- import NumericPrelude.Numeric (zero, round, (^?), )+import Prelude hiding (Real, round, break, id, )+++vectorChunkSize :: SVL.ChunkSize+vectorChunkSize =+   case Play.defaultChunkSize of+      SVL.ChunkSize size ->+         SVL.ChunkSize (divUp size vectorSize)++sampleRatePlain :: Num a => a+sampleRatePlain = Option.defaultSampleRate++sampleRate :: Option.SampleRate Real+sampleRate = Option.SampleRate Option.defaultSampleRate++{- |+try to reproduce a space leak+-}+sequencePlain :: IO ()+sequencePlain =+   SVL.writeFile "/tmp/test.f32" $+--   print $ last $ SVL.chunks $+      CutSt.arrange Option.defaultChunkSize $+      evalState (Gen.sequence Option.defaultChannel (error "no sound" :: Instrument Real Real)) $+      let evs = EventList.cons 10 [] evs+      in  evs+++chopEvents ::+   (NonNeg.C time, Num time) =>+   time ->+   EventListTT.T time body ->+   [EventListTT.T time body]+chopEvents chunkSize =+   let go evs =+          let (chunk,rest) = EventListTT.splitAtTime chunkSize evs+          in  if EventListTT.duration chunk == 0+                then []+                else chunk : go rest+   in  go++-- see playFromEvents+writeTest ::+   (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+                      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 (EventListTT.mapTime+             (NonNegW.fromNumberUnsafe . fromInteger . NonNegW.toNumber))+          <<<+          PAlsa.sequenceCore+             Option.defaultChannel+             (\ _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 chan pitch 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 chan cc 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 <-+      CausalP.processIO+         (CausalP.mapSimple StereoInt.interleave <<<+          CausalP.envelopeStereo <<<+          first (CausalP.mapSimple SoV.replicate))++   ping <- Instr.pingStereoReleaseFM++   let timeControlPercussive =+          Run.controllerExponentialDim Ctrl.attackTime+             (DN.time 0.1, DN.time 2.5) (DN.time 0.8)+          &+&+          Run.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 (Option.sampleRate opt) vel freq+          <<<+          Zip.arrowSecond+             (timeControlPercussive+              &+&+              ((MCS.controllerExponential controllerTimbre0 (0.3,10) 0.05+                &+&+                Run.controllerExponentialDim controllerTimbre1+                    (DN.time 0.01, DN.time 10) (DN.time 5))+               &+&+               ((MCS.controllerLinear Ctrl.soundController5 (0,10) 2+                 &+&+                 Run.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 (EventListTT.mapTime+              (NonNegW.fromNumberUnsafe . fromInteger . NonNegW.toNumber))+           <<<+           PAlsa.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]+++sampledSound :: IO ()+sampledSound = do+   opt <- Option.get++   amp <-+      CausalP.processIO+         (CausalP.mapSimple StereoInt.interleave)++   tomatoSmps <-+      Instr.makeSampledSounds (Option.sampleDirectory opt) InstrP.tomatensalat++   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) $+      replicate 20 $+      Zip.consChecked "Test.sampledSound"+         (Gate.chunk 512 Nothing)+         (PCS.Cons Map.empty (EventListTT.pause 512))
src/Synthesizer/LLVM/Server/Common.hs view
@@ -1,45 +1,47 @@-module Synthesizer.LLVM.Server.Common where+module Synthesizer.LLVM.Server.Common (+   Real,+   SampleRate(SampleRate),+   Instrument,+   frequency, time, number, control, signal, parameter,+   frequencyConst, timeConst,+   ($/),+   play,+   startMessage,+   piecewiseConstant,+   transposeModulation,+   amplitudeFromVelocity,+   makeNote,+   ) where +import qualified Synthesizer.LLVM.Server.Option as Option+import Synthesizer.LLVM.Server.Option (SampleRate(SampleRate), )+ import qualified Sound.ALSA.Sequencer.Event as Event import qualified Sound.ALSA.Sequencer.Address as Addr import qualified Sound.ALSA.Sequencer.Client as Client import qualified Sound.ALSA.Sequencer.Port as Port import qualified Sound.ALSA.Sequencer.Queue as Queue import qualified Sound.ALSA.Sequencer.RealTime as RealTime-import qualified Sound.ALSA.Sequencer.Event as Event  import qualified Sound.ALSA.PCM as ALSA import qualified Synthesizer.Storable.ALSA.Play as Play-import qualified Synthesizer.PiecewiseConstant.ALSA.MIDI as PC-import qualified Synthesizer.PiecewiseConstant.ALSA.MIDIControllerSet as PCS+import qualified Synthesizer.Storable.ALSA.MIDI as AlsaSt+import qualified Synthesizer.PiecewiseConstant.Signal as PC+import qualified Synthesizer.LLVM.ALSA.BendModulation as BM  import qualified Synthesizer.LLVM.Parameterized.Signal as SigP import qualified Synthesizer.LLVM.Parameter as Param -import qualified LLVM.Extra.Representation as Rep+import qualified LLVM.Extra.Memory as Memory+import qualified LLVM.Extra.Class as Class import qualified LLVM.Core as LLVM -import qualified Data.EventList.Relative.BodyTime  as EventListBT- import qualified Synthesizer.Storable.Signal      as SigSt-import qualified Data.StorableVector.Lazy         as SVL  import Foreign.Storable (Storable, ) -import qualified Synthesizer.Generic.Signal    as SigG--import qualified Sound.MIDI.Message.Channel       as ChannelMsg--import qualified Sound.Sox.Frame         as SoxFrame--import Control.Arrow ((^<<), )--import qualified Numeric.NonNegative.Wrapper as NonNegW+import Control.Arrow (arr, (^<<), ) -import qualified Algebra.RealRing as RealRing-import qualified Algebra.Field     as Field-import qualified Algebra.Ring      as Ring-import qualified Algebra.ToInteger as ToInteger import qualified Algebra.Additive  as Additive  import Data.Word (Word8, )@@ -49,80 +51,82 @@   -channel :: ChannelMsg.Channel-channel = ChannelMsg.toChannel 0+type Real = Float -sampleRate :: Num a => a--- sampleRate = 24000--- sampleRate = 48000-sampleRate = 44100+type Instrument a sig = SampleRate a -> AlsaSt.Instrument a sig -latency :: Int-latency = 0--- latency = 256--- latency = 480 -chunkSize :: SVL.ChunkSize-chunkSize = Play.defaultChunkSize+frequency :: (p -> Real) -> Param.T (SampleRate Real, p) Real+frequency param =+   arr (\(SampleRate sampleRate, p) -> param p / sampleRate) +time :: (p -> Real) -> Param.T (SampleRate Real, p) Real+time param =+   arr (\(SampleRate sampleRate, p) -> param p * sampleRate) -lazySize :: SigG.LazySize-lazySize =-   let (SVL.ChunkSize size) = chunkSize-   in  SigG.LazySize size+number :: (p -> Real) -> Param.T (SampleRate Real, p) Real+number param = arr (param . snd) -periodTime :: Field.C t => t-periodTime =-   let (SVL.ChunkSize size) = chunkSize-   in  ToInteger.fromIntegral size Field./ Ring.fromInteger sampleRate+control :: (p -> PC.T Real) -> Param.T (SampleRate Real, p) (PC.T Real)+control param = arr (param . snd) +signal :: (p -> SigSt.T a) -> Param.T (SampleRate Real, p) (SigSt.T a)+signal param = arr (param . snd) -type Real = Float+parameter :: (p -> a) -> Param.T (SampleRate Real, p) a+parameter param = arr (param . snd)  +frequencyConst :: Real -> Param.T (SampleRate Real, p) Real+frequencyConst param =+   arr (\(SampleRate sampleRate, _p) -> param / sampleRate)++timeConst :: Real -> Param.T (SampleRate Real, p) Real+timeConst param =+   arr (\(SampleRate sampleRate, _p) -> param * sampleRate)+++ ($/) :: (Functor f) => f (a -> b) -> a -> f b f $/ x = fmap ($x) f  +-- ToDo: do not record the empty chunk that is inserted for latency {-# INLINE play #-} play ::-   (RealRing.C t, Additive.C y, ALSA.SampleFmt y) =>-   t -> t -> SigSt.T y -> IO ()-play period rate =-   Play.auto period (round rate) .-   SigSt.append (SigSt.replicate chunkSize latency zero)---   FiltG.delayPosLazySize chunkSize latency---   FiltG.delayPos latency+   (Additive.C y, ALSA.SampleFmt y) =>+   Option.T -> Double -> SigSt.T y -> IO ()+play opts rate =+   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) --- ToDo: do not record the empty chunk that is inserted for latency-{-# INLINE playAndRecord #-}-playAndRecord ::-   (RealRing.C t, Additive.C y, ALSA.SampleFmt y, SoxFrame.C y) =>-   FilePath -> t -> t -> SigSt.T y -> IO ()-playAndRecord fileName period rate =-   Play.autoAndRecord period fileName (round rate) .-   SigSt.append (SigSt.replicate chunkSize latency zero) +startMessage :: String+startMessage =+   "run 'aconnect' to connect to the MIDI controller" + piecewiseConstant ::    (Storable a,-    LLVM.MakeValueTuple a al,-    Rep.Memory al am,+    Class.MakeValueTuple a al,+    Memory.C al am,     LLVM.IsSized am as) =>    Param.T p (PC.T a) -> SigP.T p al piecewiseConstant pc =    SigP.piecewiseConstant-      (EventListBT.mapTime-         (NonNegW.fromNumber . fromIntegral . NonNegW.toNumber) ^<< pc)---   SigP.piecewiseConstant (PC.subdivideInt ^<< pc)+      (PC.subdivideLongStrict ^<< pc)  transposeModulation ::    (Functor stream) =>+   SampleRate Real ->    Real ->-   stream (PC.BendModulation Real) ->-   stream (PC.BendModulation Real)-transposeModulation freq =-   fmap (PC.shiftBendModulation (freq/sampleRate))+   stream (BM.T Real) ->+   stream (BM.T Real)+transposeModulation (SampleRate sampleRate) freq =+   fmap (BM.shift (freq/sampleRate))   {-# INLINE amplitudeFromVelocity #-}
+ src/Synthesizer/LLVM/Server/Option.hs view
@@ -0,0 +1,196 @@+module Synthesizer.LLVM.Server.Option (+   T(..),+   get,+   defaultChannel,+   Play.defaultChunkSize,+   defaultSampleRate,+   defaultLatency,+   SampleRate(SampleRate),+   sampleRate,+   ) where++import qualified Synthesizer.Storable.ALSA.Play as Play+import qualified Synthesizer.Generic.Signal     as SigG+import qualified Data.StorableVector.Lazy       as SVL+import Synthesizer.EventList.ALSA.MIDI (ClientName(ClientName))++import qualified Sound.MIDI.Message.Channel as ChannelMsg++import System.Console.GetOpt+          (getOpt, ArgOrder(..), OptDescr(..), ArgDescr(..), usageInfo, )+import System.Environment (getArgs, getProgName, )+import System.Exit (exitSuccess, exitFailure, )+import qualified System.IO as IO++import Control.Monad (when, )++import qualified NumericPrelude.Numeric as NP+import Prelude hiding (Real, )+++data T =+   Cons {+      device :: Play.Device,+      clientName :: ClientName,+      channel, extraChannel :: ChannelMsg.Channel,+      sampleDirectory :: FilePath,+      sampleRateInt :: SampleRate Integer,+      chunkSize :: SVL.ChunkSize,+      lazySize :: SigG.LazySize,+      periodTime :: Double,+      latency :: Int+   }+   deriving (Show)+++deflt :: T+deflt =+   Cons {+      device = Play.defaultDevice,+      clientName = defaultClientName,+      channel = defaultChannel,+      extraChannel = ChannelMsg.toChannel 1,+      sampleDirectory = "speech",+      sampleRateInt = SampleRate defaultSampleRate,+      chunkSize = Play.defaultChunkSize,+      lazySize = error "Option.lazySize must be initialized after option parsing",+      periodTime = error "Option.periodTime must be initialized after option parsing",+      latency = defaultLatency+   }++defaultClientName :: ClientName+defaultClientName =+   ClientName "Haskell-LLVM-Synthesizer"++defaultChannel :: ChannelMsg.Channel+defaultChannel = ChannelMsg.toChannel 0++defaultSampleRate :: Num a => a+-- defaultSampleRate = 24000+-- defaultSampleRate = 48000+defaultSampleRate = 44100++defaultLatency :: Int+defaultLatency =+   -- 0+   -- 256+   1024+++newtype SampleRate a = SampleRate a+   deriving (Show)++instance Functor SampleRate where+   fmap f (SampleRate sr) = SampleRate (f sr)+++sampleRate :: Num a => T -> SampleRate a+sampleRate = fmap fromInteger . sampleRateInt+++exitFailureMsg :: String -> IO a+exitFailureMsg msg =+   IO.hPutStrLn IO.stderr msg >> exitFailure++parseChannel :: String -> IO ChannelMsg.Channel+parseChannel str =+   case reads str of+      [(chan, "")] ->+         if 0<=chan && chan<16+           then return $ ChannelMsg.toChannel chan+           else exitFailureMsg "MIDI channel must a number from 0..15"+      _ ->+         exitFailureMsg $ "channel must be a number, but is '" ++ str ++ "'"++parseNumber ::+   (Read a) =>+   String -> (a -> Bool) -> String -> String -> IO a+parseNumber name constraint constraintName str =+   case reads str of+      [(n, "")] ->+         if constraint n+           then return n+           else exitFailureMsg $ name ++ " must be a " ++ constraintName ++ " number"+      _ ->+         exitFailureMsg $ name ++ " must be a number, but is '" ++ str ++ "'"++maxInt :: Integer+maxInt =+   fromIntegral (maxBound :: Int)+++{-+Guide for common Linux/Unix command-line options:+  http://www.faqs.org/docs/artu/ch10s05.html+-}+description :: [OptDescr (T -> IO T)]+description =+   Option ['h'] ["help"]+      (NoArg $ \ _flags -> do+         programName <- getProgName+         putStrLn+            (usageInfo ("Usage: " ++ programName ++ " [OPTIONS]") description)+         exitSuccess)+      "show options" :+   Option ['d'] ["device"]+      (flip ReqArg "NAME" $ \str flags ->+         return $ flags{device = str})+      "select ALSA output device" :+   Option [] ["clientname"]+      (flip ReqArg "NAME" $ \str flags ->+         return $ flags{clientName = ClientName str})+      "name of the ALSA client" :+   Option ['r'] ["samplerate"]+      (flip ReqArg "RATE" $ \str flags ->+         fmap (\rate -> flags{sampleRateInt = SampleRate rate}) $+         parseNumber "sample-rate" (\n -> 0<n && n<=maxInt) "positive" str)+      "sample-rate in samples per second" :+   Option ['b'] ["blocksize"]+      (flip ReqArg "SIZE" $ \str flags ->+         fmap (\size -> flags{chunkSize = SVL.ChunkSize $ fromInteger size}) $+         parseNumber "blocksize" (\n -> 0<n && n<=maxInt) "positive" str)+      "block size as number of sample-frames" :+   Option [] ["latency"]+      (flip ReqArg "SIZE" $ \str flags ->+         fmap (\size -> flags{latency = fromInteger size}) $+         parseNumber "latency" (\n -> 0<=n && n<=maxInt) "non-negative" str)+      "latency as number of sample-frames" :+   Option ['c'] ["channel"]+      (flip ReqArg "CHANNEL" $ \str flags ->+         fmap (\chan -> flags{channel = chan}) $+         parseChannel str)+      "select MIDI input channel (0-based)" :+   Option [] ["extra-channel"]+      (flip ReqArg "CHANNEL" $ \str flags ->+         fmap (\chan -> flags{extraChannel = chan}) $+         parseChannel str)+      "select MIDI channel with effects" :+   Option ['I'] ["sample-directory"]+      (flip ReqArg "DIR" $ \str flags ->+         return $ flags{sampleDirectory = str})+      "directory for sound samples" :+   []+++get :: IO T+get = do+   argv <- getArgs+   let (opts, files, errors) = getOpt RequireOrder description argv+   when (not $ null errors) $+      exitFailureMsg (init (concat errors))+   when (not $ null files) $+      exitFailureMsg $+         "Do not know what to do with arguments " ++ show files+   fmap+      (\actual ->+         case chunkSize actual of+            SVL.ChunkSize size ->+               actual {+                  lazySize = SigG.LazySize size,+                  periodTime =+                     NP.fromIntegral size NP./+                     case sampleRate actual of SampleRate sr -> sr+               }) $+      foldl (>>=)+         (return deflt)+         opts
src/Synthesizer/LLVM/Server/Packed/Instrument.hs view
@@ -1,1494 +1,1568 @@-{-# LANGUAGE Rank2Types #-}-module Synthesizer.LLVM.Server.Packed.Instrument where--import Synthesizer.LLVM.Server.Common--import qualified Synthesizer.EventList.ALSA.MIDI as Ev-import qualified Synthesizer.PiecewiseConstant.ALSA.MIDI as PC--import qualified Synthesizer.LLVM.Frame.Stereo as Stereo--import qualified Sound.Sox.Read          as SoxRead-import qualified Sound.Sox.Option.Format as SoxOption--import Synthesizer.Storable.ALSA.MIDI (Instrument, chunkSizesFromLazyTime, )--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.ALSA.MIDI as MIDIL-import qualified Synthesizer.LLVM.CausalParameterized.ProcessPacked as CausalPS-import qualified Synthesizer.LLVM.CausalParameterized.ControlledPacked as CtrlPS-import qualified Synthesizer.LLVM.Parameterized.SignalPacked as SigPS-import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP-import qualified Synthesizer.LLVM.Parameterized.Signal as SigP-import qualified Synthesizer.LLVM.Storable.Signal as SigStL-import qualified Synthesizer.LLVM.Sample as Sample-import qualified Synthesizer.LLVM.Wave as WaveL-import qualified Synthesizer.LLVM.Parameter as Param-import Synthesizer.LLVM.CausalParameterized.Process (($<), ($>), ($*), )-import Synthesizer.LLVM.Parameterized.Signal (($#), )--import qualified LLVM.Extra.ScalarOrVector as SoV-import qualified LLVM.Extra.Monad as LM-import qualified LLVM.Extra.Arithmetic as A-import qualified LLVM.Core as LLVM-import qualified Data.TypeLevel.Num as TypeNum--import Control.Arrow.Monad ((=<<<), listen, )-import qualified Data.HList as HL--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 Control.Arrow ((<<<), (^<<), (<<^), (&&&), (***), arr, first, second, )-import Control.Applicative (liftA2, liftA3, )--import Data.Tuple.HT (mapPair, fst3, snd3, thd3, )--import Data.Int (Int32, )--{--import qualified Numeric.NonNegative.Class   as NonNeg-import qualified Numeric.NonNegative.Wrapper as NonNegW--}-import qualified Numeric.NonNegative.Chunky as NonNegChunky--import qualified Algebra.RealRing as RealRing-import qualified Algebra.Additive  as Additive--import NumericPrelude.Numeric (zero, round, (^?), )-import Prelude hiding (Real, round, break, )----type Vector = LLVM.Vector VectorSize Real-type VectorSize = TypeNum.D4---vectorSize :: Int-vectorSize = TypeNum.toInt (undefined :: VectorSize)--vectorChunkSize :: SVL.ChunkSize-vectorChunkSize =-   let (SVL.ChunkSize size) = chunkSize-   in  SVL.ChunkSize (div size vectorSize)--vectorRate :: Fractional a => a-vectorRate = sampleRate / fromIntegral vectorSize---frequencyFromBendModulation ::-{--   (Storable a,-    LLVM.MakeValueTuple a (Value a)) =>--}-   Param.T p Real ->-   Param.T p (PC.T (PC.BendModulation Real), Real) ->-   SigP.T p (LLVM.Value Vector)-frequencyFromBendModulation speed fmFreq =-   MIDIL.frequencyFromBendModulationPacked (speed/sampleRate)-      $* piecewiseConstant-            (fmap (\(fm,freq) -> transposeModulation freq fm) fmFreq)--stereoFrequenciesFromDetuneBendModulation ::-   Param.T p Real ->-   Param.T p (PC.T Real, PC.T (PC.BendModulation Real), Real) ->-   SigP.T p (Stereo.T (LLVM.Value Vector))-stereoFrequenciesFromDetuneBendModulation speed detFmFreq =-   (CausalP.envelopeStereo-      $< frequencyFromBendModulation speed-           (fmap (\(_det,fm,freq) -> (fm,freq)) detFmFreq))-   <<<-   CausalP.zipWithSimple Sample.zipStereo-   <<<-   CausalPS.raise 1 &&&-   (CausalPS.raise 1 <<< CausalP.mapSimple LLVM.neg)-   $* piecewiseConstantVector-         (fmap (\(det,_fm,_freq) -> det) detFmFreq)---pingReleaseEnvelope ::-   IO (Real -> Real -> Real -> Ev.LazyTime -> SigSt.T Vector)-pingReleaseEnvelope =-   liftA2-      (\pressed release decay rel vel dur ->-         SigStL.continuePacked-            (pressed (chunkSizesFromLazyTime dur) (decay,vel))-            (\x -> release vectorChunkSize (rel,x)))-      (SigP.runChunkyPattern $-       let decay = arr fst-           velocity = arr snd-       in  SigPS.exponential2 (decay*sampleRate)-              (amplitudeFromVelocity ^<< velocity))-      (SigP.runChunky $-       let release = arr fst-           amplitude = arr snd-       in  (CausalP.take (round ^<< (release*5*vectorRate)) $*-            SigPS.exponential2 (release*sampleRate) amplitude))--pingRelease ::-   IO (Real -> Real -> Instrument Real Vector)-pingRelease =-   liftA2-      (\osc env dec rel vel freq dur ->-         osc freq (env dec rel vel dur))-      (CausalP.runStorableChunky-         (let freq = arr id-          in  CausalP.envelope $>-              SigPS.osciSimple WaveL.saw zero (freq/sampleRate)))-      pingReleaseEnvelope--pingStereoRelease ::-   IO (Real -> Real -> Instrument Real (Stereo.T Vector))-pingStereoRelease =-   liftA2-      (\osc env dec rel vel freq dur ->-         osc freq (env dec rel vel dur))-      (CausalP.runStorableChunky-         (let freq = arr id-          in  CausalP.envelopeStereo $>-              SigP.zipWithSimple Sample.zipStereo-                 (SigPS.osciSimple WaveL.saw zero-                     (0.999*freq/sampleRate))-                 (SigPS.osciSimple WaveL.saw zero-                     (1.001*freq/sampleRate))))-      pingReleaseEnvelope--pingStereoReleaseFM ::-   IO (Real -> Real ->-       PC.T Real ->-       PC.T Real ->-       Real -> Real ->-       PC.T (PC.BendModulation Real) ->-       Instrument Real (Stereo.T Vector))-pingStereoReleaseFM =-   liftA2-      (\osc env dec rel detune shape phase phaseDecay fm vel freq dur ->-         osc-            ((phase, phaseDecay), shape, (detune,fm,freq))-            (env dec rel vel dur))-      (CausalP.runStorableChunky-         (let phs = arr (fst.fst3)-              dec = arr (snd.fst3)-              shp = arr snd3-              fm  = arr thd3-          in  CausalP.envelopeStereo $>-              ((CausalP.stereoFromMonoControlled-                  (CausalPS.shapeModOsci WaveL.rationalApproxSine1)-                    $< piecewiseConstantVector shp)-                  <<^ Stereo.interleave-                $< (CausalP.zipWithSimple Sample.zipStereo-                    <<<-                    arr id &&& CausalP.mapSimple LLVM.neg-                     $* SigPS.exponential2 (dec*sampleRate) phs)-                $* stereoFrequenciesFromDetuneBendModulation 10 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 ->-       PC.T (PC.BendModulation Real) ->-       Instrument Real (Stereo.T Vector))-squareStereoReleaseFM =-   liftA2-      (\osc env dec rel detune shape phase fm vel freq dur ->-         osc-            ((phase, shape), (detune,fm,freq))-            (env dec rel vel dur))-      (CausalP.runStorableChunky-         (let phs = arr (fst.fst)-              shp = arr (snd.fst)-              fm  = arr snd-              chanOsci =-                 CausalP.mix-                 <<<-                 (CausalPS.shapeModOsci WaveL.rationalApproxSine1-                  <<<-                  second (first (CausalP.mapSimple LLVM.neg)))-                 &&&-                 (CausalP.mapSimple LLVM.neg-                  <<<-                  CausalPS.shapeModOsci WaveL.rationalApproxSine1)-                 <<^-                 (\((p,s),f) -> (s,(p,f)))-          in  CausalP.envelopeStereo $>-              ((CausalP.stereoFromMonoControlled chanOsci-                   $< SigP.zip-                         (piecewiseConstantVector phs)-                         (piecewiseConstantVector shp))-                $* stereoFrequenciesFromDetuneBendModulation 10 fm)))-      pingReleaseEnvelope--bellStereoFM ::-   IO (Real -> Real ->-       PC.T Real ->-       PC.T (PC.BendModulation Real) ->-       Instrument Real (Stereo.T Vector))-bellStereoFM =-   liftA2-      (\osc env dec rel detune fm vel freq dur ->-         osc ((detune, fm, freq), vel,-              (env (dec/4) rel vel dur,-               env (dec/7) rel vel dur))-             (env dec rel vel dur))-      (CausalP.runStorableChunky-         (let fm   = arr fst3-              vel  = arr snd3-              env4 = arr (fst.thd3)-              env7 = arr (snd.thd3)-              mix x y = CausalP.mixStereo <<< x&&&y-              osci sel v d =-                 CausalP.envelopeStereo-                 <<<-                 (arr sel ***-                    (CausalPS.amplifyStereo v-                     <<<-                     CausalP.stereoFromMono-                        (CausalPS.osciSimple WaveL.approxSine4-                           $< SigPS.constant zero)-                     <<<-                     CausalPS.amplifyStereo d))-          in  (osci fst3  0.6              1 `mix`-               osci snd3 (0.02 *  50^?vel) 4 `mix`-               osci thd3 (0.02 * 100^?vel) 7)-              <<<-              CausalP.feedSnd (stereoFrequenciesFromDetuneBendModulation 5 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.-                  -}-                  SigP.zip-                     (SigP.fromStorableVectorLazy env4)-                     (SigP.fromStorableVectorLazy env7)))-      pingReleaseEnvelope--bellNoiseStereoFM ::-   IO (Real -> Real ->-       PC.T Real -> PC.T Real ->-       PC.T (PC.BendModulation Real) ->-       Instrument Real (Stereo.T Vector))-bellNoiseStereoFM =-   liftA2-      (\osc env dec rel noiseAmp noiseReson fm vel freq dur ->-         osc ((fm, freq),-              (noiseAmp,noiseReson),-              (vel,-               env (dec/4) rel vel dur,-               env (dec/7) rel vel dur))-             (env dec rel vel dur))-      (CausalP.runStorableChunky-         (let fm   = arr fst3-              noiseAmp   = arr (fst.snd3)-              noiseReson = arr (snd.snd3)-              vel  = arr (fst3.thd3)-              env4 = arr (snd3.thd3)-              env7 = arr (thd3.thd3)-              mix x y = CausalP.mix <<< x&&&y-              osci sel v d =-                 CausalP.envelope-                 <<<-                 (arr sel ***-                    (CausalPS.amplify v-                     <<<-                     (CausalPS.osciSimple WaveL.approxSine4-                        $< SigPS.constant zero)-                     <<<-                     CausalPS.amplify d))-              noise sel d =-                 (CausalP.envelope $<-                    piecewiseConstantVector noiseAmp)-                 <<<-                 CausalP.envelope-                 <<<-                 (arr sel ***-                    ({- UniFilter.lowpass-                        ^<< -}-                     (CtrlPS.process-                        $> SigPS.noise 12 (sampleRate/20000))-                     <<<---                     CausalP.zipWithSimple UniFilterL.parameter-                     CausalP.zipWithSimple (MoogL.parameter TypeNum.d8)-{--FIXME:-This leads to a run-time crash even without LLVM optimizations.-However, I cannot reproduce this in the Test module.-                     (CausalP.quantizeLift $# (1 :: Real)) (arr id)--                     (CausalP.quantizeLift-                        $# (128 / fromIntegral vectorSize :: Real))-                           (CausalP.zipWithSimple UniFilterL.parameter)--                     (CausalP.quantizeLift-                        $# (128 / fromIntegral vectorSize :: Real))-                           (CausalP.zipWithSimple (MoogL.parameter TypeNum.d8))--}-                     <<<-                     CausalP.feedFst (piecewiseConstant noiseReson)-                     <<<-                     CausalP.mapSimple Sample.subsampleVector-                     <<<-                     CausalPS.amplify d))-          in  CausalP.zipWithSimple Sample.zipStereo-              <<<-              (osci fst3  0.6              (1*0.999) `mix`-               osci snd3 (0.02 *  50^?vel) (4*0.999) `mix`-               osci thd3 (0.02 * 100^?vel) (7*0.999) `mix`-               noise fst3 0.999) &&&-              (osci fst3  0.6              (1*1.001) `mix`-               osci snd3 (0.02 *  50^?vel) (4*1.001) `mix`-               osci thd3 (0.02 * 100^?vel) (7*1.001) `mix`-               noise fst3 1.001)-              <<<-              CausalP.feedSnd (frequencyFromBendModulation 5 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.-                  -}-                  SigP.zip-                     (SigP.fromStorableVectorLazy env4)-                     (SigP.fromStorableVectorLazy env7)))-      pingReleaseEnvelope---tine :: IO (Real -> Real -> Instrument Real Vector)-tine =-   liftA2-      (\osc env dec rel vel freq dur ->-         osc (vel,freq) (env dec rel 0 dur))-      (CausalP.runStorableChunky-         (let freq = arr snd-              vel  = arr fst-          in  CausalP.envelope $>-                 (CausalPS.osciSimple WaveL.approxSine2-                    $> (SigPS.constant (freq/sampleRate))-                    $* (CausalP.envelope-                          $< SigPS.exponential2 (1*sampleRate) (vel+1)-                          $* SigPS.osciSimple WaveL.approxSine2 zero-                                (2*freq/sampleRate)))))-      pingReleaseEnvelope--tineStereo :: IO (Real -> Real -> Instrument Real (Stereo.T Vector))-tineStereo =-   liftA2-      (\osc env dec rel vel freq dur ->-         osc (vel,freq) (env dec rel 0 dur))-      (CausalP.runStorableChunky-         (let freq = arr snd-              vel  = arr fst-              chanOsci d =-                 CausalPS.osciSimple WaveL.approxSine2-                    $> SigPS.constant (freq*d/sampleRate)-          in  CausalP.envelopeStereo $>-                 ((CausalP.zipWithSimple Sample.zipStereo <<<-                    (chanOsci 0.995 &&& chanOsci 1.005))-                  $* SigP.envelope-                        (SigPS.exponential2 (1*sampleRate) (vel+1))-                        (SigPS.osciSimple WaveL.approxSine2 zero-                           (2*freq/sampleRate)))))-      pingReleaseEnvelope---softStringReleaseEnvelope ::-   IO (Real -> Real -> Ev.LazyTime -> SigSt.T Vector)-softStringReleaseEnvelope =-   liftA2-      (\rev env attackTime vel dur ->-         let attackTimeVector =-                div (round (attackTime*sampleRate)) vectorSize-             amp = amplitudeFromVelocity vel-             {--             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 attackTimeVector $-                env (chunkSizesFromLazyTime dur) (amp, attackTimeVector)-             release = rev attack-         in  attack `SigSt.append` sustain `SigSt.append` release)-      SigStL.makeReversePacked-      (let amp = arr fst-           attackTimeVector = arr snd-       in  SigP.runChunkyPattern $-           flip SigP.append (SigPS.constant amp) $-           (CausalPS.amplify amp <<<-            CausalP.take attackTimeVector-            $* SigPS.parabolaFadeInInf-                  (fmap fromIntegral attackTimeVector *-                   fromIntegral vectorSize)))--softString :: IO (Instrument Real (Stereo.T Vector))-softString =-   liftA2-      (\osc env vel freq dur ->-         osc freq (env 1 vel dur))-      (let freq = arr id-           osci d =-              SigPS.osciSimple WaveL.saw zero (d * freq / sampleRate)-       in  CausalP.runStorableChunky $-           (CausalP.envelopeStereo $>-              (SigP.zipWithSimple Sample.zipStereo-                 (SigP.mix-                    (osci 1.005)-                    (osci 0.998))-                 (SigP.mix-                    (osci 1.002)-                    (osci 0.995)))))-      softStringReleaseEnvelope---softStringFM ::-   IO (PC.T (PC.BendModulation Real) ->-       Instrument Real (Stereo.T Vector))-softStringFM =-   liftA2-      (\osc env fm vel freq dur ->-         osc (fm,freq) (env 1 vel dur))-      (let fm = arr id-           osci ::-              Param.T fm Real ->-              CausalP.T fm (LLVM.Value Vector) (LLVM.Value Vector)-           osci d =-              (CausalPS.osciSimple WaveL.saw $<-                  (SigPS.constant $# (zero::Real))) <<<-              CausalPS.amplify d-       in  CausalP.runStorableChunky $-           (CausalP.envelopeStereo $>-              (CausalP.zipWithSimple Sample.zipStereo-               <<<-               (CausalP.mix  <<<  osci 1.005 &&& osci 0.998) &&&-               (CausalP.mix  <<<  osci 1.002 &&& osci 0.995)-               $* frequencyFromBendModulation 5 fm)))-      softStringReleaseEnvelope---tineStereoFM ::-   IO (Real -> Real ->-       PC.T (PC.BendModulation Real) ->-       Instrument Real (Stereo.T Vector))-tineStereoFM =-   liftA2-      (\osc env dec rel fm vel freq dur ->-         osc (vel,(fm,freq)) (env dec rel 0 dur))-      (CausalP.runStorableChunky-         (let vel  = arr fst-              fm   = arr snd-              chanOsci d =-                 CausalPS.osciSimple WaveL.approxSine2-                    <<< second (CausalPS.amplify d)-          in  CausalP.envelopeStereo $>-                 ((CausalP.zipWithSimple Sample.zipStereo <<<-                    chanOsci 0.995 &&& chanOsci 1.005)-                  <<<-                  (((CausalP.envelope-                       $< SigPS.exponential2 (1*sampleRate) (vel+1))-                     <<< (CausalPS.osciSimple WaveL.approxSine2-                             $< (SigPS.constant $# (zero::Real)))-                     <<< CausalPS.amplify 2)-                   &&& arr id)-                  $* frequencyFromBendModulation 5 fm)))-      pingReleaseEnvelope---tineControlledProc, tineControlledFnProc ::-   Param.T p (PC.T Real) ->-   Param.T p (PC.T Real) ->-   Param.T p Real ->-   CausalP.T p-      (Stereo.T (LLVM.Value Vector))-      (Stereo.T (LLVM.Value Vector))-tineControlledProc index depth vel =-   CausalP.stereoFromMono-      (CausalPS.osciSimple WaveL.approxSine2)-   <<<-   Stereo.interleave-   ^<<-   ((CausalP.envelopeStereo-       $< SigP.envelope-             (piecewiseConstantVector depth)-             (SigPS.exponential2 (1*sampleRate) (vel+1)))-    <<<-    CausalP.stereoFromMono-       (CausalPS.osciSimple WaveL.approxSine2-          $< (SigPS.constant $# (zero::Real)))-    <<<-    (CausalP.envelopeStereo-       $< piecewiseConstantVector index))-            &&& arr id--tineControlledFnProc index depth vel =-   ((\freq ->-        CausalP.stereoFromMono-           (CausalPS.osciSimple WaveL.approxSine2)-        <<<-        Stereo.interleave-        ^<<-         ((CausalP.envelopeStereo-             $< SigP.envelope-                   (piecewiseConstantVector depth)-                   (SigPS.exponential2 (1*sampleRate) (vel+1)))-          <<<-          CausalP.stereoFromMono-             (CausalPS.osciSimple WaveL.approxSine2-                $< (SigPS.constant $# (zero::Real)))-          <<<-          (CausalP.envelopeStereo-             $< piecewiseConstantVector index)-          <<<-          listen freq)-         &&&-         listen freq)---    =<<< listen HL.hNil-    =<<< arr HL.hHead)-   <<< arr (\freq -> HL.hCons freq HL.hNil)--tineControlledFM ::-   IO (Real -> Real ->-       PC.T Real ->-       PC.T Real -> PC.T Real ->-       PC.T (PC.BendModulation Real) ->-       Instrument Real (Stereo.T Vector))-tineControlledFM =-   liftA2-      (\osc env dec rel detune index depth fm vel freq dur ->-         osc-            ((index, depth), vel, (detune,fm,freq))-            (env dec rel 0 dur))-      (CausalP.runStorableChunky-         (let index = arr (fst.fst3)-              depth = arr (snd.fst3)-              vel   = arr snd3-              fm    = arr thd3-          in  CausalP.envelopeStereo $>-                 (tineControlledFnProc index depth vel $*-                  stereoFrequenciesFromDetuneBendModulation 5 fm)))-      pingReleaseEnvelope---fenderProc ::-   Param.T p (PC.T Real) ->-   Param.T p (PC.T Real) ->-   Param.T p (PC.T Real) ->-   Param.T p Real ->-   CausalP.T p-      (Stereo.T (LLVM.Value Vector))-      (Stereo.T (LLVM.Value Vector))-fenderProc fade index depth vel =-   ((\stereoFreq ->-       let channel_n_1 freq =-              CausalPS.osciSimple WaveL.approxSine2-              <<<-              ((CausalP.envelope-                  $< SigP.envelope-                        (piecewiseConstantVector depth)-                        (SigPS.exponential2 (1*sampleRate) (vel+1)))-               <<<-               (CausalPS.osciSimple WaveL.approxSine2-                  $< (SigPS.constant $# (zero::Real)))-               <<<-               (CausalP.envelope-                  $< piecewiseConstantVector index)-               <<<-               freq)-              &&&-              freq-           channel_1_2 freq =-              CausalPS.osciSimple WaveL.approxSine2-              <<<-              ((CausalP.envelope-                  $< SigP.envelope-                        (piecewiseConstantVector depth)-                        (SigPS.exponential2 (1*sampleRate) (vel+1)))-               <<<-               (CausalPS.osciSimple WaveL.approxSine2-                  $< (SigPS.constant $# (zero::Real)))-               <<<-               freq)-              &&&-              (CausalPS.amplify 2 <<< freq)-       in  (CausalP.stereoFromMonoControlled-              (fadeProcess-                 (channel_n_1 (arr id))-                 (channel_1_2 (arr id)))-              $< piecewiseConstantVector fade)-           <<<-           listen stereoFreq)-    =<<< arr HL.hHead)-   <<< arr (\freq -> HL.hCons freq HL.hNil)--fenderFM ::-   IO (Real -> Real ->-       PC.T Real ->-       PC.T Real -> PC.T Real -> PC.T Real ->-       PC.T (PC.BendModulation Real) ->-       Instrument Real (Stereo.T Vector))-fenderFM =-   liftA2-      (\osc env dec rel detune index depth fade fm vel freq dur ->-         osc-            (((index, depth), fade), vel, (detune,fm,freq))-            (env dec rel 0 dur))-      (CausalP.runStorableChunky-         (let index = arr (fst.fst.fst3)-              depth = arr (snd.fst.fst3)-              fade  = arr (snd.fst3)-              vel   = arr snd3-              fm    = arr thd3-          in  CausalP.envelopeStereo $>-                 (fenderProc fade index depth vel $*-                  stereoFrequenciesFromDetuneBendModulation 5 fm)))-      pingReleaseEnvelope---tineModulatorBankFM ::-   IO (Real -> Real ->-       PC.T Real ->-       PC.T Real -> PC.T Real -> PC.T Real -> PC.T Real ->-       PC.T (PC.BendModulation Real) ->-       Instrument Real (Stereo.T Vector))-tineModulatorBankFM =-   liftA2-      (\osc env-            dec rel detune-            depth1 depth2 depth3 depth4-            fm vel freq dur ->-         osc-            ((depth1,(depth2,(depth3,(depth4,())))), vel, (detune,fm,freq))-            (env dec rel 0 dur))-      (CausalP.runStorableChunky-         (let depth1 = arr (fst.fst3)-              depth2 = arr (fst.snd.fst3)-              depth3 = arr (fst.snd.snd.fst3)-              depth4 = arr (fst.snd.snd.snd.fst3)-              vel = arr snd3-              fm  = arr thd3-              mix x y = CausalP.mixStereo <<< x&&&y-              modulator n depth =-                 (CausalP.envelopeStereo-                    $< SigP.envelope-                          (piecewiseConstantVector depth)-                          (SigPS.exponential2 (1*sampleRate) (vel+1)))-                 <<<-                 CausalP.stereoFromMono-                    (CausalPS.osciSimple WaveL.approxSine2-                       $< (SigPS.constant $# (zero::Real)))-                 <<<-                 CausalP.amplifyStereo n-          in  CausalP.envelopeStereo $>-                 (CausalP.stereoFromMono-                     (CausalPS.osciSimple WaveL.approxSine2)-                  <<<-                  Stereo.interleave-                  ^<<-                  (modulator 1 depth1 `mix`-                   modulator 2 depth2 `mix`-                   modulator 3 depth3 `mix`-                   modulator 4 depth4)-                      &&& arr id-                  $*-                  stereoFrequenciesFromDetuneBendModulation 5 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 ->-       PC.T (PC.BendModulation Real) ->-       Instrument Real (Stereo.T Vector))-tineBankFM =-   liftA2-      (\osc env-            dec rel detune-            depth1 depth2 depth3 depth4-            partial1 partial2 partial3 partial4-            fm vel freq dur ->-         osc-            ((depth1,(depth2,(depth3,(depth4,())))),-             (partial1,(partial2,(partial3,(partial4,())))),-             (vel, (detune,fm,freq)))-            (env dec rel 0 dur))-      (CausalP.runStorableChunky-         (let depth1 = arr (fst.fst3)-              depth2 = arr (fst.snd.fst3)-              depth3 = arr (fst.snd.snd.fst3)-              depth4 = arr (fst.snd.snd.snd.fst3)-              partial1 = arr (fst.snd3)-              partial2 = arr (fst.snd.snd3)-              partial3 = arr (fst.snd.snd.snd3)-              partial4 = arr (fst.snd.snd.snd.snd3)-              vel = arr (fst.thd3)-              fm  = arr (snd.thd3)-              mixStereo x y = CausalP.mixStereo <<< x&&&y-              modulator n depth =-                 (CausalP.envelopeStereo-                    $< SigP.envelope-                          (piecewiseConstantVector depth)-                          (SigPS.exponential2 (1*sampleRate) (vel+1)))-                 <<<-                 CausalP.stereoFromMono-                    (CausalPS.osciSimple WaveL.approxSine2-                       $< (SigPS.constant $# (zero::Real)))-                 <<<-                 CausalP.amplifyStereo n-              partial ::-                 LLVM.Value Vector -> Int32 -> LLVM.Value Vector ->-                 LLVM.CodeGenFunction r (LLVM.Value Vector)-              partial amp n t =-                 A.mul amp =<<-                 WaveL.partial WaveL.approxSine2 (LLVM.valueOf n) t-          in  CausalP.envelopeStereo $>-                 (CausalP.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)-                        $<-                           (SigP.zip (piecewiseConstantVector partial1) $-                            SigP.zip (piecewiseConstantVector partial2) $-                            SigP.zip (piecewiseConstantVector partial3)-                                     (piecewiseConstantVector partial4)))-                  <<<-                  Stereo.interleave-                  ^<<-                  (modulator 1 depth1 `mixStereo`-                   modulator 2 depth2 `mixStereo`-                   modulator 3 depth3 `mixStereo`-                   modulator 4 depth4)-                      &&& arr id-                  $*-                  stereoFrequenciesFromDetuneBendModulation 5 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 ::-   Param.T p (PC.T Real) ->-   Param.T p (PC.T Real) ->-   Param.T p (PC.T Real) ->-   Param.T p Real ->-   CausalP.T p-      (Stereo.T (LLVM.Value Vector))-      (Stereo.T (LLVM.Value Vector))-resonantFMSynthProc reson index depth vel =-   ((\stereoFreq ->-       let chan freq =-              CausalPS.osciSimple WaveL.approxSine2-              <<<-              ((CausalP.envelope-                  $< SigP.envelope-                        (piecewiseConstantVector depth)-                        (SigPS.exponential2 (1*sampleRate) (vel+1)))-               <<<-               UniFilter.lowpass-               ^<<-               CtrlPS.process-               <<<-               (CausalP.zipWithSimple UniFilterL.parameter-                   <<<-                   CausalP.feedFst (piecewiseConstant reson)-                   <<<-                   (CausalP.envelope $< piecewiseConstant index)-                   <<<-                   CausalP.mapSimple Sample.subsampleVector-                   <<<-                   freq)-               &&&-               ((CausalPS.osciSimple WaveL.saw-                   $< (SigPS.constant $# (zero::Real)))-                <<<-                freq))-              &&&-              freq-       in  CausalP.stereoFromMono (chan (arr id))-           <<<-           listen stereoFreq)-    =<<< arr HL.hHead)-   <<< arr (\freq -> HL.hCons freq HL.hNil)--resonantFMSynth ::-   IO (Real -> Real ->-       PC.T Real ->-       PC.T Real -> PC.T Real -> PC.T Real ->-       PC.T (PC.BendModulation Real) ->-       Instrument Real (Stereo.T Vector))-resonantFMSynth =-   liftA2-      (\osc env dec rel detune reson index depth fm vel freq dur ->-         osc-            ((reson, index, depth), vel, (detune,fm,freq))-            (env dec rel 0 dur))-      (CausalP.runStorableChunky-         (let reson = arr (fst3.fst3)-              index = arr (snd3.fst3)-              depth = arr (thd3.fst3)-              vel   = arr snd3-              fm    = arr thd3-          in  CausalP.envelopeStereo $>-                 (resonantFMSynthProc reson index depth vel $*-                  stereoFrequenciesFromDetuneBendModulation 5 fm)))-      pingReleaseEnvelope---piecewiseConstantVector ::-   Param.T p (PC.T Real) -> SigP.T p (LLVM.Value Vector)-{--   (Storable a,-    LLVM.MakeValueTuple a al,-    Rep.Memory al am,-    LLVM.IsSized am as) =>-   Param.T p (PC.T a) -> SigP.T p (LLVM.Vector n al)--}-piecewiseConstantVector pc =-   SigP.mapSimple SoV.replicate $-   piecewiseConstant pc---softStringDetuneFM ::-   IO (Real ->-       PC.T Real ->-       PC.T (PC.BendModulation Real) ->-       Instrument Real (Stereo.T Vector))-softStringDetuneFM =-   liftA2-      (\osc env att det fm vel freq dur ->-         osc (det, (fm,freq)) (env att vel dur))-      (let det = arr fst-           fm  = arr snd-           mix x y = CausalP.mix <<< x&&&y-           osci ::-              Param.T (det,fm) Real ->-              CausalP.T (det,fm)-                 (LLVM.Value Vector, LLVM.Value Vector)-                 (LLVM.Value Vector)-           osci d =-              (CausalPS.osciSimple WaveL.saw $<-                  (SigPS.constant $# (zero::Real)))-              <<<-              CausalP.envelope-              <<<-              first (CausalPS.raise 1 <<< CausalPS.amplify d)-       in  CausalP.runStorableChunky $-           (CausalP.envelopeStereo $>-              (CausalPS.amplifyStereo 0.25-               <<<-               CausalP.zipWithSimple Sample.zipStereo-               <<<-               ((osci 1.0 `mix` osci (-0.4)) `mix`-                (osci 0.5 `mix` osci (-0.7))) &&&-               ((osci 0.4 `mix` osci (-1.0)) `mix`-                (osci 0.7 `mix` osci (-0.5)))-               <<<-               CausalP.feedFst (piecewiseConstantVector det)-               $* frequencyFromBendModulation 5 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 (PC.BendModulation 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.-    LLVM.Value Vector ->-    LLVM.CodeGenFunction r (LLVM.Value Vector)) ->-   IO (Real ->-       PC.T Real ->-       PC.T Real ->-       PC.T (PC.BendModulation Real) ->-       Instrument Real (Stereo.T Vector))-arcStringStereoFM wave =-   softStringShapeCore-      (\k p ->-         LM.liftR2 Sample.amplifyMono-            (WaveL.approxSine4 =<< WaveL.halfEnvelope p)-            (wave =<< WaveL.replicate k p))--softStringShapeCore ::-   (forall r.-    LLVM.Value Vector ->-    LLVM.Value Vector ->-    LLVM.CodeGenFunction r (LLVM.Value Vector)) ->-   IO (Real ->-       PC.T Real ->-       PC.T Real ->-       PC.T (PC.BendModulation Real) ->-       Instrument Real (Stereo.T Vector))-softStringShapeCore wave =-   liftA2-      (\osc env att det dist fm vel freq dur ->-         osc ((det, dist), (fm,freq)) (env att vel dur))-      (let det  = arr (fst.fst)-           dist = arr (snd.fst)-           fm   = arr snd-           mix x y = CausalP.mix <<< x&&&y-           osci ::-              Param.T (mod,fm) Real ->-              CausalP.T (mod,fm)-                 (LLVM.Value Vector,-                       {- wave shape parameter -}-                  (LLVM.Value Vector, LLVM.Value Vector)-                       {- detune, frequency modulation -})-                 (LLVM.Value Vector)-           osci d =-              CausalPS.shapeModOsci wave-              <<<-              second-                 (CausalP.feedFst (SigPS.constant $# (zero::Real))-                  <<<-                  CausalP.envelope-                  <<<-                  first (CausalPS.raise 1 <<< CausalPS.amplify d))-       in  CausalP.runStorableChunky $-           (CausalP.envelopeStereo $>-              (CausalPS.amplifyStereo 0.25-               <<<-               CausalP.zipWithSimple Sample.zipStereo-               <<<-               ((osci 1.0 `mix` osci (-0.4)) `mix`-                (osci 0.5 `mix` osci (-0.7))) &&&-               ((osci 0.4 `mix` osci (-1.0)) `mix`-                (osci 0.7 `mix` osci (-0.5)))-               $< piecewiseConstantVector dist-               $< piecewiseConstantVector det-               $* frequencyFromBendModulation 5 fm)))-      softStringReleaseEnvelope--fmStringStereoFM ::-   IO (Real ->-       PC.T Real ->-       PC.T Real ->-       PC.T Real ->-       PC.T (PC.BendModulation Real) ->-       Instrument Real (Stereo.T Vector))-fmStringStereoFM =-   liftA2-      (\osc env att det depth dist fm vel freq dur ->-         osc ((det, depth, dist), (fm, freq)) (env att vel dur))-      (let det   = arr (fst3.fst)-           depth = arr (snd3.fst)-           dist  = arr (thd3.fst)-           fm  = arr snd-           mix x y = CausalP.mix <<< x&&&y-           osci ::-              Param.T (mod,fm) Real ->-              CausalP.T (mod,fm)-                 ((LLVM.Value Vector, LLVM.Value Vector)-                       {- phase modulation depth, modulator distortion -},-                  (LLVM.Value Vector, LLVM.Value Vector)-                       {- detune, frequency modulation -})-                 (LLVM.Value Vector)-           osci d =-              CausalPS.osciSimple WaveL.approxSine2-              <<<-              (CausalP.envelope-               <<<-               second-                  (CausalPS.shapeModOsci WaveL.rationalApproxSine1-                     <<< second (CausalP.feedFst (SigPS.constant 0)))-               <<^-               (\((dp, ds), f) -> (dp, (ds, f))))-               &&& arr snd-              <<<-              second-                 (CausalP.envelope <<<-                  first (CausalPS.raise 1 <<< CausalPS.amplify d))-       in  CausalP.runStorableChunky-              (CausalP.envelopeStereo <<<-                 (arr id &&&-                  (CausalPS.amplifyStereo 0.25-                   <<<-                   CausalP.zipWithSimple Sample.zipStereo-                   <<<-                   ((osci 1.0 `mix` osci (-0.4)) `mix`-                    (osci 0.5 `mix` osci (-0.7))) &&&-                   ((osci 0.4 `mix` osci (-1.0)) `mix`-                    (osci 0.7 `mix` osci (-0.5)))-                   <<<-                   CausalP.feedSnd-                      (SigP.zip-                         (piecewiseConstantVector det)-                         (frequencyFromBendModulation 5 fm))-                   <<<-                   CausalP.feedSnd (piecewiseConstantVector dist)-                   <<<-                   (CausalP.envelope-                       $< piecewiseConstantVector depth)))))-      softStringReleaseEnvelope---wind ::-   IO (Real ->-       PC.T Real ->-       PC.T (PC.BendModulation Real) ->-       Instrument Real (Stereo.T Vector))-wind =-   liftA2-      (\osc env att reson fm vel freq dur ->-         osc (reson, (fm,freq)) (env att vel dur))-      (let reson = arr fst-           fm = arr snd-       in  CausalP.runStorableChunky $-           (CausalP.envelopeStereo $>-              (CausalP.stereoFromMonoControlled CtrlPS.process-                $< SigP.zipWithSimple-                      (MoogL.parameter TypeNum.d8)-                      (piecewiseConstant reson)-                      (SigP.mapSimple Sample.subsampleVector-                         (frequencyFromBendModulation 0.2 fm))-                $* SigP.zipWithSimple Sample.zipStereo-                      (SigPS.noise 13 (sampleRate/20000))-                      (SigPS.noise 14 (sampleRate/20000)-                          :: SigP.T p (LLVM.Value Vector)))))-      softStringReleaseEnvelope---fadeProcess ::-   (Num b, LLVM.IsConst b,-    LLVM.IsArithmetic v, SoV.Replicate b v) =>-   CausalP.T p a (LLVM.Value v) ->-   CausalP.T p a (LLVM.Value v) ->-   CausalP.T p (LLVM.Value v, a) (LLVM.Value v)-fadeProcess proc0 proc1 =-   CausalP.mapSimple-      (\(k,(a0,a1)) -> do-         b0 <- A.mul a0 =<< A.sub (SoV.replicateOf 1) k-         b1 <- A.mul a1 k-         A.add b0 b1)-   <<<-   second (proc0 &&& proc1)--windPhaser ::-   IO (Real ->-       PC.T Real ->-       PC.T Real ->-       PC.T Real ->-       PC.T (PC.BendModulation Real) ->-       Instrument Real (Stereo.T Vector))-windPhaser =-   liftA2-      (\osc env att phaserMix phaserFreq reson fm vel freq dur ->-         osc ((phaserMix,phaserFreq), reson, (fm,freq)) (env att vel dur))-      (let phaserMix = arr (fst.fst3)-           phaserFreq = arr (snd.fst3)-           reson = arr snd3-           fm = arr thd3-       in  CausalP.runStorableChunky $-           (CausalP.envelopeStereo $>-              ((CausalP.stereoFromMonoControlled-                   (fadeProcess (arr snd) CtrlPS.process-                    <<<-                    first (CausalP.mapSimple SoV.replicate)-                    <<^-                    (\((k,p),x) -> (k,(p,x))))-                  $< SigP.zip-                        (piecewiseConstant phaserMix)-                        (piecewiseConstant-                           (fmap-                               (Allpass.flangerParameterPlain TypeNum.d8 .-                                (/sampleRate))-                               ^<< phaserFreq)))-               <<<-               CausalP.stereoFromMonoControlled CtrlPS.process-                 $< SigP.zipWithSimple-                       (MoogL.parameter TypeNum.d8)-                       (piecewiseConstant reson)-                       (SigP.mapSimple Sample.subsampleVector-                          (frequencyFromBendModulation 0.2 fm))-                 $* SigP.zipWithSimple Sample.zipStereo-                       (SigPS.noise 13 (sampleRate/20000))-                       (SigPS.noise 14 (sampleRate/20000)-                           :: SigP.T p (LLVM.Value Vector)))))-      softStringReleaseEnvelope---filterSawStereoFM ::-   IO (Real -> Real ->-       PC.T Real ->-       Real -> Real ->-       PC.T (PC.BendModulation Real) ->-       Instrument Real (Stereo.T Vector))-filterSawStereoFM =-   liftA2-      (\osc env dec rel detune bright brightDecay fm vel freq dur ->-         osc ((bright, brightDecay), (detune,fm,freq)) (env dec rel vel dur))-      (CausalP.runStorableChunky-         (let bright    = arr (fst.fst)-              brightDec = arr (snd.fst)-              fm = arr snd-          in  CausalP.envelopeStereo $>-              (CausalP.stereoFromMono-                  (UniFilter.lowpass-                   ^<<-                   (CtrlPS.processCtrlRate $# (100::Real))-                      (\k -> SigP.mapSimple-                          (UniFilterL.parameter (LLVM.valueOf 10))-                          {- bound control in order to avoid too low resonant frequency,-                             which makes the filter instable -}-                          (SigP.exponentialBounded2-                              (100/sampleRate)-                              (brightDec*sampleRate/k)-                              (bright/sampleRate)))-                   <<<-                   CausalPS.osciSimple WaveL.saw $< SigPS.constant zero)-               $* stereoFrequenciesFromDetuneBendModulation 10 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 ->-       Real -> Ev.LazyTime -> SigSt.T Vector)-adsr =-   liftA3-      (\attack decay release-           attackTime attackPeak attackHalfLife-           decayHalfLife releaseHalfLife vel dur ->-         let amp = amplitudeFromVelocity vel-             (attackDur, decayDur) =-                CutG.splitAt (round (attackTime*vectorRate)) dur-         in  SigStL.continuePacked-                (attack (chunkSizesFromLazyTime attackDur)-                    (attackHalfLife,-                     attackPeak * amp / (1 - 2^?(-attackTime/attackHalfLife)))-                 `SigSt.append`-                 decay (chunkSizesFromLazyTime decayDur)-                    (decayHalfLife,-                     ((attackPeak-1)*amp, amp)))-                (\x -> release vectorChunkSize (releaseHalfLife,x)))-      (SigP.runChunkyPattern $-       let halfLife  = arr fst-           amplitude = arr snd-       in  SigP.zipWithSimple A.sub-              (SigPS.constant amplitude)-              (SigPS.exponential2 (halfLife*sampleRate) amplitude))-      (SigP.runChunkyPattern $-       let halfLife   = arr fst-           amplitude  = arr (fst.snd)-           saturation = arr (snd.snd)-       in  SigP.mix (SigPS.constant saturation) $-           SigPS.exponential2 (halfLife*sampleRate) amplitude)-      (SigP.runChunky $-       let release   = arr fst-           amplitude = arr snd-       in  (CausalP.take (round ^<< (release*5*vectorRate)) $*-            SigPS.exponential2 (release*sampleRate) amplitude))--brass ::-   IO (Real -> Real ->-       Real -> Real -> Real -> Real ->-       PC.T Real ->-       PC.T Real ->-       PC.T (PC.BendModulation Real) ->-       Instrument Real (Stereo.T Vector))-brass =-   liftA2-      (\osc env attTime attPeak attHL dec rel emph det dist fm vel freq dur ->-         osc-            ((det, dist), (fm,freq),-             env attTime emph attHL dec rel vel dur)-            (env attTime attPeak attHL dec rel vel dur))-      (let det  = arr (fst.fst3)-           dist = arr (snd.fst3)-           fm   = arr snd3-           emph = arr thd3-           mix x y = CausalP.mix <<< x&&&y-           osci ::-              Param.T p Real ->-              CausalP.T p-                 (LLVM.Value Vector,-                       {- wave shrink/replication factor -}-                  (LLVM.Value Vector, LLVM.Value Vector)-                       {- detune, frequency modulation -})-                 (LLVM.Value Vector)-           osci d =-              CausalPS.shapeModOsci WaveL.rationalApproxSine1-              <<<-              second-                 (CausalP.feedFst (SigPS.constant $# (zero::Real))-                  <<<-                  CausalP.envelope-                  <<<-                  first (CausalPS.raise 1 <<< CausalPS.amplify d))-       in  CausalP.runStorableChunky $-           (CausalP.envelopeStereo $>-              (CausalPS.amplifyStereo 0.25-               <<<-               CausalP.zipWithSimple Sample.zipStereo-               <<<-               ((osci 1.0 `mix` osci (-0.4)) `mix`-                (osci 0.5 `mix` osci (-0.7))) &&&-               ((osci 0.4 `mix` osci (-1.0)) `mix`-                (osci 0.7 `mix` osci (-0.5)))-               <<<-               CausalP.feedFst (piecewiseConstantVector dist)-               <<<-               CausalP.feedSnd (frequencyFromBendModulation 5 fm)-               <<<-               (CausalP.envelope $< piecewiseConstantVector det)-               $*-               SigP.fromStorableVectorLazy emph)))-      adsr---data SamplePositions =-   SamplePositions {-      sampleStart, sampleLength,-      sampleLoopStart, sampleLoopLength :: Int-   }--data SampledSound =-   SampledSound {-      sampleData :: SigSt.T Real,-      samplePositions :: SamplePositions,-      samplePeriod :: Real-   }---sampledSound ::-   IO (SampledSound ->-       PC.T (PC.BendModulation Real) ->-       Instrument Real (Stereo.T Vector))-sampledSound =-   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 fmSig =-                freqMod-                   (chunkSizesFromLazyTime (PC.duration fm))-                   (fm, freq*samplePeriod smp) :: SigSt.T Vector-             pos = samplePositions smp-             amp = 2 * amplitudeFromVelocity vel-             (attack,sustain) =-                mapPair-                   (SigSt.drop (sampleStart pos),-                    SigSt.take (sampleLoopLength pos)) $-                SigSt.splitAt (sampleLoopStart pos) $-                sampleData smp-             release =-                SigSt.drop (sampleLoopStart pos + sampleLoopLength pos) $-                SigSt.take (sampleStart     pos + sampleLength     pos) $-                sampleData smp-         in  (\cont -> osc cont-                (amp,-                 attack `SigSt.append`-                 SVL.cycle (SigSt.take (sampleLoopLength pos) sustain),-                 chunkSizesFromLazyTime dur)-                fmSig)-             (osc (const SigSt.empty)-                (amp, release, NonNegChunky.fromChunks (repeat 1000))))-      (CausalP.runStorableChunkyCont-         (let amp = arr fst3-              smp = arr snd3-              dur = arr thd3-          in  CausalPS.amplifyStereo amp-              <<<-              CausalP.stereoFromMono-                 (CausalPS.pack-                    (CausalP.frequencyModulationLinear-                       (SigP.fromStorableVectorLazy smp)))-              <<<-              CausalP.zipWithSimple Sample.zipStereo-              <<<-              CausalPS.amplify 0.999 &&&-              CausalPS.amplify 1.001-              <<<-              arr fst-              <<<-              CausalP.feedSnd (SigP.lazySize dur)))-      (SigP.runChunkyPattern-         (frequencyFromBendModulation 3 (arr id)))---sampledSoundLeaky ::-   IO (SampledSound ->-       PC.T (PC.BendModulation Real) ->-       Instrument Real (Stereo.T Vector))-sampledSoundLeaky =-   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) =-                SVP.splitAt (chunkSizesFromLazyTime dur) $-                (freqMod-                   (chunkSizesFromLazyTime (PC.duration fm))-                   (fm, freq*samplePeriod smp) :: SigSt.T Vector)-             pos = samplePositions smp-             amp = 2 * amplitudeFromVelocity vel-             (attack,sustain) =-                mapPair-                   (SigSt.drop (sampleStart pos),-                    SigSt.take (sampleLoopLength pos)) $-                SigSt.splitAt (sampleLoopStart pos) $-                sampleData smp-             release =-                SigSt.drop (sampleLoopStart pos + sampleLoopLength pos) $-                SigSt.take (sampleStart     pos + sampleLength     pos) $-                sampleData smp-         in  osc-                (amp,-                 attack `SigSt.append`-                 SVL.cycle (SigSt.take (sampleLoopLength pos) sustain))-                sustainFM-             `SigSt.append`-             osc (amp,release) releaseFM)-      (CausalP.runStorableChunky-         (let smp = arr snd-              amp = arr fst-          in  CausalPS.amplifyStereo amp-              <<<-              CausalP.stereoFromMono-                 (CausalPS.pack-                    (CausalP.frequencyModulationLinear-                       (SigP.fromStorableVectorLazy smp)))-              <<<-              CausalP.zipWithSimple Sample.zipStereo-              <<<-              CausalPS.amplify 0.999 &&&-              CausalPS.amplify 1.001))-      (SigP.runChunkyPattern-         (frequencyFromBendModulation 3 (arr id)))---type SampleInfo = (FilePath, [SamplePositions], Real)--makeSampledSounds ::-   SampleInfo ->-   IO [-- PC.T Real ->-       PC.T (PC.BendModulation Real) ->-       Instrument Real (Stereo.T Vector)]-makeSampledSounds (path, positions, period) = do-{--   sound <--      (SoxRead.withHandle1 (SVL.hGetContentsSync chunkSize) =<<-       SoxRead.open SoxOption.none "speech/tomatensalat2.wav")-   play (44100::Real) (sound::SVL.Vector Real)--}-   liftA2-      (\makeSmp smp ->-          map (\pos -> makeSmp (SampledSound smp pos period))-             positions)-      sampledSound-      (SoxRead.withHandle1 (SVL.hGetContentsSync chunkSize) =<<-       SoxRead.open SoxOption.none path)---tomatensalatPositions :: [SamplePositions]-tomatensalatPositions =-   SamplePositions      0 29499  12501 15073 :-   SamplePositions  29499 31672  38163 17312 :-   SamplePositions  67379 28610  81811 10667 :-   SamplePositions  95989 31253 106058 16111 :-   SamplePositions 127242 38596 136689 11514 :-   []--tomatensalat :: SampleInfo-tomatensalat =-   ("speech/tomatensalat2.wav", tomatensalatPositions, 324.5)---halPositions :: [SamplePositions]-halPositions =---   SamplePositions   2371 25957   7362  6321 :-   SamplePositions   2371 25957 (2371+25957) 1 :-   SamplePositions  40546 34460  63540  9546 :-   SamplePositions  79128 32348  94367 14016 :-   SamplePositions 112027 21227 125880  5500 :-   SamplePositions 146057 23235 168941   352 :-   []--hal :: SampleInfo-hal =-   ("speech/haskell-in-leipzig2.wav", halPositions, 316)---graphentheoriePositions :: [SamplePositions]-graphentheoriePositions =-   SamplePositions      0 29524  13267 14768 :-   SamplePositions  29524 35333  47624  9968 :-   SamplePositions  64857 31189  73818 16408 :-   SamplePositions  96046 31312 106206 18504 :-   SamplePositions 127358 32127 132469 16530 :-   []--graphentheorie :: SampleInfo-graphentheorie =-   ("speech/graphentheorie0.wav", graphentheoriePositions, 301.15)+{-+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:+   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+   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.++effects:+   reverb and controllable delay+   phaser or Chebyshev filter++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 Rank2Types #-}+module Synthesizer.LLVM.Server.Packed.Instrument where++import Synthesizer.LLVM.Server.Common++import qualified Synthesizer.LLVM.ALSA.BendModulation as BM+import qualified Synthesizer.PiecewiseConstant.ALSA.MIDI as PC+import qualified Synthesizer.EventList.ALSA.MIDI as Ev++import qualified Sound.Sox.Read          as SoxRead+import qualified Sound.Sox.Option.Format as SoxOption+import System.FilePath ((</>), )+import Control.Exception (bracket, )++import Synthesizer.Storable.ALSA.MIDI (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.ALSA.MIDI as MIDIL+import qualified Synthesizer.LLVM.CausalParameterized.ControlledPacked as CtrlPS+import qualified Synthesizer.LLVM.CausalParameterized.ProcessPacked as CausalPS+import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP+import qualified Synthesizer.LLVM.Parameterized.SignalPacked as SigPS+import qualified Synthesizer.LLVM.Parameterized.Signal as SigP+import qualified Synthesizer.LLVM.Parameter as Param+import qualified Synthesizer.LLVM.Storable.Signal as SigStL+import qualified Synthesizer.LLVM.Frame as Frame+import qualified Synthesizer.LLVM.SerialVector as Serial+import qualified Synthesizer.LLVM.Wave as WaveL+import Synthesizer.LLVM.CausalParameterized.Process (($<), ($>), ($*), )+import Synthesizer.LLVM.Parameterized.Signal (($#), )++import qualified LLVM.Extra.ScalarOrVector as SoV+import qualified LLVM.Extra.Monad as LM+import qualified LLVM.Extra.Arithmetic as A+import qualified LLVM.Core as LLVM+import qualified Data.TypeLevel.Num as TypeNum++import Control.Arrow.Monad ((=<<<), listen, )+import qualified Data.HList as HL++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 Control.Arrow ((<<<), (^<<), (<<^), (&&&), (***), arr, first, second, )+import Control.Category (id, )+import Control.Applicative (liftA2, liftA3, )+import Data.Traversable (traverse, )++import qualified Data.List.Match as Match+import Data.Tuple.HT (mapPair, fst3, snd3, thd3, )++import Data.Int (Int32, )++{-+import qualified Numeric.NonNegative.Class   as NonNeg+import qualified Numeric.NonNegative.Wrapper as NonNegW+-}+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, (+), (-), (*), )++++sumNested :: (Additive.C a) => [a] -> a+sumNested [] = Additive.zero+sumNested xs@(_:rs) =+   let ys = xs ++ Match.take rs (sum2 ys)+   in  last ys++sum2 :: (Additive.C a) => [a] -> [a]+sum2 (x:y:rest) = (x+y) : sum2 rest+sum2 xs = xs+++type Param p = Param.T (SampleRate Real, p)+type SigP p = SigP.T (SampleRate Real, p)+type CausalP p = CausalP.T (SampleRate Real, p)+++type Vector = LLVM.Vector VectorSize Real+type VectorSize = TypeNum.D4+++vectorSize :: Int+vectorSize = TypeNum.toInt (undefined :: VectorSize)++vectorRate :: Fractional a => SampleRate a -> a+vectorRate (SampleRate sampleRate) =+   sampleRate / fromIntegral vectorSize+++vectorTime :: (p -> Real) -> Param p Real+vectorTime param =+   arr (\(SampleRate sampleRate, p) ->+          param p * sampleRate / fromIntegral vectorSize)++noiseReference :: Real -> Param p Real+noiseReference freq =+   arr (\(SampleRate sampleRate, _p) -> sampleRate/freq)++frequencyControl :: (p -> PC.T Real) -> Param p (PC.T Real)+frequencyControl param =+   arr (\(SampleRate sampleRate, p) -> fmap (/sampleRate) $ param p)++modulation ::+   (p -> (PC.T (BM.T Real), Real)) -> Param p (PC.T (BM.T Real))+modulation param =+   arr (\(sr, p) ->+      (\(fm,freq) -> transposeModulation sr freq fm) $ param p)++detuneModulation ::+   (p -> (PC.T Real, PC.T (BM.T Real), Real)) ->+   Param p (PC.T Real, PC.T (BM.T Real))+detuneModulation param =+   arr $ \(sr, p) ->+      case param p of+         (det,fm,freq) -> (det, transposeModulation sr freq fm)+++frequencyFromBendModulation ::+{-+   (Storable a,+    Class.MakeValueTuple a (Value a)) =>+-}+   Param p Real ->+   Param p (PC.T (BM.T Real)) ->+   SigP p (LLVM.Value Vector)+frequencyFromBendModulation speed fmFreq =+   MIDIL.frequencyFromBendModulationPacked speed+      $* piecewiseConstant fmFreq++stereoFrequenciesFromDetuneBendModulation ::+   Param p Real ->+   Param p (PC.T Real, PC.T (BM.T Real)) ->+   SigP p (Stereo.T (LLVM.Value Vector))+stereoFrequenciesFromDetuneBendModulation speed detFmFreq =+   (CausalP.envelopeStereo+      $< frequencyFromBendModulation speed+           (fmap (\(_det,fm) -> (fm)) detFmFreq))+   <<<+   liftA2 Stereo.cons (one + id) (one - id)+   $* piecewiseConstantVector+         (fmap (\(det,_fm) -> det) detFmFreq)++piecewiseConstantVector ::+   Param.T p (PC.T Real) -> SigP.T p (LLVM.Value Vector)+{-+   (Storable a,+    Class.MakeValueTuple a al,+    Memory.C al am,+    LLVM.IsSized am as) =>+   Param.T p (PC.T a) -> SigP.T p (LLVM.Vector n al)+-}+piecewiseConstantVector =+   piecewiseConstant . fmap (fmap (Serial.replicate))+++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+            (pressed (chunkSizesFromLazyTime dur) (sr, (decay,vel)))+            (\x -> release vcsize (sr, (rel,x))))+      (SigP.runChunkyPattern $+       let decay = time fst+           velocity = number snd+       in  SigPS.exponential2 decay+              (amplitudeFromVelocity ^<< velocity))+      (SigP.runChunky $+       let releaseTime = vectorTime fst * 5+           releaseHL = time fst+           amplitude = number snd+       in  CausalP.take (round ^<< 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 ->+         osc (sr,freq) (env dec rel vcsize sr vel dur))+      (CausalP.runStorableChunky+         (let freq = frequency id+          in  CausalP.envelope $>+              SigPS.osciSimple 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 ->+         osc (sr,freq) (env dec rel vcsize sr vel dur))+      (CausalP.runStorableChunky+         (let freq = frequency id+          in  CausalP.envelopeStereo $>+              liftA2 Stereo.cons+                 (SigPS.osciSimple WaveL.saw zero (0.999*freq))+                 (SigPS.osciSimple 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 ->+         osc+            (sr, ((phase, phaseDecay), shape, (detune,fm,freq)))+            (env dec rel vcsize sr vel dur))+      (CausalP.runStorableChunky+         (let phase = number (fst.fst3)+              decay = time   (snd.fst3)+              shape = control snd3+              fm  = detuneModulation thd3+          in  CausalP.envelopeStereo $>+              ((CausalP.stereoFromMonoControlled+                  (CausalPS.shapeModOsci WaveL.rationalApproxSine1)+                    $< piecewiseConstantVector shape)+                  <<^ Stereo.interleave+                $< (liftA2 Stereo.cons id (Additive.negate id)+                     $* SigPS.exponential2 decay phase)+                $* stereoFrequenciesFromDetuneBendModulation (frequencyConst 10) 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 ->+         osc+            (sr, ((phase, shape), (detune,fm,freq)))+            (env dec rel vcsize sr vel dur))+      (CausalP.runStorableChunky+         (let phs = control (fst.fst)+              shp = control (snd.fst)+              fm  = detuneModulation snd+              chanOsci =+                 ((CausalPS.shapeModOsci WaveL.rationalApproxSine1+                   <<<+                   second (first (Additive.negate id)))+                  -+                   CausalPS.shapeModOsci WaveL.rationalApproxSine1)+                 <<^+                 (\((p,s),f) -> (s,(p,f)))+          in  CausalP.envelopeStereo $>+              ((CausalP.stereoFromMonoControlled chanOsci+                   $< SigP.zip+                         (piecewiseConstantVector phs)+                         (piecewiseConstantVector shp))+                $* stereoFrequenciesFromDetuneBendModulation (frequencyConst 10) fm)))+      pingReleaseEnvelope++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 ->+         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))+      (CausalP.runStorableChunky+         (let fm   = detuneModulation fst3+              vel  = number snd3+              env4 = signal (fst.thd3)+              env7 = signal (snd.thd3)+              osci sel v d =+                 CausalP.envelopeStereo+                 <<<+                 (arr sel ***+                    (CausalPS.amplifyStereo v+                     <<<+                     CausalP.stereoFromMono+                        (CausalPS.osciSimple WaveL.approxSine4 $< zero)+                     <<<+                     CausalPS.amplifyStereo d))+          in  sumNested+                 [osci fst3  0.6              1,+                  osci snd3 (0.02 *  50^?vel) 4,+                  osci thd3 (0.02 * 100^?vel) 7]+              <<<+              CausalP.feedSnd (stereoFrequenciesFromDetuneBendModulation (frequencyConst 5) 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.+                  -}+                  SigP.zip+                     (SigP.fromStorableVectorLazy env4)+                     (SigP.fromStorableVectorLazy 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 ->+         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))+      (CausalP.runStorableChunky+         (let fm   = modulation fst3+              noiseAmp   = control (fst.snd3)+              noiseReson = control (snd.snd3)+              vel  = number (fst3.thd3)+              env4 = signal (snd3.thd3)+              env7 = signal (thd3.thd3)+              osci sel v d =+                 CausalP.envelope+                 <<<+                 (arr sel ***+                    (CausalPS.amplify v+                     <<<+                     (CausalPS.osciSimple WaveL.approxSine4 $< zero)+                     <<<+                     CausalPS.amplify d))+              noise sel d =+                 (CausalP.envelope $<+                    piecewiseConstantVector noiseAmp)+                 <<<+                 CausalP.envelope+                 <<<+                 (arr sel ***+                    ({- UniFilter.lowpass+                        ^<< -}+                     (CtrlPS.process+                        $> SigPS.noise 12 (noiseReference 20000))+                     <<<+{-+                     (CausalP.quantizeLift+                        $# (128 / fromIntegral vectorSize :: Real))+                           (CausalP.zipWithSimple UniFilterL.parameter)+-}+                     (CausalP.quantizeLift+                        $# (128 / fromIntegral vectorSize :: Real))+                           (CausalP.zipWithSimple (MoogL.parameter TypeNum.d8))+                     <<<+                     CausalP.feedFst (piecewiseConstant noiseReson)+                     <<<+                     CausalP.mapSimple Frame.subsampleVector+                     <<<+                     CausalPS.amplify d))+          in  liftA2 Stereo.cons+                 (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])+              <<<+              CausalP.feedSnd (frequencyFromBendModulation (frequencyConst 5) 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.+                  -}+                  SigP.zip+                     (SigP.fromStorableVectorLazy env4)+                     (SigP.fromStorableVectorLazy env7)))+      pingReleaseEnvelope+++tine :: IO (Real -> Real -> SigSt.ChunkSize -> Instrument Real Vector)+tine =+   liftA2+      (\osc env dec rel vcsize sr vel freq dur ->+         osc (sr, (vel,freq)) (env dec rel vcsize sr 0 dur))+      (CausalP.runStorableChunky+         (let freq = frequency snd+              vel  = number fst+          in  CausalP.envelope $>+                 (CausalPS.osciSimple WaveL.approxSine2+                    $> SigPS.constant freq+                    $* (CausalP.envelope+                          $< SigPS.exponential2 (timeConst 1) (vel+1)+                          $* SigPS.osciSimple 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 ->+         osc (sr, (vel,freq)) (env dec rel vcsize sr 0 dur))+      (CausalP.runStorableChunky+         (let freq = frequency snd+              vel  = number fst+              chanOsci d =+                 CausalPS.osciSimple WaveL.approxSine2+                    $> SigPS.constant (freq*d)+          in  CausalP.envelopeStereo $>+                 (liftA2 Stereo.cons+                    (chanOsci 0.995) (chanOsci 1.005)+                  $* SigP.envelope+                        (SigPS.exponential2 (timeConst 1) (vel+1))+                        (SigPS.osciSimple 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 =+                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 attackTimeVector $+                env (chunkSizesFromLazyTime dur)+                    (sr, (amplitudeFromVelocity vel, attackTimeVector))+             release = rev attack+         in  attack `SigSt.append` sustain `SigSt.append` release)+      SigStL.makeReversePacked+      (let amp = number fst+           attackTimeVector = parameter snd+       in  SigP.runChunkyPattern $+           flip SigP.append (SigPS.constant amp) $+           (CausalPS.amplify amp <<<+            CausalP.take attackTimeVector+            $* SigPS.parabolaFadeInInf+                  (fmap (fromIntegral . (vectorSize*)) attackTimeVector)))++softString :: IO (Instrument Real (Stereo.T Vector))+softString =+   liftA2+      (\osc env sr vel freq dur ->+         osc (sr, freq) (env 1 sr vel dur))+      (let freq = frequency id+           osci d =+              SigPS.osciSimple WaveL.saw zero (d * freq)+       in  CausalP.runStorableChunky $+           (CausalP.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 ->+         osc (sr, (fm,freq)) (env 1 sr vel dur))+      (let fm = modulation id+           osci ::+              Param.T fm Real ->+              CausalP.T fm (LLVM.Value Vector) (LLVM.Value Vector)+           osci d =+              (CausalPS.osciSimple WaveL.saw $< zero) <<<+              CausalPS.amplify d+       in  CausalP.runStorableChunky $+           (CausalP.envelopeStereo $>+              (liftA2 Stereo.cons+                  (osci 1.005 + osci 0.998)+                  (osci 1.002 + osci 0.995)+               $* frequencyFromBendModulation (frequencyConst 5) 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 ->+         osc (sr, (vel,(fm,freq))) (env dec rel vcsize sr 0 dur))+      (CausalP.runStorableChunky+         (let vel  = number fst+              fm   = modulation snd+              chanOsci d =+                 CausalPS.osciSimple WaveL.approxSine2+                    <<< second (CausalPS.amplify d)+          in  CausalP.envelopeStereo $>+                 (liftA2 Stereo.cons+                     (chanOsci 0.995) (chanOsci 1.005)+                  <<<+                  (((CausalP.envelope+                       $< SigPS.exponential2 (timeConst 1) (vel+1))+                     <<< (CausalPS.osciSimple WaveL.approxSine2 $< zero)+                     <<< CausalPS.amplify 2)+                   &&& id)+                  $* frequencyFromBendModulation (frequencyConst 5) fm)))+      pingReleaseEnvelope+++tineControlledProc, tineControlledFnProc ::+   Param p (PC.T Real) ->+   Param p (PC.T Real) ->+   Param p Real ->+   CausalP p+      (Stereo.T (LLVM.Value Vector))+      (Stereo.T (LLVM.Value Vector))+tineControlledProc index depth vel =+   CausalP.stereoFromMono+      (CausalPS.osciSimple WaveL.approxSine2)+   <<<+   Stereo.interleave+   ^<<+   ((CausalP.envelopeStereo+       $< SigP.envelope+             (piecewiseConstantVector depth)+             (SigPS.exponential2 (timeConst 1) (vel+1)))+    <<<+    CausalP.stereoFromMono+       (CausalPS.osciSimple WaveL.approxSine2 $< zero)+    <<<+    (CausalP.envelopeStereo+       $< piecewiseConstantVector index))+            &&& id++tineControlledFnProc index depth vel =+   ((\freq ->+        CausalP.stereoFromMono+           (CausalPS.osciSimple WaveL.approxSine2)+        <<<+        Stereo.interleave+        ^<<+         ((CausalP.envelopeStereo+             $< SigP.envelope+                   (piecewiseConstantVector depth)+                   (SigPS.exponential2 (timeConst 1) (vel+1)))+          <<<+          CausalP.stereoFromMono+             (CausalPS.osciSimple WaveL.approxSine2 $< zero)+          <<<+          (CausalP.envelopeStereo+             $< piecewiseConstantVector index)+          <<<+          listen freq)+         &&&+         listen freq)+--    =<<< listen HL.hNil+    =<<< arr HL.hHead)+   <<< arr (\freq -> HL.hCons freq HL.hNil)++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 ->+         osc+            (sr, ((index, depth), vel, (detune,fm,freq)))+            (env dec rel vcsize sr 0 dur))+      (CausalP.runStorableChunky+         (let index = control (fst.fst3)+              depth = control (snd.fst3)+              vel   = number snd3+              fm    = detuneModulation thd3+          in  CausalP.envelopeStereo $>+                 (tineControlledFnProc index depth vel $*+                  stereoFrequenciesFromDetuneBendModulation (frequencyConst 5) fm)))+      pingReleaseEnvelope+++fenderProc ::+   Param p (PC.T Real) ->+   Param p (PC.T Real) ->+   Param p (PC.T Real) ->+   Param p Real ->+   CausalP p+      (Stereo.T (LLVM.Value Vector))+      (Stereo.T (LLVM.Value Vector))+fenderProc fade index depth vel =+   ((\stereoFreq ->+       let channel_n_1 freq =+              CausalPS.osciSimple WaveL.approxSine2+              <<<+              ((CausalP.envelope+                  $< SigP.envelope+                        (piecewiseConstantVector depth)+                        (SigPS.exponential2 (timeConst 1) (vel+1)))+               <<<+               (CausalPS.osciSimple WaveL.approxSine2 $< zero)+               <<<+               (CausalP.envelope+                  $< piecewiseConstantVector index)+               <<<+               freq)+              &&&+              freq+           channel_1_2 freq =+              CausalPS.osciSimple WaveL.approxSine2+              <<<+              ((CausalP.envelope+                  $< SigP.envelope+                        (piecewiseConstantVector depth)+                        (SigPS.exponential2 (timeConst 1) (vel+1)))+               <<<+               (CausalPS.osciSimple WaveL.approxSine2 $< zero)+               <<<+               freq)+              &&&+              (CausalPS.amplify 2 <<< freq)+       in  (CausalP.stereoFromMonoControlled+              (fadeProcess+                 (channel_n_1 id)+                 (channel_1_2 id))+              $< piecewiseConstantVector fade)+           <<<+           listen stereoFreq)+    =<<< arr HL.hHead)+   <<< arr (\freq -> HL.hCons freq HL.hNil)++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 ->+         osc+            (sr, (((index, depth), fade), vel, (detune,fm,freq)))+            (env dec rel vcsize sr 0 dur))+      (CausalP.runStorableChunky+         (let index = control (fst.fst.fst3)+              depth = control (snd.fst.fst3)+              fade  = control (snd.fst3)+              vel   = number snd3+              fm    = detuneModulation thd3+          in  CausalP.envelopeStereo $>+                 (fenderProc fade index depth vel $*+                  stereoFrequenciesFromDetuneBendModulation (frequencyConst 5) fm)))+      pingReleaseEnvelope+++fmModulator ::+   Param p Real ->+   Param p Real ->+   Param p (PC.T Real) ->+   CausalP p+      (Stereo.T (LLVM.Value Vector))+      (Stereo.T (LLVM.Value Vector))+fmModulator vel n depth =+   (CausalP.envelopeStereo+      $< SigP.envelope+            (piecewiseConstantVector depth)+            (SigPS.exponential2 (timeConst 1) (vel+1)))+   <<<+   CausalP.stereoFromMono+      (CausalPS.osciSimple 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 ->+         osc+            (sr, ((depth1,(depth2,(depth3,(depth4,())))), vel, (detune,fm,freq)))+            (env dec rel vcsize sr 0 dur))+      (CausalP.runStorableChunky+         (let depth1 = control (fst.fst3)+              depth2 = control (fst.snd.fst3)+              depth3 = control (fst.snd.snd.fst3)+              depth4 = control (fst.snd.snd.snd.fst3)+              vel = number snd3+              fm  = detuneModulation thd3+          in  CausalP.envelopeStereo $>+                 (CausalP.stereoFromMono+                     (CausalPS.osciSimple WaveL.approxSine2)+                  <<<+                  Stereo.interleave+                  ^<<+                  sumNested+                     [fmModulator vel 1 depth1,+                      fmModulator vel 2 depth2,+                      fmModulator vel 3 depth3,+                      fmModulator vel 4 depth4]+                    &&& id+                  $*+                  stereoFrequenciesFromDetuneBendModulation (frequencyConst 5) 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 ->+         osc+            (sr,+             ((depth1,(depth2,(depth3,(depth4,())))),+              (partial1,(partial2,(partial3,(partial4,())))),+              (vel, (detune,fm,freq))))+            (env dec rel vcsize sr 0 dur))+      (CausalP.runStorableChunky+         (let depth1 = control (fst.fst3)+              depth2 = control (fst.snd.fst3)+              depth3 = control (fst.snd.snd.fst3)+              depth4 = control (fst.snd.snd.snd.fst3)+              partial1 = control (fst.snd3)+              partial2 = control (fst.snd.snd3)+              partial3 = control (fst.snd.snd.snd3)+              partial4 = control (fst.snd.snd.snd.snd3)+              vel = number (fst.thd3)+              fm  = detuneModulation (snd.thd3)+              partial ::+                 LLVM.Value Vector -> Int32 -> LLVM.Value Vector ->+                 LLVM.CodeGenFunction r (LLVM.Value Vector)+              partial amp n t =+                 A.mul amp =<<+                 WaveL.partial WaveL.approxSine2 (LLVM.valueOf n) t+          in  CausalP.envelopeStereo $>+                 (CausalP.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)+                        $<+                           (SigP.zip (piecewiseConstantVector partial1) $+                            SigP.zip (piecewiseConstantVector partial2) $+                            SigP.zip (piecewiseConstantVector partial3)+                                     (piecewiseConstantVector partial4)))+                  <<<+                  Stereo.interleave+                  ^<<+                  sumNested+                     [fmModulator vel 1 depth1,+                      fmModulator vel 2 depth2,+                      fmModulator vel 3 depth3,+                      fmModulator vel 4 depth4]+                    &&& id+                  $*+                  stereoFrequenciesFromDetuneBendModulation (frequencyConst 5) 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 ::+   Param p (PC.T Real) ->+   Param p (PC.T Real) ->+   Param p (PC.T Real) ->+   Param p Real ->+   CausalP p+      (Stereo.T (LLVM.Value Vector))+      (Stereo.T (LLVM.Value Vector))+resonantFMSynthProc reson index depth vel =+   ((\stereoFreq ->+       let chan freq =+              CausalPS.osciSimple WaveL.approxSine2+              <<<+              ((CausalP.envelope+                  $< SigP.envelope+                        (piecewiseConstantVector depth)+                        (SigPS.exponential2 (timeConst 1) (vel+1)))+               <<<+               UniFilter.lowpass+               ^<<+               CtrlPS.process+               <<<+               (CausalP.zipWithSimple UniFilterL.parameter+                   <<<+                   CausalP.feedFst (piecewiseConstant reson)+                   <<<+                   (CausalP.envelope $< piecewiseConstant index)+                   <<<+                   CausalP.mapSimple Frame.subsampleVector+                   <<<+                   freq)+               &&&+               ((CausalPS.osciSimple WaveL.saw $< zero)+                <<<+                freq))+              &&&+              freq+       in  CausalP.stereoFromMono (chan id)+           <<<+           listen stereoFreq)+    =<<< arr HL.hHead)+   <<< arr (\freq -> HL.hCons freq HL.hNil)++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 ->+         osc+            (sr, ((reson, index, depth), vel, (detune,fm,freq)))+            (env dec rel vcsize sr 0 dur))+      (CausalP.runStorableChunky+         (let reson = control (fst3.fst3)+              index = control (snd3.fst3)+              depth = control (thd3.fst3)+              vel   = number snd3+              fm    = detuneModulation thd3+          in  CausalP.envelopeStereo $>+                 (resonantFMSynthProc reson index depth vel $*+                  stereoFrequenciesFromDetuneBendModulation (frequencyConst 5) fm)))+      pingReleaseEnvelope+++phaserOsci ::+   (Param.T p Real -> CausalP.T p a (LLVM.Value Vector)) ->+   CausalP.T p a (Stereo.T (LLVM.Value Vector))+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 ->+         osc (sr, (det, (fm,freq))) (env att sr vel dur))+      (let det = control fst+           fm  = modulation snd+           osci ::+              Param.T (det,fm) Real ->+              CausalP.T (det,fm)+                 (LLVM.Value Vector, LLVM.Value Vector)+                 (LLVM.Value Vector)+           osci d =+              (CausalPS.osciSimple WaveL.saw $< zero)+              <<<+              CausalP.envelope+              <<<+              first (one + CausalPS.amplify d)+       in  CausalP.runStorableChunky $+           (CausalP.envelopeStereo $>+              (phaserOsci osci+               <<<+               CausalP.feedFst (piecewiseConstantVector det)+               $* frequencyFromBendModulation (frequencyConst 5) 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.+    LLVM.Value Vector ->+    LLVM.CodeGenFunction r (LLVM.Value Vector)) ->+   IO (Real ->+       PC.T Real ->+       PC.T Real ->+       PC.T (BM.T Real) ->+       Instrument Real (Stereo.T Vector))+arcStringStereoFM wave =+   softStringShapeCore+      (\k p ->+         LM.liftR2 Frame.amplifyMono+            (WaveL.approxSine4 =<< WaveL.halfEnvelope p)+            (wave =<< WaveL.replicate k p))++softStringShapeCore ::+   (forall r.+    LLVM.Value Vector ->+    LLVM.Value Vector ->+    LLVM.CodeGenFunction r (LLVM.Value Vector)) ->+   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 ->+         osc (sr, ((det, dist), (fm,freq))) (env att sr vel dur))+      (let det  = control (fst.fst)+           dist = control (snd.fst)+           fm   = modulation snd+           osci ::+              Param.T (mod,fm) Real ->+              CausalP.T (mod,fm)+                 (LLVM.Value Vector,+                       {- wave shape parameter -}+                  (LLVM.Value Vector, LLVM.Value Vector)+                       {- detune, frequency modulation -})+                 (LLVM.Value Vector)+           osci d =+              CausalPS.shapeModOsci wave+              <<<+              second+                 (CausalP.feedFst zero+                  <<<+                  CausalP.envelope+                  <<<+                  first (one + CausalPS.amplify d))+       in  CausalP.runStorableChunky $+           (CausalP.envelopeStereo $>+              (phaserOsci osci+               $< piecewiseConstantVector dist+               $< piecewiseConstantVector det+               $* frequencyFromBendModulation (frequencyConst 5) 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 ->+         osc (sr, ((det, depth, dist), (fm, freq))) (env att sr vel dur))+      (let det   = control (fst3.fst)+           depth = control (snd3.fst)+           dist  = control (thd3.fst)+           fm  = modulation snd+           osci ::+              Param.T (mod,fm) Real ->+              CausalP.T (mod,fm)+                 ((LLVM.Value Vector, LLVM.Value Vector)+                       {- phase modulation depth, modulator distortion -},+                  (LLVM.Value Vector, LLVM.Value Vector)+                       {- detune, frequency modulation -})+                 (LLVM.Value Vector)+           osci d =+              CausalPS.osciSimple WaveL.approxSine2+              <<<+              (CausalP.envelope+               <<<+               second+                  (CausalPS.shapeModOsci WaveL.rationalApproxSine1+                     <<< second (CausalP.feedFst zero))+               <<^+               (\((dp, ds), f) -> (dp, (ds, f))))+               &&& arr snd+              <<<+              second+                 (CausalP.envelope <<<+                  first (one + CausalPS.amplify d))+       in  CausalP.runStorableChunky+              (CausalP.envelopeStereo <<<+                 (id &&&+                  (phaserOsci osci+                   <<<+                   CausalP.feedSnd+                      (SigP.zip+                         (piecewiseConstantVector det)+                         (frequencyFromBendModulation (frequencyConst 5) fm))+                   <<<+                   CausalP.feedSnd (piecewiseConstantVector dist)+                   <<<+                   (CausalP.envelope+                       $< piecewiseConstantVector depth)))))+      softStringReleaseEnvelope+++stereoNoise :: SigP p (Stereo.T (LLVM.Value Vector))+stereoNoise =+   traverse+      (\uid -> SigPS.noise uid (noiseReference 20000))+      (Stereo.cons 13 14)++windCore ::+   Param p (PC.T Real) ->+   Param p (PC.T (BM.T Real)) ->+   SigP p (Stereo.T (LLVM.Value Vector))+windCore reson fm =+   CausalP.stereoFromMonoControlled CtrlPS.process+    $< SigP.zipWithSimple+          (MoogL.parameter TypeNum.d8)+          (piecewiseConstant reson)+          (SigP.mapSimple Frame.subsampleVector+             (frequencyFromBendModulation (frequencyConst 0.2) fm))+    $* stereoNoise++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 ->+         osc (sr, (reson, (fm,freq))) (env att sr vel dur))+      (let reson = control fst+           fm = modulation snd+       in  CausalP.runStorableChunky $+           (CausalP.envelopeStereo $> windCore reson fm))+      softStringReleaseEnvelope+++fadeProcess ::+   (A.PseudoRing v, A.IntegerConstant v) =>+   CausalP.T p a v ->+   CausalP.T p a v ->+   CausalP.T p (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 ->+         osc (sr, ((phaserMix,phaserFreq), reson, (fm,freq))) (env att sr vel dur))+      (let phaserMix = control (fst.fst3)+           phaserFreq = frequencyControl (snd.fst3)+           reson = control snd3+           fm = modulation thd3+       in  CausalP.runStorableChunky $+           (CausalP.envelopeStereo $>+              ((CausalP.stereoFromMonoControlled+                   (fadeProcess (arr snd) CtrlPS.process+                    <<<+                    first (CausalP.mapSimple SoV.replicate)+                    <<^+                    (\((k,p),x) -> (k,(p,x))))+                  $< SigP.zip+                        (piecewiseConstant phaserMix)+                        (piecewiseConstant+                           (fmap (Allpass.flangerParameterPlain TypeNum.d8)+                               ^<< phaserFreq)))+               $*+               windCore reson fm)))+      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 ->+         osc+            (sr, ((bright, brightDecay), (detune,fm,freq)))+            (env dec rel vcsize sr vel dur))+      (CausalP.runStorableChunky+         (let bright    = frequency (fst.fst)+              brightDec = time (snd.fst)+              fm = detuneModulation snd+          in  CausalP.envelopeStereo $>+              (CausalP.stereoFromMono+                  (UniFilter.lowpass+                   ^<<+                   (CtrlPS.processCtrlRate $# (100::Real))+                      (\k -> SigP.mapSimple+                          (UniFilterL.parameter (LLVM.valueOf 10))+                          {- bound control in order to avoid too low resonant frequency,+                             which makes the filter instable -}+                          (SigP.exponentialBounded2+                              (frequencyConst 100)+                              (brightDec/k)+                              (bright)))+                   <<<+                   CausalPS.osciSimple WaveL.saw $< zero)+               $* stereoFrequenciesFromDetuneBendModulation (frequencyConst 10) 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+                (attack (chunkSizesFromLazyTime attackDur)+                    (sr,+                     (attackHalfLife,+                      attackPeak * amp / (1 - 2^?(-attackTime/attackHalfLife))))+                 `SigSt.append`+                 decay (chunkSizesFromLazyTime decayDur)+                    (sr,+                     (decayHalfLife,+                      ((attackPeak-1)*amp, amp))))+                (\x -> release vcsize (sr,(releaseHalfLife,x))))+      (SigP.runChunkyPattern $+       let halfLife  = time fst+           amplitude = number snd+       in  SigPS.constant amplitude -+           SigPS.exponential2 halfLife amplitude)+      (SigP.runChunkyPattern $+       let halfLife   = time fst+           amplitude  = number (fst.snd)+           saturation = number (snd.snd)+       in  SigPS.constant saturation ++           SigPS.exponential2 halfLife amplitude)+      (SigP.runChunky $+       let releaseTime = vectorTime fst * 5+           releaseHL   = time fst+           amplitude   = number snd+       in  CausalP.take (round ^<< 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 ->+         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 det  = control (fst.fst3)+           dist = control (snd.fst3)+           fm   = modulation snd3+           emph = signal thd3+           osci ::+              Param.T p Real ->+              CausalP.T p+                 (LLVM.Value Vector,+                       {- wave shrink/replication factor -}+                  (LLVM.Value Vector, LLVM.Value Vector)+                       {- detune, frequency modulation -})+                 (LLVM.Value Vector)+           osci d =+              CausalPS.shapeModOsci WaveL.rationalApproxSine1+              <<<+              second+                 (CausalP.feedFst zero+                  <<<+                  CausalP.envelope+                  <<<+                  first (one + CausalPS.amplify d))+       in  CausalP.runStorableChunky $+           (CausalP.envelopeStereo $>+              (phaserOsci osci+               <<<+               CausalP.feedFst (piecewiseConstantVector dist)+               <<<+               CausalP.feedSnd (frequencyFromBendModulation (frequencyConst 5) fm)+               <<<+               (CausalP.envelope $< piecewiseConstantVector det)+               $*+               SigP.fromStorableVectorLazy emph)))+      adsr+++data SamplePositions =+   SamplePositions {+      sampleStart, sampleLength,+      sampleLoopStart, sampleLoopLength :: Int+   }++data SampledSound =+   SampledSound {+      sampleData :: SigSt.T Real,+      samplePositions :: SamplePositions,+      samplePeriod :: Real+   }+++sampledSound ::+   IO (SampledSound ->+       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 =+                freqMod+                   (chunkSizesFromLazyTime (PC.duration fm))+                   (sr, (fm, freq*samplePeriod smp)) :: SigSt.T Vector+             pos = samplePositions smp+             amp = 2 * amplitudeFromVelocity vel+             (attack,sustain) =+                mapPair+                   (SigSt.drop (sampleStart pos),+                    SigSt.take (sampleLoopLength pos)) $+                SigSt.splitAt (sampleLoopStart pos) $+                sampleData smp+             release =+                SigSt.drop (sampleLoopStart pos + sampleLoopLength pos) $+                SigSt.take (sampleStart     pos + sampleLength     pos) $+                sampleData smp+         in  (\cont -> osc cont+                (sr,+                 (amp,+                  attack `SigSt.append`+                  SVL.cycle (SigSt.take (sampleLoopLength pos) sustain),+                  chunkSizesFromLazyTime dur))+                fmSig)+             (osc (const SigSt.empty)+                (sr, (amp, release, NonNegChunky.fromChunks (repeat 1000)))))+      (CausalP.runStorableChunkyCont+         (let amp = number fst3+              smp = signal snd3+              dur = parameter thd3+          in  CausalPS.amplifyStereo amp+              <<<+              CausalP.stereoFromMono+                 (CausalPS.pack+                    (CausalP.frequencyModulationLinear+                       (SigP.fromStorableVectorLazy smp)))+              <<<+              liftA2 Stereo.cons+                 (CausalPS.amplify 0.999)+                 (CausalPS.amplify 1.001)+              <<<+              arr fst+              <<<+              CausalP.feedSnd (SigP.lazySize dur)))+      (SigP.runChunkyPattern+         (frequencyFromBendModulation (frequencyConst 3) (modulation id)))+++sampledSoundLeaky ::+   IO (SampledSound ->+       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) =+                SVP.splitAt (chunkSizesFromLazyTime dur) $+                (freqMod+                   (chunkSizesFromLazyTime (PC.duration fm))+                   (sr, (fm, freq*samplePeriod smp)) :: SigSt.T Vector)+             pos = samplePositions smp+             amp = 2 * amplitudeFromVelocity vel+             (attack,sustain) =+                mapPair+                   (SigSt.drop (sampleStart pos),+                    SigSt.take (sampleLoopLength pos)) $+                SigSt.splitAt (sampleLoopStart pos) $+                sampleData smp+             release =+                SigSt.drop (sampleLoopStart pos + sampleLoopLength pos) $+                SigSt.take (sampleStart     pos + sampleLength     pos) $+                sampleData smp+         in  osc+                (sr,+                 (amp,+                  attack `SigSt.append`+                  SVL.cycle (SigSt.take (sampleLoopLength pos) sustain)))+                sustainFM+             `SigSt.append`+             osc (sr, (amp,release)) releaseFM)+      (CausalP.runStorableChunky+         (let smp = signal snd+              amp = number fst+          in  CausalPS.amplifyStereo amp+              <<<+              CausalP.stereoFromMono+                 (CausalPS.pack+                    (CausalP.frequencyModulationLinear+                       (SigP.fromStorableVectorLazy smp)))+              <<<+              liftA2 Stereo.cons+                 (CausalPS.amplify 0.999)+                 (CausalPS.amplify 1.001)))+      (SigP.runChunkyPattern+         (frequencyFromBendModulation (frequencyConst 3) (modulation id)))+++loadSound :: FilePath -> IO (SVL.Vector Real)+loadSound path =+   bracket (SoxRead.open SoxOption.none path) SoxRead.close $+   SoxRead.withHandle1 (SVL.hGetContentsSync SVL.defaultChunkSize)+++type SampleInfo = (FilePath, [SamplePositions], Real)+++-- ToDo: flag failure if files cannot be found, or just remain silent+makeSampledSounds ::+   FilePath ->+   SampleInfo ->+   IO [-- PC.T Real ->+       PC.T (BM.T Real) ->+       Instrument Real (Stereo.T Vector)]+makeSampledSounds dir (file, positions, period) = do+{-+   sound <-+      (SoxRead.withHandle1 (SVL.hGetContentsSync chunkSize) =<<+       SoxRead.open SoxOption.none "speech/tomatensalat2.wav")+   play (44100::Real) (sound::SVL.Vector Real)+-}+   liftA2+      (\makeSmp smp ->+          map (\pos -> makeSmp (SampledSound smp pos period))+             positions)+      sampledSound+      (loadSound (dir </> file))+++tomatensalatPositions :: [SamplePositions]+tomatensalatPositions =+   SamplePositions      0 29499  12501 15073 :+   SamplePositions  29499 31672  38163 17312 :+   SamplePositions  67379 28610  81811 10667 :+   SamplePositions  95989 31253 106058 16111 :+   SamplePositions 127242 38596 136689 11514 :+   []++tomatensalat :: SampleInfo+tomatensalat =+   ("tomatensalat2.wav", tomatensalatPositions, 324.5)+++halPositions :: [SamplePositions]+halPositions =+--   SamplePositions   2371 25957   7362  6321 :+   SamplePositions   2371 25957 (2371+25957) 1 :+   SamplePositions  40546 34460  63540  9546 :+   SamplePositions  79128 32348  94367 14016 :+   SamplePositions 112027 21227 125880  5500 :+   SamplePositions 146057 23235 168941   352 :+   []++hal :: SampleInfo+hal =+   ("haskell-in-leipzig2.wav", halPositions, 316)+++graphentheoriePositions :: [SamplePositions]+graphentheoriePositions =+   SamplePositions      0 29524  13267 14768 :+   SamplePositions  29524 35333  47624  9968 :+   SamplePositions  64857 31189  73818 16408 :+   SamplePositions  96046 31312 106206 18504 :+   SamplePositions 127358 32127 132469 16530 :+   []++graphentheorie :: SampleInfo+graphentheorie =+   ("graphentheorie0.wav", graphentheoriePositions, 301.15)
src/Synthesizer/LLVM/Server/Packed/Run.hs view
@@ -1,8 +1,9 @@ module Synthesizer.LLVM.Server.Packed.Run where  import qualified Synthesizer.LLVM.Server.Packed.Instrument as Instr+import qualified Synthesizer.LLVM.Server.Option as Option import Synthesizer.LLVM.Server.Packed.Instrument-          (Vector, vectorSize, vectorChunkSize, )+          (Vector, VectorSize, vectorSize, ) import Synthesizer.LLVM.Server.Common  import qualified Sound.ALSA.Sequencer.Event as Event@@ -11,6 +12,7 @@ import qualified Synthesizer.PiecewiseConstant.ALSA.MIDIControllerSet as PCS import qualified Synthesizer.Generic.ALSA.MIDI 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@@ -24,11 +26,13 @@  import qualified LLVM.Core as LLVM -import qualified Synthesizer.Storable.Signal      as SigSt+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 @@ -36,8 +40,8 @@ import qualified Data.EventList.Relative.MixedTime as EventListMT  import Synthesizer.ApplicativeUtility (liftA4, liftA5, liftA6, )-import Control.Arrow ((<<<), (^<<), {- (<<^), -} (&&&), {- (***), -} arr, first, {- second, -} )-import Control.Applicative (pure, {- liftA, -} liftA2, liftA3, (<*>), )+import Control.Arrow ((<<<), (^<<), arr, first, {- second, -} )+import Control.Applicative (pure, {- liftA, liftA2, -} liftA3, (<*>), ) import Control.Monad.Trans.State (evalState, )  {-@@ -47,36 +51,56 @@ import qualified Numeric.NonNegative.Wrapper as NonNegW import qualified Numeric.NonNegative.Chunky as NonNegChunky -}---- import qualified Algebra.RealRing as RealRing-import qualified Algebra.Additive  as Additive+import Algebra.IntegralDomain (divUp, ) -import NumericPrelude.Numeric (zero, round, )+import NumericPrelude.Numeric (zero, round, (^?), ) import Prelude hiding (Real, round, break, )   +vectorChunkSize :: Option.T -> SVL.ChunkSize+vectorChunkSize opts =+   case Option.chunkSize opts of+      SVL.ChunkSize size ->+         SVL.ChunkSize (divUp size vectorSize)++sampleRate :: Num a => Option.T -> a+sampleRate opt =+   case Option.sampleRate opt of+      SampleRate sr -> sr++ {-# INLINE withMIDIEventsMono #-} withMIDIEventsMono ::-   (Double -> Double -> SigSt.T Real -> IO b) ->+   Option.T ->+   (Option.T -> Double -> SigSt.T Real -> IO b) ->    (EventList.T Ev.StrictTime [Event.T] -> SigSt.T Vector) -> IO b-withMIDIEventsMono action proc =-   let rate = sampleRate-       per  = periodTime-   in  Ev.withMIDIEvents per (rate / fromIntegral vectorSize) $-       action per rate . SigStL.unpack . proc+withMIDIEventsMono opt action proc =+   let rate = sampleRate opt+   in  do+          putStrLn startMessage+          Ev.withMIDIEvents+             (Option.clientName opt)+             (Option.periodTime opt) (rate / fromIntegral vectorSize) $+                action opt rate . SigStL.unpack . proc ++type StereoVector = StereoInt.T VectorSize Real+ {-# INLINE withMIDIEventsStereo #-} withMIDIEventsStereo ::-   (Double -> Double -> SigSt.T (Stereo.T Real) -> IO b) ->-   (EventList.T Ev.StrictTime [Event.T] -> SigSt.T (Stereo.T Vector)) ->+   Option.T ->+   (Option.T -> Double -> SigSt.T (Stereo.T Real) -> IO b) ->+   (EventList.T Ev.StrictTime [Event.T] -> SigSt.T StereoVector) ->    IO b-withMIDIEventsStereo action proc =-   let rate = sampleRate-       per  = periodTime-   in  do unpack <- SigStL.makeUnpackGeneric-          Ev.withMIDIEvents per (rate / fromIntegral vectorSize) $-             action per rate . unpack . proc+withMIDIEventsStereo opt action proc =+   let rate = sampleRate opt+   in  do+          putStrLn startMessage+          Ev.withMIDIEvents+             (Option.clientName opt)+             (Option.periodTime opt) (rate / fromIntegral vectorSize) $+                action opt rate . SigStL.unpackStereo . proc   -- maybe this can be merged into a PCS.controllerDiscrete@@ -89,81 +113,117 @@  frequencyModulation :: IO () frequencyModulation = do+   opt <- Option.get    osc <-       SigP.runChunky          ((CausalPS.osciSimple WaveL.triangle $<# (LLVM.vector [zero] :: Vector))-           $* Instr.frequencyFromBendModulation 10 (arr id &&& pure 880))-   withMIDIEventsMono play $-      osc vectorChunkSize .-      evalState (PC.bendWheelPressure channel 2 0.04 (0.03::Real))+           $* Instr.frequencyFromBendModulation+                 (frequencyConst 10)+                 (Instr.modulation (\fm -> (fm,880))))+   withMIDIEventsMono opt play $+      osc (vectorChunkSize opt) . (,) (Option.sampleRate opt) .+      evalState (PC.bendWheelPressure (Option.channel opt) 2 0.04 (0.03::Real))    keyboard :: IO () keyboard = do-   sound <- Instr.pingRelease $/ 0.4 $/ 0.1+   opt <- Option.get+   sound <-+      Instr.pingRelease+         $/ 0.4 $/ 0.1 $/ vectorChunkSize opt $/ Option.sampleRate opt    amp <- CausalP.runStorableChunky (CausalPS.amplify $# 0.2)    arrange <- SigStL.makeArranger-   withMIDIEventsMono play $+   withMIDIEventsMono opt play $       (amp () :: SigSt.T Vector -> SigSt.T Vector) .-      evalState (Gen.sequence (arrange vectorChunkSize) channel sound)+      arrange (vectorChunkSize opt) .+      evalState (Gen.sequence (Option.channel opt) sound)  keyboardStereo :: IO () keyboardStereo = do-   sound <- Instr.pingStereoRelease $/ 0.4 $/ 0.1-   amp <- CausalP.runStorableChunky (CausalP.amplifyStereo $# 0.2)+   opt <- Option.get+   sound <-+      Instr.pingStereoRelease+         $/ 0.4 $/ 0.1 $/ vectorChunkSize opt $/ Option.sampleRate opt+   amp <-+      CausalP.runStorableChunky+         (CausalP.mapSimple StereoInt.interleave <<<+          (CausalPS.amplifyStereo $# 0.2))    arrange <- SigStL.makeArranger-   withMIDIEventsStereo play $-      (amp () :: SigSt.T (Stereo.T Vector) -> SigSt.T (Stereo.T Vector)) .-      evalState (Gen.sequence (arrange vectorChunkSize) channel sound)+   withMIDIEventsStereo opt play $+      (amp () :: SigSt.T (Stereo.T Vector) -> SigSt.T StereoVector) .+      arrange (vectorChunkSize opt) .+      evalState (Gen.sequence (Option.channel opt) sound)   keyboardFM :: IO () keyboardFM = do+   opt <- Option.get    str <- Instr.softStringFM-   amp <- CausalP.runStorableChunky (CausalP.amplifyStereo $# 0.2)+   amp <-+      CausalP.runStorableChunky+         (CausalP.mapSimple StereoInt.interleave <<<+          (CausalP.amplifyStereo $# 0.2))    arrange <- SigStL.makeArranger-   withMIDIEventsStereo play $-      (amp () :: SigSt.T (Stereo.T Vector) -> SigSt.T (Stereo.T Vector)) .+   withMIDIEventsStereo opt play $+      (amp () :: SigSt.T (Stereo.T Vector) -> SigSt.T StereoVector) .+      arrange (vectorChunkSize opt) .       evalState-         (do fm <- PC.bendWheelPressure channel 2 0.04 0.03-             Gen.sequenceModulated (arrange vectorChunkSize) fm channel str)+         (do fm <- PC.bendWheelPressure (Option.channel opt) 2 0.04 0.03+             Gen.sequenceModulated+                fm (Option.channel opt) (flip str (Option.sampleRate opt)))  keyboardFMMulti :: IO () keyboardFMMulti = do+   opt <- Option.get    str <- Instr.softStringFM-   tin <- Instr.tineStereoFM $/ 0.4 $/ 0.1-   amp <- CausalP.runStorableChunky (CausalP.amplifyStereo $# 0.2)+   tin <- Instr.tineStereoFM $/ 0.4 $/ 0.1 $/ vectorChunkSize opt+   amp <-+      CausalP.runStorableChunky+         (CausalP.mapSimple StereoInt.interleave <<<+          (CausalP.amplifyStereo $# 0.2))    arrange <- SigStL.makeArranger-   withMIDIEventsStereo play $-      (amp () :: SigSt.T (Stereo.T Vector) -> SigSt.T (Stereo.T Vector)) .+   withMIDIEventsStereo opt play $+      (amp () :: SigSt.T (Stereo.T Vector) -> SigSt.T StereoVector) .+      arrange (vectorChunkSize opt) .       evalState-         (do fm <- PC.bendWheelPressure channel 2 0.04 0.03+         (do fm <- PC.bendWheelPressure (Option.channel opt) 2 0.04 0.03              Gen.sequenceModulatedMultiProgram-                (arrange vectorChunkSize) fm channel+                fm (Option.channel opt)                 (VoiceMsg.toProgram 1)-                [str, tin])+                (map (\sound fmlocal -> sound fmlocal $ Option.sampleRate opt) [str, tin]))   controllerAttack, controllerDetune, controllerTimbre0, controllerTimbre1,    controllerFilterCutoff, controllerFilterResonance,-   controllerGlobal, controllerVolume :: VoiceMsg.Controller-[controllerAttack, controllerDetune, controllerTimbre0, controllerTimbre1,-   controllerFilterCutoff, controllerFilterResonance,-   controllerGlobal, controllerVolume] =-      map VoiceMsg.toController [21, 22, 23, 24, 91, 93, 82, 83]+   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  controllerFMDepth1, controllerFMDepth2, controllerFMDepth3, controllerFMDepth4,    controllerFMPartial1, controllerFMPartial2, controllerFMPartial3, controllerFMPartial4    :: VoiceMsg.Controller-[controllerFMDepth1, controllerFMDepth2, controllerFMDepth3, controllerFMDepth4,-   controllerFMPartial1, controllerFMPartial2, controllerFMPartial3, controllerFMPartial4] =-      map VoiceMsg.toController [25, 26, 27, 28, 70, 71, 72, 73]+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 ::+   FilePath ->+   SVL.ChunkSize ->    IO (ChannelMsg.Channel -> VoiceMsg.Program ->-       Ev.Filter (SigSt.T (Stereo.T Vector)))-keyboardDetuneFMCore = do+       SampleRate Real ->+       Ev.Filter (SigSt.T StereoVector))+keyboardDetuneFMCore smpDir vcsize = do    str0 <- Instr.softStringDetuneFM    ssh0 <- Instr.softStringShapeFM    css0 <- Instr.cosineStringStereoFM@@ -186,15 +246,15 @@    ben0 <- Instr.bellNoiseStereoFM    flt0 <- Instr.filterSawStereoFM    brs0 <- Instr.brass-   tmt0 <- Instr.makeSampledSounds Instr.tomatensalat-   hal0 <- Instr.makeSampledSounds Instr.hal-   grp0 <- Instr.makeSampledSounds Instr.graphentheorie+   tmt0 <- Instr.makeSampledSounds smpDir Instr.tomatensalat+   hal0 <- Instr.makeSampledSounds smpDir Instr.hal+   grp0 <- Instr.makeSampledSounds smpDir Instr.graphentheorie     let evHead =           fmap (EventListMT.switchBodyL              (error "empty controller stream") const)        flt = evalState $-          liftA5 (\rel -> flt0 (4*rel) rel)+          liftA6 (\rel -> flt0 (4*rel) rel)              (evHead $               PCS.controllerExponential controllerAttack (0.03,0.3) 0.1)              (PCS.controllerLinear controllerDetune (0,0.005) 0.001)@@ -202,53 +262,59 @@               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) .+          (\rel -> png0 (4*rel) rel vcsize) .           evalState              (evHead $               PCS.controllerExponential controllerAttack (0.03,0.3) 0.1)        pngFM = evalState $-          liftA5 (\rel det phs shp -> pngFM0 (4*rel) rel det shp 2 phs)+          liftA6 (\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 (0.3,0.001) 0.05)+             (PCS.controllerExponential controllerTimbre1 (1/pi,0.001) 0.05)+             (pure vcsize)              (PCS.bendWheelPressure 2 0.04 0.03)        sqr = evalState $-          liftA5 (\rel -> sqr0 (4*rel) rel)+          liftA6 (\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 (0.3,0.001) 0.05)+             (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 $-          liftA2 (\rel -> tin0 (4*rel) rel)+          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 $-          liftA5 (\rel -> tnc0 (4*rel) rel)+          liftA6 (\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 $-          liftA6 (\rel -> fnd0 (4*rel) rel)-             (evHead $+          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 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)-             (PCS.bendWheelPressure 2 0.04 0.03)+             <*> (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 $@@ -262,28 +328,32 @@              <*> (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 $-          liftA6 (\rel -> rfm0 (4*rel) rel)-             (evHead $+          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)-             (PCS.bendWheelPressure 2 0.04 0.03)+             <*> (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 $-          liftA3 (\rel -> bel0 (2*rel) rel)+          liftA4 (\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 $-          liftA4 (\rel -> ben0 (2*rel) rel)+          liftA5 (\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@@ -296,7 +366,7 @@              (evHead $               PCS.controllerExponential controllerAttack (0.02,2) 0.5)              (PCS.controllerLinear controllerDetune (0,0.01) 0.005)-             (PCS.controllerExponential controllerTimbre0 (0.3,0.001) 0.05)+             (PCS.controllerExponential controllerTimbre0 (1/pi,0.001) 0.05)              (PCS.bendWheelPressure 2 0.04 0.03)        makeArc gen = evalState $           liftA4 gen@@ -333,14 +403,15 @@              (PCS.controllerExponential controllerTimbre1 (1,1000) 100)              (PCS.bendWheelPressure 12 0.8 0)        brs = evalState $-          liftA5+          liftA6              (\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 (0.3,0.001) 0.05)+             (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@@ -349,10 +420,11 @@    arrange <- SigStL.makeArranger    amp <-       CausalP.runStorableChunky-         (CausalP.envelopeStereo $<+         (CausalP.mapSimple StereoInt.interleave <<<+          CausalP.envelopeStereo $<             Instr.piecewiseConstantVector (arr id))    return-      (\chan pgm -> do+      (\chan pgm sr -> do          volume <-             PC.controllerExponential chan                controllerVolume@@ -360,10 +432,11 @@           ctrls <- PCS.fromChannel chan -         fmap (amp volume) $+         fmap (amp volume . arrange vcsize) $             Gen.sequenceModulatedMultiProgram-               (arrange vectorChunkSize) ctrls chan pgm-               ([tnc, fnd, pngFM, flt, bel, ben, sqr, brs,+               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) tmt0 ++                 map (.freqMod) hal0 ++@@ -373,15 +446,20 @@  keyboardDetuneFM :: IO () keyboardDetuneFM = do-   proc <- keyboardDetuneFMCore-   withMIDIEventsStereo play $-      evalState (proc channel (VoiceMsg.toProgram 0))+   opt <- Option.get+   proc <- keyboardDetuneFMCore (Option.sampleDirectory opt) (vectorChunkSize opt)+   withMIDIEventsStereo opt play $+      evalState (proc (Option.channel opt) (VoiceMsg.toProgram 0) (Option.sampleRate opt))  keyboardFilter :: IO () keyboardFilter = do-   proc <- keyboardDetuneFMCore+   opt <- Option.get+   proc <- keyboardDetuneFMCore (Option.sampleDirectory opt) (vectorChunkSize opt)    mix <- CausalP.runStorableChunky-      (CausalP.mixStereo <<< first (CausalPS.amplifyStereo 0.5)+      (CausalP.mapSimple StereoInt.interleave <<<+       CausalP.mix <<<+            first (CausalPS.amplifyStereo 0.5 <<<+                   CausalP.mapSimple StereoInt.deinterleave)          $< SigP.fromStorableVectorLazy (arr id))     lowpass0 <-@@ -392,31 +470,35 @@              (UniFilter.lowpass ^<< UniFilterL.causalP) $<           (SigP.interpolateConstant $# (fromIntegral vectorSize :: Real))              (piecewiseConstant (arr id)))+      <<<+      CausalP.mapSimple StereoInt.deinterleave    let lowpass ::           PC.T Real -> PC.T Real ->-          SigSt.T (Stereo.T Vector) -> SigSt.T (Stereo.T Vector)+          SigSt.T StereoVector -> SigSt.T (Stereo.T Vector)        lowpass resons freqs =           lowpass0 (fmap UniFilter.parameter-             (PC.zipWith FiltR.Pole resons (fmap (/sampleRate) freqs)))+             (PC.zipWith FiltR.Pole resons+                (fmap (/ sampleRate opt) freqs))) -   withMIDIEventsStereo (playAndRecord "/gentoo/server-llvm.f32") $---   withMIDIEventsStereo play $+   withMIDIEventsStereo opt play $       evalState          (do {-              It is important to retrieve the global controllers              before they are filtered out by PCS.fromChannel.              -}-             let altChannel = (ChannelMsg.toChannel 1)+             let freqBnd v = 880 * 2^?(v/24)              freq <--                PC.controllerExponential altChannel+                PC.controllerExponential (Option.extraChannel opt)                    controllerFilterCutoff-                   (100, 5000) 5000+                   (freqBnd (-64), freqBnd 63) 5000              resonance <--                PC.controllerExponential altChannel+                PC.controllerExponential (Option.extraChannel opt)                    controllerFilterResonance                    (1, 100) 1-             filterMusic <- proc altChannel (VoiceMsg.toProgram 8)-             pureMusic <- proc channel (VoiceMsg.toProgram 0)+             filterMusic <-+                proc (Option.extraChannel opt) (VoiceMsg.toProgram 8) (Option.sampleRate opt)+             pureMusic <-+                proc (Option.channel opt) (VoiceMsg.toProgram 0) (Option.sampleRate opt)              return                 (pureMusic `mix`                  lowpass resonance freq filterMusic))
src/Synthesizer/LLVM/Server/Packed/Test.hs view
@@ -1,12 +1,14 @@ module Synthesizer.LLVM.Server.Packed.Test where  import qualified Synthesizer.LLVM.Server.Packed.Instrument as Instr+import qualified Synthesizer.LLVM.Server.Option as Option import Synthesizer.LLVM.Server.Packed.Instrument-          (Vector, vectorChunkSize,+          (Vector, vectorSize,            sampleStart, sampleLength,            sampleLoopStart, sampleLoopLength,            samplePositions, sampleData, samplePeriod, )-import Synthesizer.LLVM.Server.Common+import Synthesizer.LLVM.Server.Common hiding+          (Instrument, )  import qualified Sound.ALSA.Sequencer.Event as Event import qualified Synthesizer.PiecewiseConstant.ALSA.MIDI as PC@@ -14,15 +16,15 @@  import qualified Synthesizer.LLVM.Frame.Stereo as Stereo +import qualified Synthesizer.Storable.ALSA.Play as Play import Synthesizer.Storable.ALSA.MIDI (Instrument, chunkSizesFromLazyTime, ) -import qualified Synthesizer.LLVM.ALSA.MIDI as MIDIL+import qualified Synthesizer.LLVM.ALSA.BendModulation as BM import qualified Synthesizer.LLVM.CausalParameterized.ProcessPacked as CausalPS import qualified Synthesizer.LLVM.Parameterized.SignalPacked as SigPS import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP import qualified Synthesizer.LLVM.Parameterized.Signal as SigP import qualified Synthesizer.LLVM.Storable.Signal as SigStL-import qualified Synthesizer.LLVM.Sample as Sample import Synthesizer.LLVM.CausalParameterized.Process (($*), )  import qualified LLVM.Core as LLVM@@ -36,7 +38,7 @@ import qualified Data.EventList.Relative.TimeBody  as EventList import qualified Data.EventList.Relative.BodyTime  as EventListBT -import Control.Arrow ((<<<), (&&&), arr, )+import Control.Arrow ((<<<), arr, ) import Control.Applicative (pure, liftA, liftA2, ) import Control.Monad.Trans.State (evalState, ) @@ -48,6 +50,7 @@ import qualified Numeric.NonNegative.Wrapper as NonNegW import qualified Numeric.NonNegative.Chunky as NonNegChunky +import Algebra.IntegralDomain (divUp, ) {- import qualified Algebra.RealRing as RealRing import qualified Algebra.Additive  as Additive@@ -57,6 +60,18 @@ import Prelude hiding (Real, round, break, )  +vectorChunkSize :: SVL.ChunkSize+vectorChunkSize =+   case Play.defaultChunkSize of+      SVL.ChunkSize size ->+         SVL.ChunkSize (divUp size vectorSize)++sampleRatePlain :: Num a => a+sampleRatePlain = Option.defaultSampleRate++sampleRate :: Option.SampleRate Real+sampleRate = Option.SampleRate Option.defaultSampleRate+ {- | try to reproduce a space leak -}@@ -64,7 +79,8 @@ sequencePlain =    SVL.writeFile "test.f32" $ --   print $ last $ SVL.chunks $-      evalState (Gen.sequence (CutSt.arrange chunkSize) channel (error "no sound" :: Instrument Real Real)) $+      CutSt.arrange Option.defaultChunkSize $+      evalState (Gen.sequence Option.defaultChannel (error "no sound" :: Instrument Real Real)) $       let evs = EventList.cons 10 [] evs       in  evs @@ -73,7 +89,8 @@    arrange <- SigStL.makeArranger    SVL.writeFile "test.f32" $ --   print $ last $ SVL.chunks $-      evalState (Gen.sequence (arrange vectorChunkSize) channel (error "no sound" :: Instrument Real Vector)) $+      arrange vectorChunkSize $+      evalState (Gen.sequence Option.defaultChannel (error "no sound" :: Instrument Real Vector)) $       let evs = EventList.cons 10 [] evs       in  evs @@ -81,10 +98,11 @@ 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 (arrange vectorChunkSize) fm channel+          in  Gen.sequenceModulated fm Option.defaultChannel                  (error "no sound" ::                      PC.T Real -> Instrument Real Vector)) $       let evs = EventList.cons 10 [] evs@@ -94,9 +112,10 @@ 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 (arrange vectorChunkSize) (fm 1) channel+          in  Gen.sequenceModulated (fm 1) Option.defaultChannel                  (error "no sound" ::                      PC.T Real -> Instrument Real Vector)) $       let evs = EventList.cons 10 [] evs@@ -106,9 +125,10 @@ sequencePitchBend = do    arrange <- SigStL.makeArranger    SVL.writeFile "test.f32" $+      arrange vectorChunkSize $       evalState-         (do fm <- PC.pitchBend channel 2 0.01-             Gen.sequenceModulated (arrange vectorChunkSize) fm channel+         (do fm <- PC.pitchBend Option.defaultChannel 2 0.01+             Gen.sequenceModulated fm Option.defaultChannel                 (error "no sound" ::                     PC.T Real -> Instrument Real Vector)) $       let evs = EventList.cons 10 [] evs@@ -118,11 +138,12 @@ sequenceModulated = do    arrange <- SigStL.makeArranger    SVL.writeFile "test.f32" $+      arrange vectorChunkSize $       evalState-         (do fm <- PC.bendWheelPressure channel 2 0.04 0.03-             Gen.sequenceModulated (arrange vectorChunkSize) fm channel+         (do fm <- PC.bendWheelPressure Option.defaultChannel 2 0.04 0.03+             Gen.sequenceModulated fm Option.defaultChannel                 (error "no sound" ::-                    PC.T (MIDIL.BendModulation Real) ->+                    PC.T (BM.T Real) ->                     Instrument Real Vector)) $       let evs = EventList.cons 10 [] evs       in  evs@@ -130,13 +151,13 @@ sequenceModulatedLong :: IO () sequenceModulatedLong = do    arrange <- SigStL.makeArranger---   sound <- Instr.softStringReleaseEnvelope-   sound <- Instr.softString  -- space leak---   sound <- Instr.pingReleaseEnvelope $/ 1  -- no space leak---   sound <- Instr.pingRelease $/ 1 $/ 1  -- no space leak+--   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" $-      evalState-         (Gen.sequence (arrange vectorChunkSize) channel sound) $+      arrange vectorChunkSize $+      evalState (Gen.sequence Option.defaultChannel 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] $@@ -147,9 +168,11 @@    arrange <- SigStL.makeArranger    sound <- Instr.softStringFM    SVL.writeFile "test.f32" $+      arrange vectorChunkSize $       evalState-         (do fm <- PC.bendWheelPressure channel 2 0.04 0.03-             Gen.sequenceModulated (arrange vectorChunkSize) fm channel sound) $+         (do fm <- PC.bendWheelPressure Option.defaultChannel 2 0.04 0.03+             Gen.sequenceModulated fm Option.defaultChannel+                (\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] $@@ -160,9 +183,11 @@    arrange <- SigStL.makeArranger    sound <- Instr.softStringFM    SVL.writeFile "test.f32" $+      arrange vectorChunkSize $       evalState-         (do fm <- PC.bendWheelPressure channel 2 0.04 0.03-             Gen.sequenceModulated (arrange vectorChunkSize) fm channel sound) $+         (do fm <- PC.bendWheelPressure Option.defaultChannel 2 0.04 0.03+             Gen.sequenceModulated fm Option.defaultChannel+                (\fmlocal -> sound fmlocal $ sampleRate)) $       let evs t =              EventList.cons t [makeNote Event.NoteOn  60] $              EventList.cons t [makeNote Event.NoteOff 60] $@@ -172,12 +197,13 @@ sequencePress :: IO () sequencePress = do    arrange <- SigStL.makeArranger---   sound <- Instr.softString---   sound <- Instr.softStringReleaseEnvelope-   sound <- Instr.pingReleaseEnvelope $/ 1+--   sound <- Instr.softString $/ sampleRate+--   sound <- Instr.softStringReleaseEnvelope $/ sampleRate+   sound <- Instr.pingReleaseEnvelope $/ 1 $/ 1 $/ vectorChunkSize $/ sampleRate    SVL.writeFile "test.f32" $+      arrange vectorChunkSize $       evalState-         (do Gen.sequence (arrange vectorChunkSize) channel sound) $+         (Gen.sequence Option.defaultChannel (\ _freq -> sound)) $       let evs t =              EventList.cons t [makeNote Event.NoteOn  60] $              EventList.cons t [makeNote Event.NoteOff 60] $@@ -187,12 +213,12 @@  sampledSoundTest0 ::    IO (Instr.SampledSound ->-       PC.T (PC.BendModulation Real) ->+       PC.T (BM.T Real) ->        Instrument Real (Stereo.T Vector)) sampledSoundTest0 =    liftA       (\osc smp _fm _vel _freq _dur ->-         osc chunkSize (sampleData smp))+         osc Option.defaultChunkSize (sampleData smp))       (SigP.runChunky          (let smp = arr id           in  fmap (\x -> Stereo.cons x x) $@@ -201,26 +227,26 @@  sampledSoundTest1 ::    IO (Instr.SampledSound ->-       PC.T (PC.BendModulation Real) ->+       PC.T (BM.T Real) ->        Instrument Real (Stereo.T Vector)) sampledSoundTest1 =    liftA       (\osc smp _fm _vel _freq _dur ->-         osc chunkSize (sampleData smp))+         osc Option.defaultChunkSize (sampleData smp))       (SigP.runChunky          (let smp = arr id           in  CausalP.stereoFromMono                  (CausalPS.pack                     (CausalP.frequencyModulationLinear                        (SigP.fromStorableVectorLazy smp)))-               $* SigP.zipWithSimple Sample.zipStereo+               $* liftA2 Stereo.cons                      (SigPS.constant 0.999)                      (SigPS.constant 1.001))) --               $* (SigPS.constant $# Stereo.cons 0.999 1.001)))  sampledSoundTest2 ::    IO (Instr.SampledSound ->-       PC.T (PC.BendModulation Real) ->+       PC.T (BM.T Real) ->        Instrument Real (Stereo.T Vector)) sampledSoundTest2 =    liftA@@ -231,24 +257,24 @@                 SigSt.drop (sampleStart pos) $                 sampleData smp          in  SVP.take (chunkSizesFromLazyTime dur) $-             osc chunkSize (body, (fm, freq * samplePeriod smp)))+             osc Option.defaultChunkSize+                (sampleRate, (body, (fm, freq * samplePeriod smp))))       (SigP.runChunky-         (let smp = arr fst-              fm = arr snd+         (let smp = signal fst+              fm = Instr.modulation snd           in  (CausalP.stereoFromMono                   (CausalPS.pack                      (CausalP.frequencyModulationLinear                         (SigP.fromStorableVectorLazy smp)))                <<<-               CausalP.zipWithSimple Sample.zipStereo-               <<<-               CausalPS.amplify 0.999 &&&-               CausalPS.amplify 1.001)-                 $* Instr.frequencyFromBendModulation 3 fm))+               liftA2 Stereo.cons+                  (CausalPS.amplify 0.999)+                  (CausalPS.amplify 1.001))+                 $* Instr.frequencyFromBendModulation (frequencyConst 3) fm))  sampledSoundTest3SpaceLeak ::    IO (Instr.SampledSound ->-       PC.T (PC.BendModulation Real) ->+       PC.T (BM.T Real) ->        Instrument Real (Stereo.T Vector)) sampledSoundTest3SpaceLeak =    liftA@@ -261,8 +287,8 @@          -}          let (sustainFM, releaseFM) =                 SVP.splitAt (chunkSizesFromLazyTime dur) $-                (SigSt.repeat chunkSize-                   (LLVM.vector [freq*samplePeriod smp/sampleRate])+                (SigSt.repeat Option.defaultChunkSize+                   (LLVM.vector [freq*samplePeriod smp/sampleRatePlain])                       :: SigSt.T Vector)              pos = samplePositions smp              amp = 2 * amplitudeFromVelocity vel@@ -293,14 +319,13 @@                     (CausalP.frequencyModulationLinear                        (SigP.fromStorableVectorLazy smp)))               <<<-              CausalP.zipWithSimple Sample.zipStereo-              <<<-              CausalPS.amplify 0.999 &&&-              CausalPS.amplify 1.001))+              liftA2 Stereo.cons+                 (CausalPS.amplify 0.999)+                 (CausalPS.amplify 1.001)))  sampledSoundTest4NoSpaceLeak ::    IO (Instr.SampledSound ->-       PC.T (PC.BendModulation Real) ->+       PC.T (BM.T Real) ->        Instrument Real (Stereo.T Vector)) sampledSoundTest4NoSpaceLeak =    liftA@@ -315,16 +340,17 @@                 SVP.splitAt (chunkSizesFromLazyTime dur) $                 (freqMod                    (chunkSizesFromLazyTime (PC.duration fm))-                   (fm, freq*samplePeriod smp) :: SigSt.T Vector)+                   (sampleRate, (fm, freq*samplePeriod smp)) :: SigSt.T Vector)          in  SigSt.map                 (\x -> Stereo.cons x x)                 (sustainFM `SigSt.append` releaseFM))       (SigP.runChunkyPattern-         (Instr.frequencyFromBendModulation 3 (arr id)))+         (Instr.frequencyFromBendModulation+            (frequencyConst 3) (Instr.modulation id)))  sampledSoundTest5LargeSpaceLeak ::    IO (Instr.SampledSound ->-       PC.T (PC.BendModulation Real) ->+       PC.T (BM.T Real) ->        Instrument Real (Stereo.T Vector)) sampledSoundTest5LargeSpaceLeak =    liftA2@@ -339,7 +365,7 @@                 SVP.splitAt (chunkSizesFromLazyTime dur) $                 (freqMod                    (chunkSizesFromLazyTime (PC.duration fm))-                   (fm, freq*samplePeriod smp) :: SigSt.T Vector)+                   (sampleRate, (fm, freq*samplePeriod smp)) :: SigSt.T Vector)              pos = samplePositions smp              amp = 2 * amplitudeFromVelocity vel              (attack,sustain) =@@ -362,20 +388,21 @@       (CausalP.runStorableChunky          (arr (\x -> Stereo.cons x x)))       (SigP.runChunkyPattern-         (Instr.frequencyFromBendModulation 3 (arr id)))+         (Instr.frequencyFromBendModulation+            (frequencyConst 3) (Instr.modulation id)))   sampledSoundSmallSpaceLeak4 ::    IO (Instr.SampledSound ->-       PC.T (PC.BendModulation Real) ->+       PC.T (BM.T Real) ->        Instrument Real (Stereo.T Vector)) sampledSoundSmallSpaceLeak4 =    liftA       (\osc smp _fm _vel freq dur ->          let (sustainFM, releaseFM) =                 SVP.splitAt (chunkSizesFromLazyTime dur) $-                (SigSt.repeat chunkSize-                   (LLVM.vector [freq*samplePeriod smp/sampleRate])+                (SigSt.repeat Option.defaultChunkSize+                   (LLVM.vector [freq*samplePeriod smp/sampleRatePlain])                       :: SigSt.T Vector)          in  osc () sustainFM              `SigSt.append`@@ -385,14 +412,14 @@  sampledSoundSmallSpaceLeak4a ::    IO (Instr.SampledSound ->-       PC.T (PC.BendModulation Real) ->+       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-                   (LLVM.vector [freq*samplePeriod smp/sampleRate])+                (SigSt.repeat Option.defaultChunkSize+                   (LLVM.vector [freq*samplePeriod smp/sampleRatePlain])                       :: SigSt.T Vector) of             (sustainFM, releaseFM) ->                osc () sustainFM@@ -403,15 +430,15 @@  sampledSoundNoSmallSpaceLeak3 ::    IO (Instr.SampledSound ->-       PC.T (PC.BendModulation Real) ->+       PC.T (BM.T Real) ->        Instrument Real (Stereo.T Vector)) sampledSoundNoSmallSpaceLeak3 =    pure       (\smp _fm _vel freq dur ->          let (sustainFM, releaseFM) =                 SVP.splitAt (chunkSizesFromLazyTime dur) $-                (SigSt.repeat chunkSize-                   (LLVM.vector [freq*samplePeriod smp/sampleRate])+                (SigSt.repeat Option.defaultChunkSize+                   (LLVM.vector [freq*samplePeriod smp/sampleRatePlain])                       :: SigSt.T Vector)          in  SigSt.map (\x -> Stereo.cons x x) sustainFM              `SigSt.append`@@ -423,15 +450,15 @@  sampledSoundNoSmallSpaceLeak2 ::    IO (Instr.SampledSound ->-       PC.T (PC.BendModulation Real) ->+       PC.T (BM.T Real) ->        Instrument Real (Stereo.T Vector)) sampledSoundNoSmallSpaceLeak2 =    liftA       (\osc smp _fm _vel freq dur ->          let (sustainFM, releaseFM) =                 SVP.splitAt (chunkSizesFromLazyTime dur) $-                (SigSt.repeat chunkSize-                   (LLVM.vector [freq*samplePeriod smp/sampleRate])+                (SigSt.repeat Option.defaultChunkSize+                   (LLVM.vector [freq*samplePeriod smp/sampleRatePlain])                       :: SigSt.T Vector)          in  osc ()                 (amplifySVL sustainFM@@ -442,15 +469,15 @@  sampledSoundSmallSpaceLeak1 ::    IO (Instr.SampledSound ->-       PC.T (PC.BendModulation Real) ->+       PC.T (BM.T Real) ->        Instrument Real (Stereo.T Vector)) sampledSoundSmallSpaceLeak1 =    liftA       (\osc smp _fm _vel freq dur ->          let (sustainFM, releaseFM) =                 SVP.splitAt (chunkSizesFromLazyTime dur) $-                (SigSt.repeat chunkSize-                   (LLVM.vector [freq*samplePeriod smp/sampleRate])+                (SigSt.repeat Option.defaultChunkSize+                   (LLVM.vector [freq*samplePeriod smp/sampleRatePlain])                       :: SigSt.T Vector)          in  osc () sustainFM              `SigSt.append`@@ -460,7 +487,7 @@  sampledSoundSmallSpaceLeak0 ::    IO (Instr.SampledSound ->-       PC.T (PC.BendModulation Real) ->+       PC.T (BM.T Real) ->        Instrument Real (Stereo.T Vector)) sampledSoundSmallSpaceLeak0 =    liftA@@ -473,8 +500,8 @@          -}          let (sustainFM, releaseFM) =                 SVP.splitAt (chunkSizesFromLazyTime dur) $-                (SigSt.repeat chunkSize-                   (LLVM.vector [freq*samplePeriod smp/sampleRate])+                (SigSt.repeat Option.defaultChunkSize+                   (LLVM.vector [freq*samplePeriod smp/sampleRatePlain])                       :: SigSt.T Vector)              pos = samplePositions smp              amp = 2 * amplitudeFromVelocity vel@@ -505,13 +532,14 @@    arrange <- SigStL.makeArranger    sampler <- sampledSoundTest2    let sound =-          sampler (Instr.SampledSound (SigSt.replicate chunkSize 100000 0)+          sampler (Instr.SampledSound (SigSt.replicate Option.defaultChunkSize 100000 0)                       (Instr.SamplePositions 0 100000 50000 50000)                       100)    SVL.writeFile "test.f32" $+      arrange vectorChunkSize $       evalState-         (do fm <- PC.bendWheelPressure channel 2 0.04 0.03-             Gen.sequenceModulated (arrange vectorChunkSize) fm channel sound) $+         (do fm <- PC.bendWheelPressure Option.defaultChannel 2 0.04 0.03+             Gen.sequenceModulated fm Option.defaultChannel sound) $       let evs t = EventList.cons t [] (evs (20-t))       in  EventList.cons 10 [makeNote Event.NoteOn 60] $           evs 10@@ -521,18 +549,18 @@ sequenceSample1 = do    sampler <- Instr.sampledSound    let sound =-          sampler (SampledSound (SigSt.replicate chunkSize 100000 0)+          sampler (SampledSound (SigSt.replicate Option.defaultChunkSize 100000 0)                       (SamplePositions 0 100000 50000 50000)                       100)    SVL.writeFile "test.f32" $       sound {-          (let evs f =-                 EventListBT.cons (MIDIL.BendModulation 0.001 f) 10 (evs (0.02-f))+                 EventListBT.cons (BM.Cons 0.001 f) 10 (evs (0.02-f))           in  evs 0.01) -}          (let evs t =-                 EventListBT.cons (MIDIL.BendModulation 0.01 0.001) t (evs (20-t))+                 EventListBT.cons (BM.Cons 0.01 0.001) t (evs (20-t))           in  evs 10) {-          (PCS.Cons@@ -550,12 +578,12 @@ sequenceSample1 = do    sampler <- sampledSoundSmallSpaceLeak4a    let sound =-          sampler (Instr.SampledSound (SigSt.replicate chunkSize 100000 0)+          sampler (Instr.SampledSound (SigSt.replicate Option.defaultChunkSize 100000 0)                       (Instr.SamplePositions 0 100000 50000 50000)                       100)    SVL.writeFile "test.f32" $       sound-         (let evs = EventListBT.cons (MIDIL.BendModulation 0.01 0.001) 1 evs+         (let evs = EventListBT.cons (BM.Cons 0.01 0.001) 1 evs           in  evs)          0.01 1          (NonNegChunky.fromChunks $ repeat $ NonNegW.fromNumber 10)@@ -575,7 +603,7 @@       let dur = NonNegChunky.fromChunks $ repeat $ SVL.chunkSize 10           !(sustainFM, releaseFM) =              SVP.splitAt dur $-             (SigSt.repeat chunkSize (LLVM.vector [1])+             (SigSt.repeat Option.defaultChunkSize (LLVM.vector [1])                  :: SigSt.T Vector)       in  case 3::Int of              -- no leak@@ -597,14 +625,15 @@    arrange <- SigStL.makeArranger    sampler <- sampledSoundTest2    let sound =-          sampler (Instr.SampledSound (SigSt.replicate chunkSize 100000 0)+          sampler (Instr.SampledSound (SigSt.replicate Option.defaultChunkSize 100000 0)                       (Instr.SamplePositions 0 100000 50000 50000)                       100)    SVL.writeFile "test.f32" $+      arrange vectorChunkSize $       evalState-         (do bend <- PC.pitchBend channel 2 0.01-             let fm = fmap (\t -> MIDIL.BendModulation t t) bend-             Gen.sequenceModulated (arrange vectorChunkSize) fm channel sound) $+         (do bend <- PC.pitchBend Option.defaultChannel 2 0.01+             let fm = fmap (\t -> BM.Cons t t) bend+             Gen.sequenceModulated fm Option.defaultChannel sound) $       let evs t = EventList.cons t [] (evs (20-t))       in  EventList.cons 10 [makeNote Event.NoteOn 60] $           evs 10@@ -619,14 +648,15 @@    arrange <- SigStL.makeArranger    sampler <- sampledSoundTest2    let sound =-          sampler (Instr.SampledSound (SigSt.replicate chunkSize 100000 0)+          sampler (Instr.SampledSound (SigSt.replicate Option.defaultChunkSize 100000 0)                       (Instr.SamplePositions 0 100000 50000 50000)                       100)    SVL.writeFile "test.f32" $+      arrange vectorChunkSize $       evalState          (let evs =-                 EventListBT.cons (MIDIL.BendModulation 0.01 0.001) 10 evs-          in  Gen.sequence (arrange vectorChunkSize) channel (sound evs)) $+                 EventListBT.cons (BM.Cons 0.01 0.001) 10 evs+          in  Gen.sequence Option.defaultChannel (sound evs)) $       let evs = EventList.cons 10 [] evs       in  EventList.cons 10 [makeNote Event.NoteOn 60] evs @@ -636,17 +666,18 @@    sampler <- Instr.sampledSound --   sampler <- sampledSoundTest2    let sound =-          sampler (Instr.SampledSound (SigSt.replicate chunkSize 100000 0)+          sampler (Instr.SampledSound (SigSt.replicate Option.defaultChunkSize 100000 0)                       (Instr.SamplePositions 0 100000 50000 50000)                       100)    SVL.writeFile "test.f32" $+      arrange vectorChunkSize $       evalState          (let evs =-                 EventListBT.cons (MIDIL.BendModulation 0.01 0.001) 10 evs+                 EventListBT.cons (BM.Cons 0.01 0.001) 10 evs           in  Gen.sequenceCore-                 (arrange vectorChunkSize) channel Gen.errorNoProgram+                 Option.defaultChannel Gen.errorNoProgram                  (Gen.Modulator () return-                     (return . Gen.renderInstrumentIgnoreProgram (sound evs)))) $+                     (return . Gen.renderInstrumentIgnoreProgram (sound evs sampleRate)))) $       let evs = EventList.cons 10 [] evs       in  EventList.cons 10 [makeNote Event.NoteOn 60] evs @@ -655,15 +686,16 @@    arrange <- SigStL.makeArranger    sound <- Instr.softStringFM $/       let evs =-             EventListBT.cons (MIDIL.BendModulation 0.01 0.001) 10 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-             (arrange vectorChunkSize) channel Gen.errorNoProgram+             Option.defaultChannel Gen.errorNoProgram              (Gen.Modulator () return-                 (return . Gen.renderInstrumentIgnoreProgram sound))) $+                 (return . Gen.renderInstrumentIgnoreProgram (sound sampleRate)))) $       let evs = EventList.cons 10 [] evs       in  EventList.cons 10 [makeNote Event.NoteOn 60] evs {-@@ -677,4 +709,19 @@ adsr = do    env <- Instr.adsr    SVL.writeFile "adsr.f32" $-      env 0.2 2 0.15 0.3 0.5 (-0.5) 88200+      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
src/Synthesizer/LLVM/Server/Scalar/Instrument.hs view
@@ -1,199 +1,186 @@ module Synthesizer.LLVM.Server.Scalar.Instrument where  import Synthesizer.LLVM.Server.Common--import qualified Synthesizer.EventList.ALSA.MIDI as Ev- import qualified Synthesizer.LLVM.Frame.Stereo as Stereo--import Synthesizer.Storable.ALSA.MIDI (Instrument, chunkSizesFromLazyTime, )- import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP import qualified Synthesizer.LLVM.Parameterized.Signal as SigP import qualified Synthesizer.LLVM.Storable.Signal as SigStL-import qualified Synthesizer.LLVM.Sample as Sample import qualified Synthesizer.LLVM.Wave as WaveL import Synthesizer.LLVM.CausalParameterized.Process (($<), ($>), ($*), )-import Synthesizer.LLVM.Parameterized.Signal (($#), )  import qualified LLVM.Core as LLVM +import qualified Synthesizer.EventList.ALSA.MIDI as Ev+import Synthesizer.Storable.ALSA.MIDI (chunkSizesFromLazyTime, )+ import qualified Synthesizer.Storable.Signal      as SigSt import qualified Data.StorableVector.Lazy.Pattern as SigStV-import qualified Data.StorableVector.Lazy         as SVL -import Control.Arrow ((<<<), (^<<), (&&&), arr, )-import Control.Applicative (pure, liftA, liftA2, )--import qualified Algebra.RealRing as RealRing-import qualified Algebra.Additive  as Additive+import Control.Arrow ((^<<), arr, )+import Control.Applicative (liftA, liftA2, ) -import NumericPrelude.Numeric (zero, round, )-import Prelude hiding (Real, round, break, )+import NumericPrelude.Numeric (zero, round, (+), )+import Prelude hiding (Real, round, break, (+), )  -pingSig :: SigP.T (Real, Real) (LLVM.Value Real)+pingSig :: SigP.T (SampleRate Real, (Real, Real)) (LLVM.Value Real) pingSig =-   let vel = arr fst-       freq = arr snd+   let vel = number fst+       freq = frequency snd    in  CausalP.envelope-          $< SigP.exponential2 (pure (0.2*sampleRate))+          $< SigP.exponential2 (timeConst 0.2)                 (fmap amplitudeFromVelocity vel)-          $* SigP.osciSimple WaveL.saw zero (freq/sampleRate)+          $* SigP.osciSimple WaveL.saw zero freq -ping :: IO (Real -> Real -> SigSt.T Real)+ping :: IO (SigSt.ChunkSize -> SampleRate Real -> Real -> Real -> SigSt.T Real) ping =-   fmap curry $ fmap ($chunkSize) $ SigP.runChunky pingSig+   fmap (\f chunkSize sr vel freq -> f chunkSize (sr, (vel,freq))) $+   SigP.runChunky pingSig  pingDur :: IO (Instrument Real Real) pingDur =    fmap-      (\sound vel freq dur ->-         sound (chunkSizesFromLazyTime dur) (vel, freq)) $+      (\sound sr vel freq dur ->+         sound (chunkSizesFromLazyTime dur) (sr, (vel, freq))) $    SigP.runChunkyPattern pingSig -pingDurTake :: IO (Instrument Real Real)+pingDurTake :: IO (SigSt.ChunkSize -> Instrument Real Real) pingDurTake =-   fmap (\sound vel freq dur ->+   fmap (\sound chunkSize sr vel freq dur ->       SigStV.take (chunkSizesFromLazyTime dur) $-      sound vel freq) ping+      sound chunkSize sr vel freq) ping -dummy :: Instrument Real Real-dummy =-   \vel freq dur ->+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 -> Real -> Ev.LazyTime -> SigSt.T Real)+   IO (Real -> Real -> SigSt.ChunkSize ->+       SampleRate Real -> Real -> Ev.LazyTime -> SigSt.T Real) pingReleaseEnvelope =    liftA2-      (\pressed release decay rel vel dur ->+      (\pressed release decay rel chunkSize sr vel dur ->          SigStL.continue-            (pressed (chunkSizesFromLazyTime dur) (decay,vel))-            (\x -> release chunkSize (rel,x)))+            (pressed (chunkSizesFromLazyTime dur) (sr, (decay,vel)))+            (\x -> release chunkSize (sr, (rel,x))))       (SigP.runChunkyPattern $-       let decay = arr fst-           velocity = arr snd-       in  SigP.exponential2 (decay*sampleRate)+       let decay = time fst+           velocity = number snd+       in  SigP.exponential2 decay               (amplitudeFromVelocity ^<< velocity))       (SigP.runChunky $-       let release = arr fst-           amplitude = arr snd-       in  (CausalP.take (round ^<< (release*3*sampleRate)) $*-            SigP.exponential2 (release*sampleRate) amplitude))+       let release = time fst+           amplitude = number snd+       in  (CausalP.take (round ^<< (release*3)) $*+            SigP.exponential2 release amplitude)) -pingRelease :: IO (Real -> Real -> Instrument Real Real)+pingRelease :: IO (Real -> Real -> SigSt.ChunkSize -> Instrument Real Real) pingRelease =    liftA2-      (\osc env dec rel vel freq dur ->-         osc freq (env dec rel vel dur))+      (\osc env dec rel chunkSize sr vel freq dur ->+         osc (sr, freq) (env dec rel chunkSize sr vel dur))       (CausalP.runStorableChunky-         (let freq = arr id+         (let freq = frequency id           in  CausalP.envelope $>-              SigP.osciSimple WaveL.saw zero (freq/sampleRate)))+              SigP.osciSimple WaveL.saw zero freq))       pingReleaseEnvelope -pingStereoRelease :: IO (Real -> Real -> Instrument Real (Stereo.T Real))+pingStereoRelease :: IO (Real -> Real -> SigSt.ChunkSize -> Instrument Real (Stereo.T Real)) pingStereoRelease =    liftA2-      (\osc env dec rel vel freq dur ->-         osc freq (env dec rel vel dur))+      (\osc env dec rel chunkSize sr vel freq dur ->+         osc (sr, freq) (env dec rel chunkSize sr vel dur))       (CausalP.runStorableChunky-         (let freq = arr id+         (let freq = frequency id           in  CausalP.envelopeStereo $>-              SigP.zipWithSimple Sample.zipStereo-                 (SigP.osciSimple WaveL.saw zero-                     (0.999*freq/sampleRate))-                 (SigP.osciSimple WaveL.saw zero-                     (1.001*freq/sampleRate))))+              liftA2 Stereo.cons+                 (SigP.osciSimple WaveL.saw zero (0.999*freq))+                 (SigP.osciSimple WaveL.saw zero (1.001*freq))))       pingReleaseEnvelope   -tine :: IO (Real -> Real -> Instrument Real Real)+tine :: IO (Real -> Real -> SigSt.ChunkSize -> Instrument Real Real) tine =    liftA2-      (\osc env dec rel vel freq dur ->-         osc (vel,freq) (env dec rel 0 dur))+      (\osc env dec rel chunkSize sr vel freq dur ->+         osc (sr, (vel,freq)) (env dec rel chunkSize sr 0 dur))       (CausalP.runStorableChunky-         (let freq = arr snd-              vel  = arr fst+         (let freq = frequency snd+              vel  = number fst           in  CausalP.envelope $>                  (CausalP.osciSimple WaveL.approxSine2-                    $> (SigP.constant (freq/sampleRate))+                    $> (SigP.constant freq)                     $* (CausalP.envelope-                          $< SigP.exponential2 (1*sampleRate) (vel+1)-                          $* SigP.osciSimple WaveL.approxSine2 zero-                                (2*freq/sampleRate)))))+                          $< SigP.exponential2 (timeConst 1) (vel+1)+                          $* SigP.osciSimple WaveL.approxSine2 zero (2*freq)))))       pingReleaseEnvelope -tineStereo :: IO (Real -> Real -> Instrument Real (Stereo.T Real))+tineStereo :: IO (Real -> Real -> SigSt.ChunkSize -> Instrument Real (Stereo.T Real)) tineStereo =    liftA2-      (\osc env dec rel vel freq dur ->-         osc (vel,freq) (env dec rel 0 dur))+      (\osc env dec rel chunkSize sr vel freq dur ->+         osc (sr, (vel,freq)) (env dec rel chunkSize sr 0 dur))       (CausalP.runStorableChunky-         (let freq = arr snd-              vel  = arr fst+         (let freq = frequency snd+              vel  = number fst               chanOsci d =                  CausalP.osciSimple WaveL.approxSine2-                    $> SigP.constant (freq*d/sampleRate)+                    $> SigP.constant (freq*d)           in  CausalP.envelopeStereo $>-                 ((CausalP.zipWithSimple Sample.zipStereo <<<-                     chanOsci 0.995 &&& chanOsci 1.005)+                 (liftA2 Stereo.cons+                     (chanOsci 0.995) (chanOsci 1.005)                   $* SigP.envelope-                        (SigP.exponential2 (1*sampleRate) (vel+1))-                        (SigP.osciSimple WaveL.approxSine2 zero-                           (2*freq/sampleRate)))))+                        (SigP.exponential2 (timeConst 1) (vel+1))+                        (SigP.osciSimple WaveL.approxSine2 zero (2*freq)))))       pingReleaseEnvelope    softStringReleaseEnvelope ::-   IO (Real -> Ev.LazyTime -> SigSt.T Real)+   IO (Real -> SampleRate Real -> Real -> Ev.LazyTime -> SigSt.T Real) softStringReleaseEnvelope =-   let attackTime = sampleRate-   in  liftA-          (\env vel dur ->-             let amp = amplitudeFromVelocity vel-                 {--                 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 attackTime $-                    env (chunkSizesFromLazyTime dur) amp-                 release = SigSt.reverse attack-             in  attack `SigSt.append` sustain `SigSt.append` release)-          (let amp = arr id-           in  SigP.runChunkyPattern $-               flip SigP.append (SigP.constant amp) $-               SigP.amplify amp $-               (SigP.parabolaFadeIn $# fromIntegral attackTime))+   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 $+                env (chunkSizesFromLazyTime dur)+                    (attackTimeInt, amplitudeFromVelocity vel)+             release = SigSt.reverse attack+         in  attack `SigSt.append` sustain `SigSt.append` release)+      (let amp = arr snd+           attackTime = arr fst+       in  SigP.runChunkyPattern $+           flip SigP.append (SigP.constant amp) $+           SigP.amplify amp $+           (SigP.parabolaFadeIn (fmap fromIntegral attackTime)))  softString :: IO (Instrument Real (Stereo.T Real)) softString =    liftA2-      (\osc env vel freq dur ->-         osc freq (env vel dur))-      (let freq = arr id+      (\osc env sr vel freq dur ->+         osc (sr, freq) (env 1 sr vel dur))+      (let freq = frequency id            osci d =-              SigP.osciSimple WaveL.saw zero (d * freq / sampleRate)+              SigP.osciSimple WaveL.saw zero (d * freq)        in  CausalP.runStorableChunky $            (CausalP.envelopeStereo $>-              (SigP.zipWithSimple Sample.zipStereo-                 (SigP.mix-                    (osci 1.005)-                    (osci 0.998))-                 (SigP.mix-                    (osci 1.002)-                    (osci 0.995)))))+              (liftA2 Stereo.cons+                 (osci 1.005 + osci 0.998)+                 (osci 1.002 + osci 0.995))))       softStringReleaseEnvelope
src/Synthesizer/LLVM/Server/Scalar/Run.hs view
@@ -1,6 +1,7 @@ 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.Common  import qualified Sound.ALSA.Sequencer.Event as Event@@ -21,59 +22,67 @@ import Synthesizer.LLVM.Parameterized.Signal (($#), )  import qualified Synthesizer.Storable.Signal      as SigSt-import qualified Data.StorableVector.Lazy         as SVL  import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg  import Control.Arrow ((<<<), arr, ) import Control.Monad.Trans.State (evalState, ) -import qualified Algebra.Additive  as Additive- import NumericPrelude.Numeric (zero, (*>), ) import Prelude hiding (Real, break, )  +sampleRate :: Num a => Option.T -> a+sampleRate opt =+   case Option.sampleRate opt of+      SampleRate sr -> sr+ {-# INLINE withMIDIEvents #-} withMIDIEvents ::-   (Double -> Double -> a -> IO b) ->+   Option.T ->+   (Option.T -> Double -> a -> IO b) ->    (EventList.T Ev.StrictTime [Event.T] -> a) -> IO b-withMIDIEvents action proc =-   let rate = sampleRate-       per  = periodTime-   in  Ev.withMIDIEvents per rate $-       action per rate . proc+withMIDIEvents opt action proc =+   let rate = sampleRate opt+   in  do+          putStrLn startMessage+          Ev.withMIDIEvents+             (Option.clientName opt) (Option.periodTime opt) rate $+             action opt rate . proc    pitchBend :: IO () pitchBend = do+   opt <- Option.get    osc <-       SigP.runChunky          ((CausalP.osciSimple WaveL.triangle $<# (zero::Real))              $* piecewiseConstant (arr id))-   withMIDIEvents play $+   withMIDIEvents opt play $       (id :: SigSt.T Real -> SigSt.T Real) .-      osc chunkSize .-      evalState (PC.pitchBend channel 2 (880/sampleRate::Real))+      osc (Option.chunkSize opt) .+      evalState (PC.pitchBend (Option.channel opt) 2 (880/sampleRate opt::Real))   frequencyModulation :: IO () frequencyModulation = do+   opt <- Option.get    osc <-       SigP.runChunky          (((CausalP.osciSimple WaveL.triangle $<# (zero::Real))-              <<< (MIDIL.frequencyFromBendModulation $# (10/sampleRate::Real)))-           $* piecewiseConstant (arr (transposeModulation 880)))-   withMIDIEvents play $+              <<< (MIDIL.frequencyFromBendModulation $# (10/sampleRate opt::Real)))+           $* piecewiseConstant (arr (transposeModulation (Option.sampleRate opt) 880)))+   withMIDIEvents opt play $       (id :: SigSt.T Real -> SigSt.T Real) .-      osc chunkSize .-      evalState (PC.bendWheelPressure channel 2 0.04 (0.03::Real))+      osc (Option.chunkSize opt) .+      evalState (PC.bendWheelPressure (Option.channel opt) 2 0.04 (0.03::Real))    keyboard :: IO () keyboard = do+   opt <- Option.get --   sound <- Instr.pingDur {-    sound <-@@ -83,41 +92,56 @@    sound <- Instr.pingRelease $/ 0.4 $/ 0.1    amp <- CausalP.runStorableChunky (CausalP.amplify $# 0.2)    arrange <- SigStL.makeArranger-   withMIDIEvents play $+   withMIDIEvents opt play $       (amp () :: SigSt.T Real -> SigSt.T Real) .-      evalState (Gen.sequence (arrange chunkSize) channel sound)+      arrange (Option.chunkSize opt) .+      evalState+         (Gen.sequence+            (Option.channel opt)+            (sound (Option.chunkSize opt) (Option.sampleRate opt)))  keyboardStereo :: IO () keyboardStereo = do+   opt <- Option.get    sound <- Instr.pingStereoRelease $/ 0.4 $/ 0.1    amp <- CausalP.runStorableChunky (CausalP.amplifyStereo $# 0.2)    arrange <- SigStL.makeArranger-   withMIDIEvents play $+   withMIDIEvents opt play $       (amp () :: SigSt.T (Stereo.T Real) -> SigSt.T (Stereo.T Real)) .-      evalState (Gen.sequence (arrange chunkSize) channel sound)+      arrange (Option.chunkSize opt) .+      evalState+         (Gen.sequence+            (Option.channel opt)+            (sound (Option.chunkSize opt) (Option.sampleRate opt)))  keyboardMulti :: IO () keyboardMulti = do+   opt <- Option.get    png <- Instr.pingDur-   pngRel <- Instr.pingRelease $/ 0.4 $/ 0.1-   tin <- Instr.tine $/ 0.4 $/ 0.1+   pngRel <- Instr.pingRelease $/ 0.4 $/ 0.1 $/ Option.chunkSize opt+   tin <- Instr.tine $/ 0.4 $/ 0.1 $/ Option.chunkSize opt    arrange <- SigStL.makeArranger-   withMIDIEvents play $---      playALSA (Bld.put :: Int16 -> Bld.Builder Int16) (sampleRate::Real) .+   withMIDIEvents opt play $+--      playALSA (Bld.put :: Int16 -> Bld.Builder Int16) (sampleRate opt::Real) .       SigSt.map (0.2*) .-      evalState (Gen.sequenceMultiProgram (arrange chunkSize) channel+      arrange (Option.chunkSize opt) .+      evalState (Gen.sequenceMultiProgram (Option.channel opt)          (VoiceMsg.toProgram 2)-         [png, pngRel, tin])+         (map (\sound -> sound $ Option.sampleRate opt) $+              [png, pngRel, tin]))  keyboardStereoMulti :: IO () keyboardStereoMulti = do-   png <- Instr.pingStereoRelease $/ 0.4 $/ 0.1-   tin <- Instr.tineStereo $/ 0.4 $/ 0.1+   opt <- Option.get+   png <- Instr.pingStereoRelease $/ 0.4 $/ 0.1 $/ Option.chunkSize opt+   tin <- Instr.tineStereo $/ 0.4 $/ 0.1 $/ Option.chunkSize opt    str <- Instr.softString    arrange <- SigStL.makeArranger-   withMIDIEvents play $---      playALSA (Bld.put :: Int16 -> Bld.Builder Int16) (sampleRate::Real) .+   withMIDIEvents opt play $+--      playALSA (Bld.put :: Int16 -> Bld.Builder Int16) (sampleRate opt::Real) .       SigSt.map ((0.2::Real)*>) .-      evalState (Gen.sequenceMultiProgram (arrange chunkSize) channel+      arrange (Option.chunkSize opt) .+      evalState (Gen.sequenceMultiProgram (Option.channel opt)          (VoiceMsg.toProgram 1)-         [png, tin, str])+         (map (\sound -> sound $ Option.sampleRate opt) $+              [png, tin, str]))
src/Synthesizer/LLVM/Server/Scalar/Test.hs view
@@ -1,6 +1,7 @@ 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 Synthesizer.LLVM.Server.Scalar.Run (withMIDIEvents, ) import Synthesizer.LLVM.Server.Common @@ -22,12 +23,15 @@ import Control.Arrow (arr, ) import Control.Monad.Trans.State (evalState, ) -import qualified Algebra.Additive  as Additive- import NumericPrelude.Numeric (zero, ) import Prelude hiding (Real, )  +sampleRate :: Real+sampleRate =+   Option.defaultSampleRate++ pitchBend0 :: IO () pitchBend0 = do    osc <-@@ -36,25 +40,27 @@              $* piecewiseConstant (arr id))    SVL.writeFile "test.f32" $       (id :: SigSt.T Real -> SigSt.T Real) .-      osc chunkSize .-      evalState (PC.pitchBend channel 2 (880/sampleRate::Real)) $+      osc Option.defaultChunkSize .+      evalState (PC.pitchBend Option.defaultChannel 2 (880/sampleRate)) $       let evs = EventList.cons 100 [] evs       in  EventList.cons 0 [] evs  pitchBend1 :: IO () pitchBend1 = do+   opt <- Option.get    osc <-       SigP.runChunky          ((CausalP.osciSimple WaveL.triangle $<# (zero::Real))              $* piecewiseConstant (arr id))-   withMIDIEvents (\ _period _rate -> SVL.writeFile "test.f32") $+   withMIDIEvents opt (\ _opt _rate -> SVL.writeFile "test.f32") $       (id :: SigSt.T Real -> SigSt.T Real) .-      osc chunkSize .-      evalState (PC.pitchBend channel 2 (880/sampleRate::Real))+      osc Option.defaultChunkSize .+      evalState (PC.pitchBend Option.defaultChannel 2 (880/sampleRate))  pitchBend2 :: IO ()-pitchBend2 =-   withMIDIEvents (\ _period _rate -> print) id+pitchBend2 = do+   opt <- Option.get+   withMIDIEvents opt (\ _opt _rate -> print) id   @@ -63,13 +69,14 @@ --   arrange <- SigStL.makeArranger --   sound <- Instr.softString --   sound <- Instr.softStringReleaseEnvelope---   sound <- Instr.pingReleaseEnvelope $/ 1+--   sound <- Instr.pingReleaseEnvelope $/ 1 $/ Option.defaultChunkSize --   sound <- Instr.pingDur --   sound <- Instr.pingDurTake-   let sound = Instr.dummy+   let sound = Instr.dummy Option.defaultChunkSize (SampleRate sampleRate)    SVL.writeFile "test.f32" $+      CutSt.arrange Option.defaultChunkSize $       evalState-         (do Gen.sequence (CutSt.arrange chunkSize) channel sound) $+         (do Gen.sequence Option.defaultChannel sound) $       let evs t =              EventList.cons t [makeNote Event.NoteOn  60] $              EventList.cons t [makeNote Event.NoteOff 60] $
src/Synthesizer/LLVM/Simple/Signal.hs view
@@ -1,18 +1,15 @@ {-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ForeignFunctionInterface #-} module Synthesizer.LLVM.Simple.Signal where -import qualified LLVM.Extra.Representation as Rep import qualified Synthesizer.LLVM.Wave as Wave-import qualified Synthesizer.LLVM.Sample as Sample+import qualified Synthesizer.LLVM.Frame as Frame import qualified Synthesizer.LLVM.Execution as Exec+import qualified LLVM.Extra.ForeignPtr as ForeignPtr+import qualified LLVM.Extra.Memory as Memory import qualified LLVM.Extra.ScalarOrVector as SoV import qualified LLVM.Extra.MaybeContinuation as Maybe @@ -26,22 +23,25 @@ import qualified LLVM.Extra.Arithmetic as A import LLVM.Extra.Arithmetic (advanceArrayElementPtr, ) import LLVM.Extra.Control (whileLoop, ifThen, )+import LLVM.Extra.Class (MakeValueTuple, Undefined, undefTuple, ) -import LLVM.Core+import LLVM.Core as LLVM import LLVM.Util.Loop (Phi, )  import Control.Monad (liftM2, liftM3, )+import Control.Applicative (Applicative, pure, (<*>), liftA2, ) +import qualified Number.Ratio as Ratio import qualified Algebra.Transcendental as Trans import qualified Algebra.Field as Field import qualified Algebra.Ring as Ring+import qualified Algebra.Additive as Additive  import Data.Word (Word32, ) import Foreign.Storable.Tuple () import Foreign.Storable (Storable, ) import Foreign.Marshal.Array (advancePtr, )-import qualified Foreign.Marshal.Array as Array-import qualified Foreign.Marshal.Alloc as Alloc+import qualified Synthesizer.LLVM.Alloc as Alloc import Foreign.ForeignPtr           (unsafeForeignPtrToPtr, touchForeignPtr, withForeignPtr, ) import Foreign.Ptr (FunPtr, nullPtr, )@@ -64,7 +64,7 @@ -} data T a =    forall state packed size ioContext.-      (Rep.Memory state packed, IsSized packed size) =>+      (Memory.C state packed, IsSized packed size) =>       Cons (forall r c.             (Phi c) =>             ioContext ->@@ -83,7 +83,7 @@                -- finalization from IO monad, also run within unsafePerformIO  simple ::-   (Rep.Memory state packed, IsSized packed size) =>+   (Memory.C state packed, IsSized packed size) =>    (forall r c.     state -> Maybe.T r c (a, state)) ->    (forall r. CodeGenFunction r state) ->@@ -108,7 +108,7 @@       createIOContext deleteIOContext  mapAccum ::-   (Rep.Memory s struct, IsSized struct sa) =>+   (Memory.C s struct, IsSized struct sa) =>    (forall r. a -> s -> CodeGenFunction r (b,s)) ->    (forall r. CodeGenFunction r s) ->    T a -> T b@@ -148,17 +148,43 @@  zip ::    T a -> T b -> T (a,b)-zip = zipWith (\a b -> return (a,b))+zip = liftA2 (,)  +instance Functor T where+   fmap f = map (return . f)+ {- |+ZipList semantics+-}+instance Applicative T where+   pure x = simple (\() -> return (x, ())) (return ())+   (<*>) = zipWith (\f a -> return (f a))++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+++{- | Stretch signal in time by a certain factor. -} interpolateConstant ::-   (Rep.Memory a struct, IsSized struct size,+   (Memory.C a struct, IsSized struct size,+    Memory.FirstClass b bm, IsSized b bsize, IsSized bm bmsize,     Ring.C b,-    IsFloating b, CmpRet b Bool,-    IsConst b, IsFirstClass b, IsSized b sb) =>+    IsFloating b, CmpRet b Bool, IsConst b) =>    b -> T a -> T a interpolateConstant k       (Cons next start createIOContext deleteIOContext) =@@ -188,42 +214,37 @@   mix ::-   (IsArithmetic a) =>-   T (Value a) -> T (Value a) -> T (Value a)-mix = zipWith Sample.mixMono--mixStereo ::-   (IsArithmetic a) =>-   T (Stereo.T (Value a)) -> T (Stereo.T (Value a)) -> T (Stereo.T (Value a))-mixStereo = zipWith Sample.mixStereo+   (A.Additive a) =>+   T a -> T a -> T a+mix = zipWith Frame.mix   envelope ::-   (IsArithmetic a) =>-   T (Value a) -> T (Value a) -> T (Value a)-envelope = zipWith Sample.amplifyMono+   (A.PseudoRing a) =>+   T a -> T a -> T a+envelope = zipWith Frame.amplifyMono  envelopeStereo ::-   (IsArithmetic a) =>-   T (Value a) -> T (Stereo.T (Value a)) -> T (Stereo.T (Value a))-envelopeStereo = zipWith Sample.amplifyStereo+   (A.PseudoRing a) =>+   T a -> T (Stereo.T a) -> T (Stereo.T a)+envelopeStereo = zipWith Frame.amplifyStereo  amplify ::    (IsArithmetic a, IsConst a) =>    a -> T (Value a) -> T (Value a) amplify x =-   map (Sample.amplifyMono (valueOf x))+   map (Frame.amplifyMono (valueOf x))  amplifyStereo ::    (IsArithmetic a, IsConst a) =>    a -> T (Stereo.T (Value a)) -> T (Stereo.T (Value a)) amplifyStereo x =-   map (Sample.amplifyStereo (valueOf x))+   map (Frame.amplifyStereo (valueOf x))    iterate ::-   (IsFirstClass a, IsSized a s, IsConst a) =>+   (Memory.FirstClass a am, IsSized a asize, IsSized am amsize, IsConst a) =>    (forall r. Value a -> CodeGenFunction r (Value a)) ->    Value a -> T (Value a) iterate f initial =@@ -232,15 +253,15 @@       (return initial)  exponential2 ::-   (Trans.C a,-    IsFirstClass a, IsSized a s, IsArithmetic a, IsConst a) =>+   (Trans.C a, IsArithmetic a,+    Memory.FirstClass a am, IsSized a asize, IsSized am amsize, IsConst a) =>    a -> a -> T (Value a) exponential2 halfLife =    iterate (\y -> A.mul y (valueOf (0.5 ** recip halfLife))) . valueOf   osciPlain ::-   (IsFirstClass t, IsSized t size,+   (Memory.FirstClass t tm, IsSized t tsize, IsSized tm tmsize,     SoV.Fraction t, IsConst t) =>    (forall r. Value t -> CodeGenFunction r y) ->    Value t -> Value t -> T y@@ -250,7 +271,7 @@    phase  osci ::-   (IsFirstClass t, IsSized t size,+   (Memory.FirstClass t tm, IsSized t tsize, IsSized tm tmsize,     SoV.Fraction t, IsConst t) =>    (forall r. Value t -> CodeGenFunction r y) ->    t -> t -> T y@@ -259,7 +280,7 @@  osciSaw ::    (Ring.C a0, IsConst a0, SoV.Replicate a0 a,-    IsFirstClass a, IsSized a size,+    Memory.FirstClass a am, IsSized a asize, IsSized am amsize,     SoV.Fraction a, IsConst a) =>    a -> a -> T (Value a) osciSaw = osci Wave.saw@@ -267,21 +288,21 @@   fromStorableVector ::-   (Storable a, MakeValueTuple a value, Rep.Memory value struct) =>+   (Storable a, MakeValueTuple a value, Memory.C value struct) =>    SV.Vector a ->    T value fromStorableVector xs =    let (fp,s,l) = SVB.toForeignPtr xs    in  Cons           (\_ (p0,l0) -> do-             cont <- Maybe.lift $ A.icmp IntUGT l0 (valueOf 0)+             cont <- Maybe.lift $ A.cmp CmpGT l0 (valueOf 0)              Maybe.withBool cont $ do-                y1 <- Rep.load p0+                y1 <- Memory.load p0                 p1 <- advanceArrayElementPtr p0                 l1 <- A.dec l0                 return (y1,(p1,l1)))           (const $ return-             (valueOf (Rep.castStorablePtr $ unsafeForeignPtrToPtr fp `advancePtr` s),+             (valueOf (Memory.castStorablePtr $ unsafeForeignPtrToPtr fp `advancePtr` s),               valueOf (fromIntegral l :: Word32)))           -- keep the foreign ptr alive           (return fp)@@ -293,7 +314,7 @@ and advances to the next chunk in the sequence. -} fromStorableVectorLazy ::-   (Storable a, MakeValueTuple a value, Rep.Memory value struct) =>+   (Storable a, MakeValueTuple a value, Memory.C value struct) =>    SVL.Vector a ->    T value fromStorableVectorLazy sig =@@ -301,14 +322,14 @@       (\(stable, lenPtr) (buffer0,length0) -> do          (buffer1,length1) <- Maybe.lift $ do             nextChunkFn <- staticFunction ChunkIt.nextCallBack-            needNext <- A.icmp IntEQ length0 (valueOf 0)+            needNext <- A.cmp CmpEQ length0 (valueOf 0)             ifThen needNext (buffer0,length0)                (liftM2 (,)                    (call nextChunkFn (valueOf stable) (valueOf lenPtr))                    (load (valueOf lenPtr)))-         valid <- Maybe.lift $ A.icmp IntNE buffer1 (valueOf nullPtr)+         valid <- Maybe.lift $ A.cmp CmpNE buffer1 (valueOf nullPtr)          Maybe.withBool valid $ do-            x <- Rep.load buffer1+            x <- Memory.load buffer1             buffer2 <- advanceArrayElementPtr buffer1             length2 <- A.dec length1             return (x, (buffer2,length2)))@@ -321,7 +342,7 @@  {- compile ::-   (Rep.Memory value struct) =>+   (Memory.C value struct) =>    T value ->    CodeGenModule (Function (Word32 -> Ptr struct -> IO Word32)) -}@@ -334,7 +355,7 @@ or compile once. -} render ::-   (Storable a, MakeValueTuple a value, Rep.Memory value struct) =>+   (Storable a, MakeValueTuple a value, Memory.C value struct) =>    Int -> T value -> SV.Vector a render len (Cons next start createIOContext deleteIOContext) =    unsafePerformIO $@@ -342,15 +363,15 @@    SVB.createAndTrim len $ \ ptr ->       do fill <-             Exec.runFunction $-            createFunction ExternalLinkage $ \ size bPtr -> do+            createNamedFunction ExternalLinkage "fillsignalblock" $ \ size bPtr -> do                s <- start ioContext                (pos,_) <- Maybe.arrayLoop size bPtr s $ \ ptri s0 -> do                   (y,s1) <- next ioContext s0-                  Maybe.lift $ Rep.store y ptri+                  Maybe.lift $ Memory.store y ptri                   return s1                ret (pos :: Value Word32)          fmap (fromIntegral :: Word32 -> Int) $-            fill (fromIntegral len) (Rep.castStorablePtr ptr)+            fill (fromIntegral len) (Memory.castStorablePtr ptr)   foreign import ccall safe "dynamic" derefChunkPtr ::@@ -358,8 +379,8 @@   compileChunky ::-   (Rep.Memory value struct,-    Rep.Memory state stateStruct,+   (Memory.C value struct,+    Memory.C state stateStruct,     IsSized stateStruct stateSize) =>    (forall r.     state -> Maybe.T r (Value Bool, state) (value, state)) ->@@ -371,36 +392,35 @@ compileChunky next start =    Exec.compileModule $       liftM3 (,,)-         (createFunction ExternalLinkage $+         (createNamedFunction ExternalLinkage "startsignal" $           do-             -- FIXME: size computation in LLVM currently does not work for structs!-             pptr <- Rep.malloc-             flip Rep.store pptr =<< start+             pptr <- LLVM.malloc+             flip Memory.store pptr =<< start              ret pptr) {- for debugging: allocation with initialization makes type inference difficult-         (createFunction ExternalLinkage $+         (createNamedFunction ExternalLinkage "startsignal" $           do              pptr <- malloc              let retn :: CodeGenFunction r state -> Value (Ptr state) -> CodeGenFunction (Ptr state) ()                  retn _ ptr = ret ptr              retn undefined pptr) -}-         (createFunction ExternalLinkage $-          \ pptr -> Rep.free pptr >> ret ())-         (createFunction ExternalLinkage $+         (createNamedFunction ExternalLinkage "stopsignal" $+          \ pptr -> LLVM.free pptr >> ret ())+         (createNamedFunction ExternalLinkage "fillsignal" $           \ sptr loopLen ptr -> do-             sInit <- Rep.load sptr+             sInit <- Memory.load sptr              (pos,sExit) <- Maybe.arrayLoop loopLen ptr sInit $               \ ptri s0 -> do                 (y,s1) <- next s0-                Maybe.lift $ Rep.store y ptri+                Maybe.lift $ Memory.store y ptri                 return s1-             Rep.store sExit sptr+             Memory.store sExit sptr              ret (pos :: Value Word32))   runChunky ::-   (Storable a, MakeValueTuple a value, Rep.Memory value struct) =>+   (Storable a, MakeValueTuple a value, Memory.C value struct) =>    SVL.ChunkSize -> T value -> IO (SVL.Vector a) runChunky (SVL.ChunkSize size)      (Cons next start createIOContext deleteIOContext) = do@@ -408,9 +428,9 @@    (startFunc, stopFunc, fill) <-       compileChunky (next ioContext) (start ioContext) -   statePtr <- Rep.newForeignPtrInit stopFunc startFunc+   statePtr <- ForeignPtr.newInit stopFunc startFunc    -- for explanation see Causal.Process-   ioContextPtr <- Rep.newForeignPtr (deleteIOContext ioContext) False+   ioContextPtr <- ForeignPtr.new (deleteIOContext ioContext) False     let go =          unsafeInterleaveIO $ do@@ -419,7 +439,7 @@                SVB.createAndTrim size $                fmap (fromIntegral :: Word32 -> Int) .                derefChunkPtr fill sptr (fromIntegral size) .-               Rep.castStorablePtr+               Memory.castStorablePtr             touchForeignPtr ioContextPtr             (if SV.length v > 0                then fmap (v:)@@ -430,7 +450,7 @@    fmap SVL.fromChunks go  renderChunky ::-   (Storable a, MakeValueTuple a value, Rep.Memory value struct) =>+   (Storable a, MakeValueTuple a value, Memory.C value struct) =>    SVL.ChunkSize -> T value -> SVL.Vector a renderChunky size sig =    unsafePerformIO (runChunky size sig)
src/Synthesizer/LLVM/Simple/Value.hs view
@@ -4,32 +4,52 @@ {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-}-module Synthesizer.LLVM.Simple.Value where+module Synthesizer.LLVM.Simple.Value (+   T, decons,+   twoPi,+   lift0, lift1, lift2,+   constantValue, constant,+   Flatten(flatten, unfold), flattenTraversable, unfoldFunctor,+   ) where  import qualified LLVM.Extra.ScalarOrVector as SoV- import qualified LLVM.Extra.Arithmetic as A -import LLVM.Core hiding (zero, )+import LLVM.Core+   (CodeGenFunction,+    Value, valueOf, CmpRet,+    IsArithmetic, IsConst, IsType, IsFloating, ) import qualified LLVM.Core as LLVM-import qualified LLVM.Util.Arithmetic as Arith  import qualified Synthesizer.Basic.Phase as Phase +import qualified Data.Vault as Vault+import qualified Control.Monad.Trans.Class as MT+import qualified Control.Monad.Trans.State as MS import Control.Monad (liftM2, liftM3, ) +import qualified Synthesizer.LLVM.Frame as Frame import qualified Synthesizer.LLVM.Frame.Stereo as Stereo +-- import qualified Algebra.NormedSpace.Maximum   as NormedMax+import qualified Algebra.NormedSpace.Euclidean as NormedEuc+import qualified Algebra.NormedSpace.Sum       as NormedSum+ import qualified Algebra.Transcendental as Trans import qualified Algebra.Algebraic as Algebraic import qualified Algebra.RealRing as RealRing+import qualified Algebra.Absolute as Absolute import qualified Algebra.Module as Module import qualified Algebra.Field as Field import qualified Algebra.Ring as Ring import qualified Algebra.Additive as Additive +import qualified Number.Complex as Complex+ import qualified Data.Traversable as Trav +import System.IO.Unsafe (unsafePerformIO, )+ import NumericPrelude.Numeric import NumericPrelude.Base @@ -48,42 +68,58 @@ >    t -> t -> T (Value y)  -}-newtype T a = Cons {decons :: forall r. Arith.TValue r a}+newtype T a = Cons {code :: forall r. Compute r (Value a)} +decons :: T a -> (forall r. LLVM.CodeGenFunction r (Value a))+decons value =+   MS.evalStateT (code value) Vault.empty+++type Compute r a =+   MS.StateT Vault.Vault (LLVM.CodeGenFunction r) a++consUnique :: (forall r. Compute r (Value a)) -> T a+consUnique code0 =+   unsafePerformIO $+   fmap (consKey code0) Vault.newKey++consKey :: (forall r. Compute r (Value a)) -> Vault.Key (Value a) -> T a+consKey code0 key =+   Cons (do+      ma <- MS.gets (Vault.lookup key)+      case ma of+         Just a -> return a+         Nothing -> do+            a <- code0+            MS.modify (Vault.insert key a)+            return a)+ {- | We do not require a numeric prelude superclass, thus also LLVM only types like vectors are instances. -}-instance (IsArithmetic a, IsConst a) => Additive.C (T a) where-   zero = constantValue (value LLVM.zero)-   (+) = binop add-   (-) = binop sub-   negate (Cons x) = Cons (neg =<< x)+instance (IsArithmetic a, IsType a) => Additive.C (T a) where+   zero = constantValue (LLVM.value LLVM.zero)+   (+) = lift2 A.add+   (-) = lift2 A.sub+   negate = lift1 A.neg -instance (Ring.C a, IsArithmetic a, IsConst a) =>+instance (IsArithmetic a, SoV.IntegerConstant a) =>       Ring.C (T a) where-   one = constant one-   (*) = binop mul-   fromInteger = constant . fromInteger+   one = constantValue (A.fromInteger' 1)+   (*) = lift2 A.mul+   fromInteger = constantValue . A.fromInteger'  {--Two instance declarations are enough for Module here.+This instance is enough for Module here. The difference to Module instances on Haskell tuples is, that LLVM vectors cannot be nested. -}-instance (Ring.C a, IsArithmetic a, IsConst a) =>-      Module.C (T a) (T a) where-   (*>) = (*)--instance (Ring.C a, IsArithmetic a, IsConst a, IsPrimitive a, IsPowerOf2 n) =>-      Module.C (T a) (T (Vector n a)) where-   (Cons a) *> (Cons v) = Cons (do-         a0 <- a-         a1 <- SoV.replicate a0-         A.mul a1 =<< v-      )+instance (SoV.PseudoModule a v, SoV.IntegerConstant a) =>+      Module.C (T a) (T v) where+   (*>) = lift2 SoV.scale -instance (Ring.C a, IsArithmetic a, IsConst a) => Enum (T a) where+instance (IsArithmetic a, SoV.IntegerConstant a) => Enum (T a) where    succ x = x + one    pred x = x - one    fromEnum _ = error "CodeGenFunction Value: fromEnum"@@ -94,25 +130,28 @@    toRational _ = error "CodeGenFunction Value: toRational"  instance (Cmp a b, Num a, IsConst a, IsInteger a) => Integral (T a) where-   quot = binop (if (isSigned (undefined :: a)) then sdiv else udiv)-   rem  = binop (if (isSigned (undefined :: a)) then srem else urem)+   quot = lift2 idiv+   rem  = lift2 irem    quotRem x y = (quot x y, rem x y)    toInteger _ = error "CodeGenFunction Value: toInteger" -} -instance (Field.C a, IsConst a, IsFloating a) => Field.C (T a) where-   (/) = binop fdiv-   fromRational' = constant . fromRational'+instance (IsFloating a, SoV.RationalConstant a) => Field.C (T a) where+   (/) = lift2 A.fdiv+   fromRational' =+      constantValue . A.fromRational' . fromRational'  {- instance (Cmp a b, Fractional a, IsConst a, IsFloating a) => RealFrac (T a) where    properFraction _ = error "CodeGenFunction Value: properFraction" -} -instance (Algebraic.C a, IsConst a, IsFloating a) => Algebraic.C (T a) where+instance (IsFloating a, SoV.RationalConstant a) => Algebraic.C (T a) where    sqrt = lift1 A.sqrt+   root n x = lift2 A.pow x (1 / fromInteger n)+   x^/r = lift2 A.pow x (fromRational' r) -instance (Trans.C a, IsConst a, IsFloating a) => Trans.C (T a) where+instance (IsFloating a, SoV.RationalConstant a, Trans.C a) => Trans.C (T a) where    pi = constant pi    sin = lift1 A.sin    cos = lift1 A.cos@@ -134,46 +173,77 @@   twoPi ::-   (Trans.C a, IsConst a, IsFloating a) =>+   (IsFloating a, IsConst a, Trans.C a) =>    T a-twoPi = 2*pi+twoPi = constant (2*pi) {- twoPi ::    (Cmp a b, P.Floating a, IsConst a, IsFloating a) =>-   Arith.TValue r a+   Compute r a twoPi = P.fromInteger 2 P.* P.pi -} +instance (SoV.Real a, SoV.IntegerConstant a, CmpRet a Bool) =>+      Absolute.C (T a) where+   abs = lift1 A.abs+   signum = lift1 Frame.signum +{-+For useful instances with different scalar and vector type,+we would need a more flexible superclass.+-}+instance (SoV.Real a, SoV.IntegerConstant a, CmpRet a Bool,+          SoV.PseudoModule a a) =>+      NormedSum.C (T a) (T a) where+   norm = lift1 A.abs++instance (SoV.Real a, SoV.IntegerConstant a, CmpRet a Bool,+          SoV.PseudoModule a a) =>+      NormedEuc.Sqr (T a) (T a) where+   normSqr = lift1 A.square++instance+   (Algebraic.C a, NormedEuc.Sqr (T a) (T v), SoV.RationalConstant a, IsFloating a) =>+      NormedEuc.C (T a) (T v) where+   norm = NormedEuc.defltNorm++{-+instance (Ring.C a, IsArithmetic a, IsConst a, CmpRet a Bool) =>+      NormedMax.C (T a) (T a) where+   norm = lift1 A.abs+-}+++lift0 ::+   (forall r. CodeGenFunction r (Value a)) ->+   T a+lift0 f =+   consUnique $ MT.lift $ f+ lift1 ::    (forall r. Value a -> CodeGenFunction r (Value b)) ->    T a -> T b lift1 f x =-   Cons $ f =<< decons x+   consUnique $ MT.lift . f =<< code x  lift2 ::    (forall r. Value a -> Value b -> CodeGenFunction r (Value c)) ->    T a -> T b -> T c lift2 f x y =-   Cons $ uncurry f =<< liftM2 (,) (decons x) (decons y)+   consUnique $ do+      xv <- code x+      yv <- code y+      MT.lift $ f xv yv   constantValue :: Value a -> T a constantValue x =-   Cons (return x)+   consUnique (return x)  constant :: (IsConst a) => a -> T a constant = constantValue . valueOf -binop ::-   (forall r. Value a -> Value b -> Arith.TValue r c) ->-   T a -> T b -> T c-binop op x y = Cons (do-   x' <- decons x-   y' <- decons y-   op x' y') - class Flatten value register | value -> register where    flatten :: value -> CodeGenFunction r register    unfold :: register -> value@@ -207,14 +277,16 @@  instance Flatten v r =>       Flatten (Stereo.T v) (Stereo.T r) where+   flatten = flattenTraversable+   unfold = unfoldFunctor++instance Flatten v r =>+      Flatten (Complex.T v) (Complex.T r) where    flatten s =-      liftM2 Stereo.cons-         (flatten $ Stereo.left s)-         (flatten $ Stereo.right s)-   unfold s =-      Stereo.cons-         (unfold $ Stereo.left s)-         (unfold $ Stereo.right s)+      liftM2 (Complex.+:)+         (flatten $ Complex.real s)+         (flatten $ Complex.imag s)+   unfold = unfoldFunctor  instance    (RealRing.C v, Flatten v r) =>@@ -226,7 +298,7 @@       Phase.fromRepresentative $ unfold s  -instance (IsConst a) => Flatten (T a) (Value a) where+instance Flatten (T a) (Value a) where    flatten = decons    unfold  = constantValue instance Flatten () () where
src/Synthesizer/LLVM/Simple/Vanilla.hs view
@@ -9,7 +9,7 @@ module Synthesizer.LLVM.Simple.Vanilla where  import qualified Synthesizer.LLVM.Simple.Signal as Sig-import qualified LLVM.Extra.Representation as Rep+import qualified LLVM.Extra.Memory as Memory import qualified Synthesizer.LLVM.Simple.Value as Value import qualified LLVM.Extra.ScalarOrVector as SoV import qualified LLVM.Extra.MaybeContinuation as Maybe@@ -40,7 +40,7 @@   iterateVal ::-   (IsFirstClass a, IsSized a size) =>+   (Memory.FirstClass a am, IsSized a asize, IsSized am amsize) =>    (Value.T a -> Value.T a) ->    Value.T a -> Sig.T (Value.T a) iterateVal f initial =@@ -52,7 +52,7 @@       (Value.decons initial)  iterate ::-   (Value.Flatten a reg, Rep.Memory reg packed, IsSized packed size) =>+   (Value.Flatten a reg, Memory.C reg packed, IsSized packed size) =>    (a -> a) ->    (a -> Sig.T a) iterate f initial =@@ -73,7 +73,7 @@  osciReg ::    (RealRing.C (Value.T t),-    IsFirstClass t, IsSized t size,+    Memory.FirstClass t tm, IsSized t tsize, IsSized tm tmsize,     SoV.Fraction t, IsConst t,     IsFirstClass y) =>    Wave.T (Value.T t) (Value.T y) ->@@ -86,7 +86,7 @@  osciVal ::    (RealRing.C (Value.T t),-    IsFirstClass t, IsSized t size,+    Memory.FirstClass t tm, IsSized t tsize, IsSized tm tmsize,     SoV.Fraction t, IsConst t) =>    Wave.T (Value.T t) y ->    Value.T t -> Value.T t -> Sig.T y@@ -97,12 +97,12 @@ incPhaseVal ::    (SoV.Fraction a, IsArithmetic a) =>    Value.T a -> Value.T a -> Value.T a-incPhaseVal = Value.binop SoV.incPhase+incPhaseVal = Value.lift2 SoV.incPhase  osci ::    (RealRing.C t,     Value.Flatten t reg,-    Rep.Memory reg struct, IsSized struct size,+    Memory.C reg struct, IsSized struct size,     SoV.Fraction t, IsConst t) =>    Wave.T t y ->    Phase.T t -> t -> Sig.T y
+ src/Synthesizer/LLVM/Storable/Process.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{- |+Functions on lazy storable vectors that are implemented using LLVM.+-}+module Synthesizer.LLVM.Storable.Process (+   makeArranger,+   continuePacked,+   ) where++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 Number.NonNegative as NonNeg++import qualified LLVM.Extra.Arithmetic as A+import qualified LLVM.Extra.Memory as Memory+import qualified LLVM.Core as LLVM+import LLVM.Extra.Class (MakeValueTuple, )+import qualified Data.TypeLevel.Num as TypeNum++import qualified Control.Arrow as Arr+import qualified Data.Foldable as Fold+import Foreign.Storable (Storable, )+import Foreign.Marshal.Array (advancePtr, )++import System.IO.Unsafe (unsafePerformIO, )++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 ::+   (Storable a, A.Additive value,+    MakeValueTuple a value, Memory.C value struct,+    Arr.Arrow arrow) =>+   IO (arrow+          (EventListTT.T NonNeg.Int (SV.Vector a))+          (SV.Vector a))+makeArranger = do+   mixer <- SigStL.makeMixer undefined+   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  unsafePerformIO $+          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 b, LLVM.IsPrimitive b, TypeNum.Pos n) =>+   PIO.T a (SV.Vector (LLVM.Vector n b)) ->+   (b -> PIO.T a (SV.Vector (LLVM.Vector n b))) ->+   PIO.T a (SV.Vector (LLVM.Vector n b))+continuePacked proc0 proc1 =+   PIO.continueChunk proc0+      (proc1 Arr.<<^ SV.last . SigStL.unpackStrict)
src/Synthesizer/LLVM/Storable/Signal.hs view
@@ -7,10 +7,12 @@ -} module Synthesizer.LLVM.Storable.Signal (    unpackStrict, unpack,+   unpackStereoStrict, unpackStereo,    makeUnpackGenericStrict, makeUnpackGeneric,    makeReversePackedStrict, makeReversePacked,    continue, continuePacked, continuePackedGeneric,-   makeMixer,+   -- should be moved to a private module+   fillBuffer, makeMixer, addToBuffer,    makeArranger, arrange,    ) where @@ -18,11 +20,14 @@ import qualified Synthesizer.LLVM.Parameterized.SignalPacked as SigPS  import qualified Synthesizer.LLVM.Execution as Exec-import qualified Synthesizer.LLVM.Sample as Sample-import qualified LLVM.Extra.Representation as Rep+import qualified LLVM.Extra.Memory as Memory import qualified LLVM.Extra.Vector as Vector+import qualified LLVM.Extra.Arithmetic as A import LLVM.Extra.Control (arrayLoop, ) +import qualified Synthesizer.LLVM.Frame.Stereo as Stereo+import qualified Synthesizer.LLVM.Frame.StereoInterleaved as StereoVector+ import qualified Data.StorableVector.Lazy as SVL import qualified Data.StorableVector as SV import qualified Data.StorableVector.Base as SVB@@ -32,14 +37,13 @@ import qualified Data.EventList.Absolute.TimeBody  as AbsEventList import qualified Number.NonNegative as NonNeg -import qualified Algebra.Additive as Additive- import LLVM.Extra.Arithmetic (advanceArrayElementPtr, ) +import LLVM.Extra.Class (MakeValueTuple, ) import LLVM.Core-   (Linkage(ExternalLinkage), createFunction, ret,-    MakeValueTuple, IsSized, IsPrimitive, getElementPtr,-    Vector, IsPowerOf2, )+   (Linkage(ExternalLinkage), createNamedFunction, ret,+    IsSized, IsPrimitive, getElementPtr,+    Vector, ) import qualified Data.TypeLevel.Num as TypeNum  import qualified Control.Category as Cat@@ -51,7 +55,6 @@ import Foreign.ForeignPtr (castForeignPtr, ) import Foreign.Storable (Storable, ) import Foreign.Marshal.Array (advancePtr, )-import qualified Foreign.Marshal.Array as Array  import System.IO.Unsafe (unsafePerformIO, ) @@ -68,31 +71,50 @@ It would also need copying since the source data may not be aligned properly. -} unpackStrict ::-   (Storable a, IsPrimitive a, IsPowerOf2 n) =>+   (Storable a, IsPrimitive a, TypeNum.Pos n) =>    SV.Vector (Vector n a) -> SV.Vector a unpackStrict v =-   let getDim :: (TypeNum.Nat n) => SV.Vector (Vector n a) -> n -> Int+   let getDim :: (TypeNum.Pos n) => SV.Vector (Vector n a) -> n -> Int        getDim _ = TypeNum.toInt        d = getDim v undefined        (fptr,s,l) = SVB.toForeignPtr v    in  SVB.SV (castForeignPtr fptr) (s*d) (l*d)  unpack ::-   (Storable a, IsPrimitive a, IsPowerOf2 n) =>+   (Storable a, IsPrimitive a, TypeNum.Pos n) =>    SVL.Vector (Vector n a) -> SVL.Vector a unpack =    SVL.fromChunks . map unpackStrict . SVL.chunks ++unpackStereoStrict ::+   (Storable a, IsPrimitive a, TypeNum.Pos n) =>+   SV.Vector (StereoVector.T n a) -> SV.Vector (Stereo.T a)+unpackStereoStrict v =+   let getDim :: (TypeNum.Pos n) => SV.Vector (StereoVector.T n a) -> n -> Int+       getDim _ = TypeNum.toInt+       d = getDim v undefined+       (fptr,s,l) = SVB.toForeignPtr v+   in  SVB.SV (castForeignPtr fptr) (s*d) (l*d)++unpackStereo ::+   (Storable a, IsPrimitive a, TypeNum.Pos n) =>+   SVL.Vector (StereoVector.T n a) -> SVL.Vector (Stereo.T a)+unpackStereo =+   SVL.fromChunks . map unpackStereoStrict . SVL.chunks+ {- | This is similar to 'unpackStrict' but performs rearrangement of data. This is for instance necessary for stereo signals where the data layout of packed and unpacked data is different, thus simple casting of the data is not possible.+However, for vectorized Stereo data the StereoInterleaved+still uses vector operations for interleaving and thus is more efficient. -} makeUnpackGenericStrict ::    (Vector.Access n va vv,-    Storable a, MakeValueTuple a va, Rep.Memory va as, IsSized as asize,-    Storable v, MakeValueTuple v vv, Rep.Memory vv vs, IsSized vs vsize) =>+    Storable a, MakeValueTuple a va, Memory.C va as, IsSized as asize,+    Storable v, MakeValueTuple v vv, Memory.C vv vs, IsSized vs vsize) =>    IO (SV.Vector v -> SV.Vector a) makeUnpackGenericStrict =    let vectorSize ::@@ -104,8 +126,8 @@  makeUnpackGeneric ::    (Vector.Access n va vv,-    Storable a, MakeValueTuple a va, Rep.Memory va as, IsSized as asize,-    Storable v, MakeValueTuple v vv, Rep.Memory vv vs, IsSized vs vsize) =>+    Storable a, MakeValueTuple a va, Memory.C va as, IsSized as asize,+    Storable v, MakeValueTuple v vv, Memory.C vv vs, IsSized vs vsize) =>    IO (SVL.Vector v -> SVL.Vector a) makeUnpackGeneric =    fmap (\f -> SVL.fromChunks . map f . SVL.chunks) $@@ -114,29 +136,29 @@  makeReverser ::    (Storable a, Vector.ShuffleMatch n value,-    MakeValueTuple a value, Rep.Memory value struct) =>+    MakeValueTuple a value, Memory.C value struct) =>    value -> IO (Word32 -> Ptr a -> Ptr a -> IO ())---   (Rep.Memory a struct, Vector.ShuffleMatch n a) =>+--   (Memory.C a struct, Vector.ShuffleMatch n a) => --   IO (Word32 -> Ptr struct -> Ptr struct -> IO ()) makeReverser dummy =    fmap (\f len srcPtr dstPtr ->-      f len (Rep.castStorablePtr srcPtr) (Rep.castStorablePtr dstPtr)) $+      f len (Memory.castStorablePtr srcPtr) (Memory.castStorablePtr dstPtr)) $    fmap derefMixPtr $    Exec.compileModule $-   createFunction ExternalLinkage $ \ size ptrA ptrB -> do+   createNamedFunction ExternalLinkage "reverse" $ \ size ptrA ptrB -> do       ptrAEnd <- getElementPtr ptrA (size, ())-      arrayLoop size ptrB ptrAEnd $ \ ptrBi ptrAj0 -> do+      _ <- arrayLoop size ptrB ptrAEnd $ \ ptrBi ptrAj0 -> do          ptrAj1 <- getElementPtr ptrAj0 (-1 :: Int32, ())-         flip Rep.store ptrBi+         flip Memory.store ptrBi             =<< Vector.reverse             . flip asTypeOf dummy-            =<< Rep.load ptrAj1+            =<< Memory.load ptrAj1          return ptrAj1       ret ()  makeReversePackedStrict ::    (Storable v, Vector.Access n va vv,-    MakeValueTuple v vv, Rep.Memory vv vs, IsSized vs vsize) =>+    MakeValueTuple v vv, Memory.C vv vs, IsSized vs vsize) =>    IO (SV.Vector v -> SV.Vector v) makeReversePackedStrict = do    rev <- makeReverser undefined@@ -148,7 +170,7 @@  makeReversePacked ::    (Storable v, Vector.Access n va vv,-    MakeValueTuple v vv, Rep.Memory vv vs, IsSized vs vsize) =>+    MakeValueTuple v vv, Memory.C vv vs, IsSized vs vsize) =>    IO (SVL.Vector v -> SVL.Vector v) makeReversePacked =    fmap (\f -> SVL.fromChunks . reverse . map f . SVL.chunks) $@@ -179,7 +201,7 @@       (\body l -> SVL.append body (y l)) x  continuePacked ::-   (IsPowerOf2 n, Storable a, IsPrimitive a) =>+   (TypeNum.Pos n, Storable a, IsPrimitive a) =>    SVL.Vector (Vector n a) ->    (a -> SVL.Vector (Vector n a)) ->    SVL.Vector (Vector n a)@@ -194,7 +216,7 @@ 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 @Rep.load@, @extractelement@ and @store@+a single @Memory.load@, @extractelement@ and @store@ instead of a loop of count 1. However, this implementation is the simplest one, so far. -}@@ -207,7 +229,7 @@ continuePackedGeneric :: {-    (Storable v, Vector.Access n a v,-    MakeValueTuple v vv, Rep.Memory vv vs, IsSized vs vsize) =>+    MakeValueTuple v vv, Memory.C vv vs, IsSized vs vsize) => -}    (Storable v, Storable a) =>    (SV.Vector v -> SV.Vector a) ->@@ -247,15 +269,15 @@ it also simplifies type inference. -} fillBuffer ::-   (MakeValueTuple a value, Rep.Memory value struct) =>+   (MakeValueTuple a value, Memory.C value struct) =>    value -> IO (Word32 -> Ptr a -> IO ()) fillBuffer x =-   fmap (\f len ptr -> f len (Rep.castStorablePtr ptr)) $+   fmap (\f len ptr -> f len (Memory.castStorablePtr ptr)) $    fmap derefFillPtr $    Exec.compileModule $-   createFunction ExternalLinkage $ \ size ptr -> do+   createNamedFunction ExternalLinkage "constantfill" $ \ size ptr -> do       arrayLoop size ptr () $ \ ptri () -> do-         Rep.store x ptri+         Memory.store x ptri          return ()       ret () @@ -264,18 +286,18 @@    Exec.Importer (Word32 -> Ptr a -> Ptr a -> IO ())  makeMixer ::-   (Storable a, Sample.Additive value,-    MakeValueTuple a value, Rep.Memory value struct) =>+   (Storable a, A.Additive value,+    MakeValueTuple a value, Memory.C value struct) =>    value -> IO (Word32 -> Ptr a -> Ptr a -> IO ()) makeMixer dummy =    fmap (\f len srcPtr dstPtr ->-      f len (Rep.castStorablePtr srcPtr) (Rep.castStorablePtr dstPtr)) $+      f len (Memory.castStorablePtr srcPtr) (Memory.castStorablePtr dstPtr)) $    fmap derefMixPtr $    Exec.compileModule $-   createFunction ExternalLinkage $ \ size srcPtr dstPtr -> do-      arrayLoop size srcPtr dstPtr $ \ srcPtri dstPtri -> do-         y <- Rep.load srcPtri-         Rep.modify (Sample.add (y `asTypeOf` dummy)) dstPtri+   createNamedFunction ExternalLinkage "mix" $ \ size srcPtr dstPtr -> do+      _ <- arrayLoop size srcPtr dstPtr $ \ srcPtri dstPtri -> do+         y <- Memory.load srcPtri+         Memory.modify (A.add (y `asTypeOf` dummy)) dstPtri          advanceArrayElementPtr dstPtri       ret () @@ -298,14 +320,14 @@ Same algorithm as in Synthesizer.Storable.Cut.arrangeEquidist -} makeArranger ::-   (Storable a, Sample.Additive value,-    MakeValueTuple a value, Rep.Memory value struct) =>+   (Storable a, A.Additive value,+    MakeValueTuple a value, Memory.C value struct) =>    IO (SVL.ChunkSize ->        EventList.T NonNeg.Int (SVL.Vector a) ->        SVL.Vector a) makeArranger = do    mixer <- makeMixer undefined-   fill <- fillBuffer Sample.zero+   fill <- fillBuffer A.zero    return $ \ (SVL.ChunkSize sz) ->       let sznn = NonNeg.fromNumberMsg "arrange" sz           go acc evs =@@ -339,9 +361,10 @@ This is unsafe since it relies on the prior initialization of the LLVM JIT. Better use 'makeArranger'. -}+{-# DEPRECATED arrange "better use makeArranger" #-} arrange ::-   (Storable a, Sample.Additive value,-    MakeValueTuple a value, Rep.Memory value struct) =>+   (Storable a, A.Additive value,+    MakeValueTuple a value, Memory.C value struct) =>       SVL.ChunkSize    -> EventList.T NonNeg.Int (SVL.Vector a)          {-^ A list of pairs: (relative start time, signal part),
src/Synthesizer/LLVM/Test.hs view
@@ -14,15 +14,16 @@ import qualified Synthesizer.LLVM.CausalParameterized.ControlledPacked as CtrlPS import qualified Synthesizer.LLVM.CausalParameterized.ProcessPacked as CausalPS import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP+import qualified Synthesizer.LLVM.CausalParameterized.Functional as Func import qualified Synthesizer.LLVM.Causal.Process as Causal import qualified Synthesizer.LLVM.Simple.Signal as Sig-import qualified Synthesizer.LLVM.Storable.Signal as SigLSt-import qualified Synthesizer.LLVM.Sample as Sample+import qualified Synthesizer.LLVM.Storable.Signal as SigStL+import qualified Synthesizer.LLVM.Frame as Frame import qualified Synthesizer.LLVM.Wave as Wave import qualified Synthesizer.LLVM.Parameter as Param  import qualified LLVM.Extra.ScalarOrVector as SoV-import qualified LLVM.Extra.Representation as Rep+import qualified LLVM.Extra.Memory as Memory import qualified LLVM.Extra.Arithmetic as A import LLVM.Core (Value, value, valueOf, Vector, constVector, constOf, ) import LLVM.Util.Arithmetic () -- Floating instance for TValue@@ -39,8 +40,9 @@ 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.Arrow (Arrow, arr, (&&&), (^<<), (***), ) import Control.Category ((<<<), (.), id, )+import Control.Applicative (pure, liftA2, )  import qualified Data.StorableVector.Lazy as SVL import qualified Data.StorableVector as SV@@ -63,7 +65,7 @@ import System.Random (randomRs, mkStdGen, )  import qualified System.IO as IO-import System.Exit (ExitCode, )+-- import System.Exit (ExitCode, )  import Prelude hiding (fst, snd, id, (.), ) import qualified Prelude as P@@ -96,22 +98,24 @@  ghci: JITEmitter.cpp:110: <unnamed>::JITResolver::JITResolver(llvm::JIT&): Assertion `TheJITResolver == 0 && "Multiple JIT resolvers?"' failed. -}-playStereo :: Sig.T (Stereo.T (Value Float)) -> IO ExitCode+playStereo :: Sig.T (Stereo.T (Value Float)) -> IO () playStereo =    playStereoVector .    Sig.renderChunky (SVL.chunkSize 100000) -playStereoVector :: SVL.Vector (Stereo.T Float) -> IO ExitCode+playStereoVector :: SVL.Vector (Stereo.T Float) -> IO () playStereoVector =+   fmap (const ()) .    SoxPlay.simple SVL.hPut SoxOption.none 44100 -playMono :: Sig.T (Value Float) -> IO ExitCode+playMono :: Sig.T (Value Float) -> IO () playMono =    playMonoVector .    Sig.renderChunky (SVL.chunkSize 100000) -playMonoVector :: SVL.Vector Float -> IO ExitCode+playMonoVector :: SVL.Vector Float -> IO () playMonoVector =+   fmap (const ()) .    SoxPlay.simple SVL.hPut SoxOption.none 44100  @@ -153,7 +157,7 @@    (\xs -> SigP.render xs (div 10000000 4) ()) $    SigP.mapSimple Wave.triangle $    SigPS.packSmall $-   SigP.osciCore 0.25 0.01+   (SigP.osciCore $# (0.25::Float)) 4.015803e-4  trianglePacked :: IO () trianglePacked =@@ -255,7 +259,7 @@  stereoOsciSaw :: Float -> Sig.T (Stereo.T (Value Float)) stereoOsciSaw freq =-   Sig.zipWith Sample.zipStereo+   liftA2 Stereo.cons       (Sig.osciSaw 0.0 (freq*1.001) `Sig.mix`        Sig.osciSaw 0.2 (freq*1.003) `Sig.mix`        Sig.osciSaw 0.1 (freq*0.995))@@ -266,9 +270,9 @@ stereoOsciSawPacked :: Float -> Sig.T (Stereo.T (Value Float)) stereoOsciSawPacked freq =    let mix4 =-          Sample.mixVector .+          Frame.mixVector .           flip asTypeOf (undefined :: Value (Vector D4 Float))-   in  Sig.zipWith Sample.zipStereo+   in  liftA2 Stereo.cons           (Sig.map mix4 $            Sig.osciPlain Wave.saw               (value $ constVector $ map constOf [0.0, 0.2, 0.1, 0.4])@@ -282,7 +286,7 @@  stereoOsciSawPacked2 :: Float -> Sig.T (Stereo.T (Value Float)) stereoOsciSawPacked2 freq =-   Sig.map (Sample.mixVectorToStereo .+   Sig.map (Frame.mixVectorToStereo .             flip asTypeOf (undefined :: Value (Vector D8 Float))) $    Sig.osciPlain (Wave.trapezoidSkew (SoV.replicateOf 0.2))       (valueOf $@@ -337,9 +341,9 @@    However doing all 32 oscillators in parallel    and mix them in one go might be still faster. -   foldl1 (Sig.zipWith Sample.mixStereoV) $+   foldl1 (Sig.zipWith Frame.mixStereoV) $    -}-   foldl1 Sig.mixStereo $+   foldl1 Sig.mix $    map (\f -> stereoOsciSawPacked2 (base*f)) $    0.25 : 1.00 : 1.25 : 1.50 : [] @@ -367,7 +371,7 @@    chord 0.005  lfoSine ::-   (Rep.Memory a ap, LLVM.IsSized ap asize) =>+   (Memory.C a ap, LLVM.IsSized ap asize) =>    (forall r. Value Float -> LLVM.CodeGenFunction r a) ->    Param.T p Float ->    SigP.T p a@@ -459,7 +463,7 @@    asMonoPacked $    flip (SigP.renderChunky (SVL.chunkSize 10000)) () $    (CausalPS.amplify 0.2 . Filt2.causalPackedP-      $< (SigP.mapSimple (const $ Rep.load =<< LLVM.alloca) $+      $< (SigP.mapSimple (const $ Memory.load =<< LLVM.alloca) $             (SigP.constant $# (0::Float)))       $* SigPS.noise 0 0.3) @@ -471,7 +475,7 @@    flip (SigP.renderChunky (SVL.chunkSize 10000)) () $    (CausalP.amplify 0.2 . Filt2.causalP       $< (SigP.mapSimple (const $-             (Rep.load =<< LLVM.alloca ::+             (Memory.load =<< LLVM.alloca ::                  LLVM.CodeGenFunction r (Filt2.Parameter (Value Float)))) $            (SigP.constant $# (0::Float)))       $* SigP.noise 0 0.3)@@ -551,7 +555,7 @@ playFilterSweepMusicCausal :: IO () playFilterSweepMusicCausal = do    do music <- SV.readFile "lichter.f32"-      SoxPlay.simple SV.hPut SoxOption.none 44100 $+      _ <- SoxPlay.simple SV.hPut SoxOption.none 44100 $          asStereo $          Causal.applyStorable             (Causal.amplifyStereo 20 <<< filterSweepControlRateCausal) $@@ -572,7 +576,7 @@ arrangeLazy = do    IO.hSetBuffering IO.stdout IO.NoBuffering    print $-      SigLSt.arrange (SVL.chunkSize 2) $+      SigStL.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]) :@@ -592,7 +596,7 @@ randomTones :: IO () randomTones = do    playMonoVector $-      SigLSt.arrange (SVL.chunkSize 12345) $+      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) .@@ -681,7 +685,7 @@ to 14.9 after total 13min. -} {--      SigLSt.arrange (SVL.chunkSize 12345678) $+      SigStL.arrange (SVL.chunkSize 12345678) $       EventList.fromPairList $ zip          (repeat (div 44100 8)) --         (cycle $ map (flip div 4 . (44100*)) [1,2,3])@@ -731,7 +735,7 @@    pingp <- makePing    playMonoVector $       CausalP.applyStorableChunky (CausalP.amplify id) 0.03 $-      SigLSt.arrange tonesChunkSize $+      SigStL.arrange tonesChunkSize $       EventList.fromPairList $ zip          (repeat (NonNeg.fromNumber dist))          (map (SVL.take (numTones * dist) . curry pingp 50000) $@@ -766,7 +770,7 @@  vibesCycleVector :: ((Float,Float) -> SVL.Vector Float) -> SVL.Vector Float vibesCycleVector pingp =-   SigLSt.arrange tonesChunkSize $+   SigStL.arrange tonesChunkSize $    EventList.fromPairList $ zip       (repeat 5000)       (map (SVL.take 50000 . pingp) $@@ -813,7 +817,7 @@           CausalP.stereoFromChannels              (CausalP.reverb (mkStdGen 142) 16 (0.9,0.97) (400,1000))              (CausalP.reverb (mkStdGen 857) 16 (0.9,0.97) (400,1000)) <<<-          CausalP.mapSimple Sample.stereoFromMono)+          CausalP.mapSimple Frame.stereoFromMono)          0.3 $       vibesCycleVector pingp    return ()@@ -843,7 +847,7 @@          (BandPass.causalP           <<<           CausalP.feedSnd-             (SigP.zipWithSimple Sample.zipStereo+             (liftA2 Stereo.cons                  (SigP.osciSimple Wave.saw 0 0.001499)                  (SigP.osciSimple Wave.saw 0 0.001501))           <<<@@ -901,7 +905,7 @@    SVL.Vector (Stereo.T Float) mixVectorStereo =    CausalP.applyStorableChunky-      (CausalP.mixStereo $<+      (CausalP.mix $<        SigP.fromStorableVectorLazy id)  mixVectorStereoIO ::@@ -910,7 +914,7 @@        SVL.Vector (Stereo.T Float)) mixVectorStereoIO =    CausalP.runStorableChunky-      (CausalP.mixStereo $<+      (CausalP.mix $<        SigP.fromStorableVectorLazy id)  {-@@ -959,7 +963,7 @@ stereoOsciSawP =    let freq = id        n = 5-       volume = 1 / sqrt (fromIntegral n)+       volume = pure $ recip $ sqrt $ fromIntegral n :: Param.T p Float        detunes =           normalizeLevel 1 $ take (2*n) $              randomRs (0,0.03) $ mkStdGen 912@@ -971,10 +975,8 @@                  (SigP.osciSaw $# phase) (fmap (detune*) freq))              phases detunes        (tonesLeft,tonesRight) = splitAt n tones-   in  SigP.zipWithSimple-          (\l r ->-             Sample.amplifyStereo (valueOf volume)-              =<< Sample.zipStereo l r)+   in  SigP.amplifyStereo volume $+       liftA2 Stereo.cons           (foldl1 SigP.mix tonesLeft)           (foldl1 SigP.mix tonesRight) @@ -1039,7 +1041,7 @@ padMusic = do    playStereoVector $       CausalP.applyStorableChunky (CausalP.amplifyStereo id) 0.1 $-      SigLSt.arrange tonesChunkSize $+      SigStL.arrange tonesChunkSize $       EventListTM.switchTimeR const $       EventListMT.consTime 0 $       EventListBT.fromPairList $@@ -1077,7 +1079,7 @@       CausalP.applyStorableChunky          (CausalP.amplifyStereo id <<<           moogSweepControlRateCausal) 0.05 $-      SigLSt.arrange tonesChunkSize $+      SigStL.arrange tonesChunkSize $       EventListTM.switchTimeR const $       EventListMT.consTime 0 $       EventListBT.fromPairList $@@ -1121,7 +1123,7 @@    pad <- stereoOsciSawPadIO    playStereoVector $       CausalP.applyStorableChunky (CausalP.amplifyStereo id) 0.08 $-      SigLSt.arrange tonesChunkSize $+      SigStL.arrange tonesChunkSize $       EventListTM.switchTimeR const $       EventListMT.consTime 0 $       EventListBT.fromPairList $@@ -1139,7 +1141,7 @@    env <- applyFadeEnvelopeIO    playStereoVector $       CausalP.applyStorableChunky (CausalP.amplifyStereo id) 0.08 $-      SigLSt.arrange tonesChunkSize $+      SigStL.arrange tonesChunkSize $       EventList.flatten $       EventListTM.switchTimeR const $       EventListMT.consTime 0 $@@ -1159,8 +1161,20 @@           <<< CausalP.take snd) $    SigP.osciSaw 0 0.01 +delayStereo :: IO ()+delayStereo =+   SVL.writeFile "speedtest.f32" $+   asStereo $+   flip (SigP.renderChunky tonesChunkSize) (7, 10000) $+   CausalP.apply+      (CausalP.take snd+       <<<+       liftA2 Stereo.cons+          id ((CausalP.delay $# (0::Float)) fst)) $+   SigP.osciSaw 0 0.01  + allpassControl ::    (TypeNum.Nat n) =>    n ->@@ -1282,7 +1296,41 @@    (SigP.osciSaw $# (0::Float)) 0.01  +arrowNonShared :: IO ()+arrowNonShared =+   SVL.writeFile "speedtest.f32" $+   asStereo $+   SVL.take 10000000 $+   flip (SigP.renderChunky (SVL.chunkSize 100000)) () $+   (let osci = CausalP.osciSimple Wave.approxSine2+    in  liftA2 Stereo.cons osci osci $*+        SigP.constant (return (0::Float, 0.01::Float)))++arrowShared :: IO ()+arrowShared =+   SVL.writeFile "speedtest.f32" $+   asStereo $+   SVL.take 10000000 $+   flip (SigP.renderChunky (SVL.chunkSize 100000)) () $+   (let osci = Func.lift (CausalP.osciSimple Wave.approxSine2)+    in  Func.compile (liftA2 Stereo.cons osci osci) $*+        SigP.constant (return (0::Float, 0.01::Float)))++arrowIndependent :: IO ()+arrowIndependent =+   SVL.writeFile "speedtest.f32" $+   asStereo $+   SVL.take 10000000 $+   flip (SigP.renderChunky (SVL.chunkSize 100000)) () $+   (let osci = CausalP.osciSimple Wave.approxSine2+    in  Func.compile+          (fmap (uncurry Stereo.cons)  $+           osci *** osci  Func.$&+           Func.lift id) $*+        SigP.constant (return ((0::Float, 0.01::Float), (0.25::Float, 0.01001::Float))))++ main :: IO () main = do    LLVM.initializeNativeTarget-   frequencyModulationStereo+   arrowIndependent
src/Synthesizer/LLVM/Wave.hs view
@@ -190,4 +190,4 @@    SoV.signedFraction =<<    A.mul t =<<    SoV.replicate =<<-   LLVM.sitofp n+   LLVM.inttofp n
src/Test/Synthesizer/LLVM/Filter.hs view
@@ -18,7 +18,7 @@ import qualified Synthesizer.Plain.Filter.Recursive.FirstOrderComplex as ComplexFilterCore  import qualified Synthesizer.LLVM.Parameter as Param-import qualified LLVM.Extra.Representation as Rep+import qualified LLVM.Extra.Memory as Memory import qualified Synthesizer.LLVM.Wave as Wave import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP import qualified Synthesizer.LLVM.Parameterized.SignalPacked as SigPS@@ -33,7 +33,6 @@ 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.Basic.Phase as Phase import qualified Synthesizer.Basic.Wave as WaveCore import qualified Synthesizer.State.Displacement as DispS import qualified Synthesizer.State.Oscillator as OsciS@@ -78,7 +77,7 @@   lfoSine ::-   (Rep.Memory a ap, LLVM.IsSized ap asize) =>+   (Memory.C a ap, LLVM.IsSized ap asize) =>    (forall r. Value Float -> LLVM.CodeGenFunction r a) ->    Param.T p Float ->    SigP.T p a@@ -129,7 +128,7 @@ since we can only handle one control parameter per vector chunk. -} applyPacked ::-   (Rep.Memory c cp, LLVM.IsSized cp cs) =>+   (Memory.C c cp, LLVM.IsSized cp cs) =>    CausalP.T p       (c, Value (Vector D4 Float))       (Value (Vector D4 Float)) ->@@ -139,7 +138,7 @@ applyPacked proc cs xs =    proc       $< ((SigP.interpolateConstant $#-            (recip $ fromIntegral $ TypeNum.toInt TypeNum.d4 :: Float)) cs)+            (recip $ TypeNum.toNum TypeNum.d4 :: Float)) cs)       $* xs
src/Test/Synthesizer/LLVM/Packed.hs view
@@ -8,7 +8,6 @@ import qualified Synthesizer.LLVM.Parameter as Param  import LLVM.Core (Value, Vector, )-import qualified LLVM.Core as LLVM import Data.TypeLevel.Num (D4, ) import qualified Data.TypeLevel.Num as TypeNum
src/Test/Synthesizer/LLVM/Utility.hs view
@@ -2,8 +2,8 @@ module Test.Synthesizer.LLVM.Utility where  import qualified Synthesizer.LLVM.Parameter as Param-import qualified LLVM.Extra.Representation as Rep-import qualified LLVM.Core as LLVM+import qualified LLVM.Extra.Memory as Memory+import qualified LLVM.Extra.Class as Class  import qualified Synthesizer.LLVM.Parameterized.Signal as SigP @@ -32,8 +32,8 @@ {-# INLINE checkSimilarityState #-} checkSimilarityState ::    (RealRing.C a, Storable a,-    LLVM.MakeValueTuple a av,-    Rep.Memory av ap) =>+    Class.MakeValueTuple a av,+    Memory.C av ap) =>    a ->    (SVL.Vector a -> SVL.Vector a) ->    SigP.T p av ->@@ -59,7 +59,7 @@ checkSimilarity ::    (RealRing.C b, Storable b,     Storable a,-    LLVM.MakeValueTuple a av, Rep.Memory av ap) =>+    Class.MakeValueTuple a av, Memory.C av ap) =>    b ->    (SVL.Vector a -> SVL.Vector b) ->    SigP.T p av -> SigP.T p av ->@@ -83,8 +83,8 @@  checkEquality ::    (Eq a, Storable a,-    LLVM.MakeValueTuple a av,-    Rep.Memory av ap) =>+    Class.MakeValueTuple a av,+    Memory.C av ap) =>    (SVL.Vector a -> SVL.Vector a) ->    SigP.T p av -> SigP.T p av ->    IO (ChunkSize -> p -> Bool)
synthesizer-llvm.cabal view
@@ -1,5 +1,5 @@ Name:           synthesizer-llvm-Version:        0.2.0.1+Version:        0.3 License:        GPL License-File:   LICENSE Author:         Henning Thielemann <haskell@henning-thielemann.de>@@ -18,8 +18,8 @@   that receives MIDI events via ALSA   and in response plays some tones via ALSA. Stability:      Experimental-Tested-With:    GHC==6.10.4-Cabal-Version:  >=1.2+Tested-With:    GHC==6.10.4, GHC==6.12.3, GHC==7.0.4, GHC==7.2.1+Cabal-Version:  >=1.6 Build-Type:     Simple  Flag buildExamples@@ -30,33 +30,46 @@   description: Build test suite   default:     False +Source-Repository this+  Tag:         0.3+  Type:        darcs+  Location:    code.haskell.org:/srv/code/synthesizer/llvm/++Source-Repository head+  Type:        darcs+  Location:    code.haskell.org:/srv/code/synthesizer/llvm/++ Library   Build-Depends:-    llvm-extra >= 0.1 && <0.2,+    llvm-extra >= 0.3 && <0.4,     -- llvm must be imported with restrictive version bounds,     -- because we import implicitly and unqualified-    llvm-ht >=0.7.0 && <0.7.1,+    llvm >=0.10 && <0.10.1,     type-level >=0.2.3 && <0.3,     functional-arrow >=0.0 && <0.1,+    vault >=0.1 && <0.2,     HList >=0.2 && <0.3,-    synthesizer-core >=0.4 && <0.5,+    synthesizer-core >=0.5 && <0.6,     -- for ALSA.BendModulation-    synthesizer-alsa >=0.3 && <0.4,+    synthesizer-alsa >=0.4 && <0.5,     alsa-seq >=0.5 && <0.6,     alsa-pcm >=0.5 && <0.6,-    midi >= 0.1.5 && <0.2,+    midi-alsa >= 0.1.2 && <0.2,+    midi >= 0.1.6 && <0.2,     storable-record >=0.0.2 && <0.1,     storable-tuple >=0.0.2 && <0.1,     sox >=0.2 && <0.3,     sample-frame-np >=0.0.1 && <0.1,     sample-frame >=0.0.1 && <0.1,     storablevector >=0.2.6 && <0.3,-    numeric-prelude >=0.2 && <0.3,+    numeric-prelude >=0.3 && <0.4,     non-negative >=0.1 && <0.2,     event-list >=0.1 && <0.2,     -- data-accessor >=0.1 && <0.2,+    filepath >=1.1 && <1.3,     random >= 1.0 && < 1.1,-    containers >=0.1 && <0.4,+    containers >=0.1 && <0.5,     transformers >=0.2 && <0.3,     utility-ht >=0.0.1 && <0.1 @@ -65,6 +78,11 @@     base >= 4 && <5    GHC-Options:    -Wall+  If impl(ghc>=7.0)+    GHC-Options: -fwarn-unused-do-bind -fcontext-stack=1000+    CPP-Options: -DNoImplicitPrelude=RebindableSyntax+    Extensions: CPP+   Hs-source-dirs: src   Exposed-Modules:     Synthesizer.LLVM.Simple.Signal@@ -72,14 +90,18 @@     Synthesizer.LLVM.Simple.Vanilla     Synthesizer.LLVM.Parameterized.Signal     Synthesizer.LLVM.Parameterized.SignalPacked-    Synthesizer.LLVM.Parameterized.Value+    -- Synthesizer.LLVM.Parameterized.Value     Synthesizer.LLVM.Parameter     Synthesizer.LLVM.Storable.Signal+    Synthesizer.LLVM.Storable.Process     Synthesizer.LLVM.Causal.Process     Synthesizer.LLVM.CausalParameterized.Process     Synthesizer.LLVM.CausalParameterized.ProcessPacked     Synthesizer.LLVM.CausalParameterized.Controlled     Synthesizer.LLVM.CausalParameterized.ControlledPacked+    Synthesizer.LLVM.CausalParameterized.Functional+    Synthesizer.LLVM.Plug.Input+    Synthesizer.LLVM.Plug.Output     Synthesizer.LLVM.Filter.Allpass     Synthesizer.LLVM.Filter.Butterworth     Synthesizer.LLVM.Filter.Chebyshev@@ -92,8 +114,13 @@     Synthesizer.LLVM.Filter.Moog     Synthesizer.LLVM.Filter.Universal     Synthesizer.LLVM.Generator.Exponential2-    Synthesizer.LLVM.Sample+    Synthesizer.LLVM.RingBuffer+    Synthesizer.LLVM.ConstantPiece+    Synthesizer.LLVM.SerialVector+    Synthesizer.LLVM.Frame     Synthesizer.LLVM.Frame.Stereo+    Synthesizer.LLVM.Frame.StereoInterleaved+    Synthesizer.LLVM.Complex     Synthesizer.LLVM.Wave     Synthesizer.LLVM.Server.Common     Synthesizer.LLVM.Server.Packed.Test@@ -102,8 +129,11 @@     Synthesizer.LLVM.Server.Scalar.Test     Synthesizer.LLVM.Server.Scalar.Run     Synthesizer.LLVM.Server.Scalar.Instrument-    -- may be moved to a separate package+    Synthesizer.LLVM.Server.CausalPacked.Instrument+    Synthesizer.LLVM.Server.CausalPacked.Run+    Synthesizer.LLVM.Server.CausalPacked.Test     Synthesizer.LLVM.ALSA.MIDI+    Synthesizer.LLVM.ALSA.BendModulation    Other-Modules:     Synthesizer.LLVM.Random@@ -112,24 +142,41 @@     Synthesizer.LLVM.Storable.LazySizeIterator     Synthesizer.LLVM.Parameterized.SignalPrivate     Synthesizer.LLVM.CausalParameterized.ProcessPrivate-    -- belongs to Synthesizer.LLVM.ALSA.MIDI-    Synthesizer.LLVM.ALSA.BendModulation+    Synthesizer.LLVM.Debug.Counter+    Synthesizer.LLVM.Debug.StablePtr+    Synthesizer.LLVM.Debug.Storable+    Synthesizer.LLVM.Server.Option     -- may be moved to llvm-extra     Synthesizer.LLVM.Execution+    -- shall be removed when Foreign.Marshal.Alloc is fixed+    Synthesizer.LLVM.Alloc+    Synthesizer.LLVM.LAC2011+    Synthesizer.LLVM.LNdW2011  Executable synthi-llvm-example   If !flag(buildExamples)     Buildable: False   GHC-Options:    -Wall+  If impl(ghc>=7.0)+    GHC-Options: -fwarn-unused-do-bind -fcontext-stack=1000+    CPP-Options: -DNoImplicitPrelude=RebindableSyntax+    Extensions: CPP   Hs-Source-Dirs: src   Main-Is:     Synthesizer/LLVM/Test.hs  Executable synthi-llvm-server   If !flag(buildExamples)     Buildable: False-  GHC-Options:    -Wall -threaded+  --  -threaded -debug+  GHC-Options:      -Wall+  GHC-Options:      -rtsopts+  GHC-Prof-Options: -auto-all+  If impl(ghc>=7.0)+    GHC-Options: -fwarn-unused-do-bind -fcontext-stack=1000+    CPP-Options: -DNoImplicitPrelude=RebindableSyntax+    Extensions: CPP   Hs-Source-Dirs: src-  Main-Is:     Synthesizer/LLVM/Server.hs+  Main-Is:        Synthesizer/LLVM/Server.hs   Other-Modules:     Synthesizer.LLVM.Server.Packed.Instrument     Synthesizer.LLVM.Server.Packed.Test@@ -145,6 +192,10 @@   Else     Buildable: False   GHC-Options:    -Wall+  If impl(ghc>=7.0)+    GHC-Options: -fwarn-unused-do-bind -fcontext-stack=1000+    CPP-Options: -DNoImplicitPrelude=RebindableSyntax+    Extensions: CPP   Hs-Source-Dirs: src   Main-Is:     Test/Main.hs   Other-Modules: