packages feed

synthesizer-midi (empty) → 0.5

raw patch · 21 files changed

+5033/−0 lines, 21 filesdep +arraydep +basedep +containerssetup-changed

Dependencies added: array, base, containers, data-accessor, data-accessor-transformers, deepseq, event-list, midi, non-negative, numeric-prelude, sox, storable-record, storablevector, synthesizer-core, synthesizer-dimensional, transformers, utility-ht

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>.
+ Setup.lhs view
@@ -0,0 +1,3 @@+#! /usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ src/Render.hs view
@@ -0,0 +1,105 @@+{- |+Very simple MIDI file renderer.+It uses an arbitrary set of simple instruments,+that is in no way related to General MIDI or something else,+ignores tempo changes and respects only MIDI channel 0.+-}+module Main where++import qualified Synthesizer.MIDI.Example.Instrument as Instr+import qualified Synthesizer.MIDI.Storable as MidiSt++import qualified Synthesizer.Frame.Stereo as Stereo++import qualified Data.StorableVector.Lazy as SVL++import qualified Sound.Sox.Write as SoxWrite+import qualified Sound.Sox.Play  as SoxPlay++import qualified Sound.MIDI.File as MidiFile+import qualified Sound.MIDI.File.Event as FileEvent+import qualified Sound.MIDI.File.Load as Load+import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg+import qualified Sound.MIDI.Message.Channel       as ChannelMsg+import Sound.MIDI.Message.Channel (Channel, )++import qualified Data.EventList.Relative.TimeBody  as EventList+import qualified Numeric.NonNegative.Wrapper as NonNeg++import Control.Monad.Trans.State (evalState, )++import Data.Monoid (mempty, )++import qualified System.Environment as Env+import qualified System.Exit as Exit+import qualified System.IO as IO++import NumericPrelude.Numeric ((*>), )+import Prelude hiding (Real, )+++type Real = Float++channel :: Channel+channel = ChannelMsg.toChannel 0++sampleRate :: Num a => a+-- sampleRate = 24000+-- sampleRate = 48000+sampleRate = 44100++chunkSize :: SVL.ChunkSize+chunkSize = SVL.defaultChunkSize+++render ::+   MidiFile.T -> SVL.Vector (Stereo.T Real)+render =+   SVL.map ((0.2::Real)*>) .+   evalState+      (MidiSt.sequenceMultiProgram chunkSize channel+         (VoiceMsg.toProgram 0) $+            Instr.pingStereoRelease :+            Instr.tineStereo :+            Instr.softString :+            []) .+   EventList.collectCoincident .+   EventList.mapMaybe (\ev ->+      case ev of+         FileEvent.MIDIEvent mev -> Just mev+         _ -> Nothing) .+   EventList.mapTime+      (NonNeg.fromNumberMsg "MIDI.render" . fromInteger . NonNeg.toNumber) .+   EventList.resample sampleRate .+   (\(MidiFile.Cons typ division tracks) ->+      MidiFile.mergeTracks typ $+      map (MidiFile.secondsFromTicks division) tracks)++handleSoxExit :: IO Exit.ExitCode -> IO ()+handleSoxExit sox = do+   soxResult <- sox+   case soxResult of+      Exit.ExitSuccess -> return ()+      Exit.ExitFailure n -> do+         IO.hPutStrLn IO.stderr $+            "'sox' aborted with exit code " ++ show n+         Exit.exitFailure++main :: IO ()+main = do+   args <- Env.getArgs+   case args of+      [midiPath] ->+         handleSoxExit .+            SoxPlay.simple SVL.hPut mempty sampleRate .+            render =<<+            Load.fromFile midiPath+      [midiPath, wavePath] ->+         handleSoxExit .+            SoxWrite.simple SVL.hPut mempty wavePath sampleRate .+            render =<<+            Load.fromFile midiPath+      _ -> do+         IO.hPutStrLn IO.stderr+            "need arguments: infile.mid [outfile.wav]"+         Exit.exitFailure
+ src/Synthesizer/MIDI/CausalIO/ControllerSelection.hs view
@@ -0,0 +1,111 @@+module Synthesizer.MIDI.CausalIO.ControllerSelection (+   fromChannel,+   filter,+   T(Cons),++   controllerLinear,+   controllerExponential,+   pitchBend,+   channelPressure,+   ) where++import qualified Synthesizer.CausalIO.Process as PIO+import qualified Synthesizer.MIDI.CausalIO.Process as MIO++import qualified Synthesizer.MIDI.PiecewiseConstant.ControllerSet as PCS+import qualified Synthesizer.MIDI.EventList as MIDIEv+import qualified Synthesizer.MIDI.Value as MV++import qualified Sound.MIDI.Message.Class.Check as Check++import qualified Data.EventList.Relative.TimeTime  as EventListTT++import qualified Algebra.Transcendental as Trans+import qualified Algebra.Field          as Field++import qualified Data.Map as Map+import qualified Data.Maybe as Maybe+import Data.Tuple.HT (mapSnd, )++import Control.Arrow (Arrow, )++import NumericPrelude.Numeric+import NumericPrelude.Base hiding ((.), filter, )+import Prelude ()++++fromChannel ::+   (Check.C event, Arrow arrow) =>+   MIDIEv.Channel ->+   arrow+      (EventListTT.T MIDIEv.StrictTime [event])+      (EventListTT.T MIDIEv.StrictTime [(PCS.Controller, Int)])+fromChannel chan =+   MIO.mapMaybe $ PCS.maybeController chan+++-- see PCS.mapInsertMany+mapInsertMany ::+   (Ord key) =>+   [(key,a)] -> Map.Map key a -> Map.Map key a+mapInsertMany assignments inits =+   foldl (flip (uncurry Map.insert)) inits assignments++++data T a =+   Cons PCS.Controller (Int -> a) a++filter ::+   [T a] ->+   PIO.T+      (EventListTT.T MIDIEv.StrictTime [(PCS.Controller, Int)])+      (PCS.T Int a)+filter mapping =+   let dict =+          Map.fromList $+          zipWith (\n (Cons cc f _init) -> (cc, (n, f)))+             [0 ..] mapping+   in  PIO.mapAccum+          (\evs curMap ->+             let ctrlEvs =+                    fmap (Maybe.mapMaybe (\(cc, val) ->+                       fmap (mapSnd ($val)) $ Map.lookup cc dict)) evs+             in  (PCS.Cons curMap ctrlEvs,+                  mapInsertMany+                     (concat $ EventListTT.getBodies ctrlEvs)+                     curMap))+          (Map.fromList $ zip [0..] $+           map (\(Cons _cc _f initVal) -> initVal) mapping)+++controllerLinear ::+   (Field.C y) =>+   MIDIEv.Controller ->+   (y,y) -> y ->+   T y+controllerLinear ctrl bnd initial =+   Cons (PCS.Controller ctrl) (MV.controllerLinear bnd) initial++controllerExponential ::+   (Trans.C y) =>+   MIDIEv.Controller ->+   (y,y) -> y ->+   T y+controllerExponential ctrl bnd initial =+   Cons (PCS.Controller ctrl) (MV.controllerExponential bnd) initial++pitchBend ::+   (Trans.C y) =>+   y -> y ->+   T y+pitchBend range center =+   Cons PCS.PitchBend (MV.pitchBend range center) center++channelPressure ::+   (Trans.C y) =>+   y -> y ->+   T y+channelPressure maxVal initial =+   Cons PCS.Pressure (MV.controllerLinear (zero,maxVal)) initial
+ src/Synthesizer/MIDI/CausalIO/ControllerSet.hs view
@@ -0,0 +1,156 @@+module Synthesizer.MIDI.CausalIO.ControllerSet (+   T,+   fromChannel,+   slice, PCS.Controller(..),++   controllerLinear,+   controllerExponential,+   pitchBend,+   channelPressure,+   bendWheelPressure,+   ) where++import qualified Synthesizer.CausalIO.Process as PIO+import qualified Synthesizer.MIDI.CausalIO.Process as MIO++import qualified Synthesizer.MIDI.PiecewiseConstant.ControllerSet as PCS+import qualified Synthesizer.MIDI.EventList as MIDIEv+import qualified Synthesizer.MIDI.Value.BendModulation as BM+import qualified Synthesizer.MIDI.Value.BendWheelPressure as BWP+import qualified Synthesizer.MIDI.Value as MV+import qualified Synthesizer.PiecewiseConstant.Signal as PC++import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg+import qualified Sound.MIDI.Message.Class.Check as Check++import qualified Data.EventList.Relative.TimeTime  as EventListTT+import qualified Data.EventList.Relative.BodyTime  as EventListBT+import qualified Data.EventList.Relative.MixedTime as EventListMT++import qualified Algebra.Transcendental as Trans+import qualified Algebra.Field          as Field+import qualified Algebra.RealRing       as RealRing++import qualified Control.Monad.Trans.State as MS++import qualified Data.Accessor.Basic as Acc++import qualified Data.Map as Map++import Data.Traversable (Traversable, traverse, )+import Data.Foldable (traverse_, )++import Control.Arrow (Arrow, arr, )+import Control.Category ((.), )++import qualified Data.Maybe as Maybe+import Data.Maybe.HT (toMaybe, )++import NumericPrelude.Numeric+import NumericPrelude.Base hiding ((.), )+import Prelude ()++++-- see PCS.mapInsertMany+mapInsertMany ::+   (Ord key) =>+   [(key,a)] -> Map.Map key a -> Map.Map key a+mapInsertMany assignments inits =+   foldl (flip (uncurry Map.insert)) inits assignments+++fromChannel ::+   (Check.C event) =>+   MIDIEv.Channel ->+   PIO.T+      (EventListTT.T MIDIEv.StrictTime [event])+      (PCS.T PCS.Controller Int)+fromChannel chan =+   (PIO.traverse Map.empty $ \evs0 -> do+      initial <- MS.get+      fmap (PCS.Cons initial) $+         traverse (\ys -> MS.modify (mapInsertMany ys) >> return ys) evs0)+   .+   MIO.mapMaybe (PCS.maybeController chan)+++type T arrow y =+   arrow+      (PCS.T PCS.Controller Int)+      (EventListBT.T PC.ShortStrictTime y)+++slice ::+   (Arrow arrow) =>+   PCS.Controller ->+   (Int -> y) {- ^ This might be a function from "Synthesizer.MIDI.Value"+                   or "Synthesizer.Dimensional.MIDIValue" -} ->+   y ->+   T arrow y+slice c f deflt =+   arr $ \(PCS.Cons initial stream) ->+      let yin = maybe deflt f $ Map.lookup c initial+      in  PC.subdivideLongStrict $+          EventListMT.consBody yin $+          flip MS.evalState yin $+          traverse+             (\ys -> traverse_ (MS.put . f) ys >> MS.get) $+          fmap+             (Maybe.mapMaybe+                (\(ci,a) -> toMaybe (c==ci) a))+             stream+++controllerLinear ::+   (Field.C y, Arrow arrow) =>+   MIDIEv.Controller ->+   (y,y) -> y ->+   T arrow y+controllerLinear ctrl bnd initial =+   slice (PCS.Controller ctrl) (MV.controllerLinear bnd) initial++controllerExponential ::+   (Trans.C y, Arrow arrow) =>+   MIDIEv.Controller ->+   (y,y) -> y ->+   T arrow y+controllerExponential ctrl bnd initial =+   slice (PCS.Controller ctrl) (MV.controllerExponential bnd) initial++pitchBend ::+   (Trans.C y, Arrow arrow) =>+   y -> y ->+   T arrow y+pitchBend range center =+   slice PCS.PitchBend (MV.pitchBend range center) center++channelPressure ::+   (Trans.C y, Arrow arrow) =>+   y -> y ->+   T arrow y+channelPressure maxVal initial =+   slice PCS.Pressure (MV.controllerLinear (zero,maxVal)) initial++bendWheelPressure ::+   (RealRing.C y, Trans.C y, Arrow arrow) =>+   Int -> y -> y ->+   T arrow (BM.T y)+bendWheelPressure pitchRange wheelDepth pressDepth =+   arr $ \(PCS.Cons initial stream) ->+      let set key field =+             maybe id (Acc.set field) $+             Map.lookup key initial+          yin =+             set PCS.PitchBend BWP.bend $+             set (PCS.Controller VoiceMsg.modulation) BWP.wheel $+             set PCS.Pressure BWP.pressure $+             BWP.deflt+      in  PC.subdivideLongStrict $+          fmap (BM.fromBendWheelPressure pitchRange wheelDepth pressDepth) $+          EventListMT.consBody yin $+          flip MS.evalState yin $+          traverse (\ys0 -> traverse_ MS.put ys0 >> MS.get) $+          fmap Maybe.catMaybes $+          flip MS.evalState BWP.deflt $+          traverse (traverse PCS.checkBendWheelPressure) stream
+ src/Synthesizer/MIDI/CausalIO/Process.hs view
@@ -0,0 +1,691 @@+{-# LANGUAGE ExistentialQuantification #-}+module Synthesizer.MIDI.CausalIO.Process (+   Events,++   slice,+   controllerLinear,+   controllerExponential,+   pitchBend,+   channelPressure,+   bendWheelPressure,+   constant,++   Instrument,+   Bank,+   GateChunk,+   noteEvents,+   embedPrograms,+   applyInstrument,+   applyModulatedInstrument,+   flattenControlSchedule,+   applyModulation,+   arrangeStorable,+   sequenceCore,+   sequenceModulated,+   sequenceModulatedMultiProgram,+   sequenceStorable,++   -- auxiliary function+   initWith,+   mapMaybe,+   ) where++import qualified Synthesizer.CausalIO.Gate as Gate+import qualified Synthesizer.CausalIO.Process as PIO++import qualified Synthesizer.MIDI.Value.BendModulation as BM+import qualified Synthesizer.MIDI.Value.BendWheelPressure as BWP+import qualified Synthesizer.MIDI.Value as MV++import qualified Synthesizer.MIDI.EventList as MIDIEv+import Synthesizer.MIDI.EventList (StrictTime, )++import qualified Synthesizer.PiecewiseConstant.Signal as PC+import qualified Synthesizer.Storable.Cut as CutSt+import qualified Synthesizer.Generic.Cut as CutG+import qualified Synthesizer.Zip as Zip++import qualified Sound.MIDI.Message.Class.Check as Check+import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg++import Control.DeepSeq (NFData, rnf, )++import qualified Data.EventList.Relative.TimeBody  as EventList+import qualified Data.EventList.Relative.BodyTime  as EventListBT+import qualified Data.EventList.Relative.TimeTime  as EventListTT+import qualified Data.EventList.Relative.TimeMixed as EventListTM+import qualified Data.EventList.Relative.MixedTime as EventListMT+import qualified Data.EventList.Absolute.TimeBody  as AbsEventList++import qualified Numeric.NonNegative.Wrapper as NonNegW+import qualified Numeric.NonNegative.Class as NonNeg++import qualified Algebra.Transcendental as Trans+import qualified Algebra.RealRing       as RealRing+import qualified Algebra.Field          as Field+import qualified Algebra.Additive       as Additive+import qualified Algebra.ToInteger      as ToInteger++import qualified Data.StorableVector as SV+import qualified Data.StorableVector.ST.Strict as SVST+import Foreign.Storable (Storable, )++import qualified Control.Monad.Trans.Writer as MW+import qualified Control.Monad.Trans.State as MS+import qualified Control.Monad.Trans.Class as MT+import Control.Monad.IO.Class (liftIO, )++import qualified Data.Traversable as Trav+import Data.Traversable (Traversable, )+import Data.Foldable (traverse_, )++import Control.Arrow (Arrow, arr, (^<<), (<<^), )+import Control.Category ((.), )++import qualified Data.Map as Map++import qualified Data.List.HT as ListHT+import qualified Data.Maybe as Maybe+import Data.Monoid (Monoid, mempty, mappend, )+import Data.Maybe (maybeToList, )+import Data.Tuple.HT (mapFst, mapPair, )++import NumericPrelude.Numeric+import NumericPrelude.Base hiding ((.), sequence, )+import Prelude ()+++type Events event = EventListTT.T StrictTime [event]+++initWith ::+   (y -> c) ->+   c ->+   PIO.T+      (EventListTT.T StrictTime [y])+      (EventListBT.T PC.ShortStrictTime c)+initWith f initial =+   PIO.traverse initial $+      \evs0 -> do+         y0 <- MS.get+         fmap (PC.subdivideLongStrict . EventListMT.consBody y0) $+            Trav.traverse (\ys -> traverse_ (MS.put . f) ys >> MS.get) evs0++slice ::+   (Check.C event) =>+   (event -> Maybe Int) ->+   (Int -> y) -> y ->+   PIO.T+      (Events event)+      (EventListBT.T PC.ShortStrictTime y)+slice select f initial =+   initWith f initial . mapMaybe select++++mapMaybe ::+   (Arrow arrow, Functor f) =>+   (a -> Maybe b) ->+   arrow (f [a]) (f [b])+mapMaybe f =+   arr $ fmap $ Maybe.mapMaybe f++catMaybes ::+   (Arrow arrow, Functor f) =>+   arrow (f [Maybe a]) (f [a])+catMaybes =+   arr $ fmap Maybe.catMaybes++traverse ::+   (Traversable f) =>+   s -> (a -> MS.State s b) ->+   PIO.T (f [a]) (f [b])+traverse initial f =+   PIO.traverse initial (Trav.traverse (Trav.traverse f))+++controllerLinear ::+   (Check.C event, Field.C y) =>+   MIDIEv.Channel ->+   MIDIEv.Controller ->+   (y,y) -> y ->+   PIO.T+      (Events event)+      (EventListBT.T PC.ShortStrictTime y)+controllerLinear chan ctrl bnd initial =+   slice (Check.controller chan ctrl)+      (MV.controllerLinear bnd) initial++controllerExponential ::+   (Check.C event, Trans.C y) =>+   MIDIEv.Channel ->+   MIDIEv.Controller ->+   (y,y) -> y ->+   PIO.T+      (Events event)+      (EventListBT.T PC.ShortStrictTime y)+controllerExponential chan ctrl bnd initial =+   slice (Check.controller chan ctrl)+      (MV.controllerExponential bnd) initial++pitchBend ::+   (Check.C event, Trans.C y) =>+   MIDIEv.Channel ->+   y -> y ->+   PIO.T+      (Events event)+      (EventListBT.T PC.ShortStrictTime y)+pitchBend chan range center =+   slice (Check.pitchBend chan)+      (MV.pitchBend range center) center++channelPressure ::+   (Check.C event, Trans.C y) =>+   MIDIEv.Channel ->+   y -> y ->+   PIO.T+      (Events event)+      (EventListBT.T PC.ShortStrictTime y)+channelPressure chan maxVal initial =+   slice (Check.channelPressure chan)+      (MV.controllerLinear (zero,maxVal)) initial++bendWheelPressure ::+   (Check.C event, RealRing.C y, Trans.C y) =>+   MIDIEv.Channel ->+   Int -> y -> y ->+   PIO.T+      (Events event)+      (EventListBT.T PC.ShortStrictTime (BM.T y))+bendWheelPressure chan+      pitchRange wheelDepth pressDepth =+   let toBM = BM.fromBendWheelPressure pitchRange wheelDepth pressDepth+   in  initWith toBM (toBM BWP.deflt)+       .+       catMaybes+       .+       traverse BWP.deflt (BWP.check chan)+++-- might be moved to synthesizer-core+constant ::+   (Arrow arrow) =>+   y -> arrow (Events event) (EventListBT.T PC.ShortStrictTime y)+constant y = arr $+   EventListBT.singleton y .+   NonNegW.fromNumberMsg "MIDI.CausalIO.constant" .+   fromIntegral .+   EventListTT.duration++_constant ::+   (Arrow arrow, CutG.Read input) =>+   y -> arrow input (EventListBT.T PC.ShortStrictTime y)+_constant y = arr $+   EventListBT.singleton y .+   NonNegW.fromNumberMsg "MIDI.CausalIO.constant" .+   CutG.length++++noteEvents ::+   (Check.C event, Arrow arrow) =>+   MIDIEv.Channel ->+   arrow+      (EventListTT.T StrictTime [event])+      (EventListTT.T StrictTime+         [Either MIDIEv.Program (MIDIEv.NoteBoundary Bool)])+noteEvents chan =+   mapMaybe $ MIDIEv.checkNoteEvent chan+++embedPrograms ::+   MIDIEv.Program ->+   PIO.T+      (EventListTT.T StrictTime+         [Either MIDIEv.Program (MIDIEv.NoteBoundary Bool)])+      (EventListTT.T StrictTime+         [MIDIEv.NoteBoundary (Maybe MIDIEv.Program)])+embedPrograms initPgm =+   catMaybes .+   traverse initPgm MIDIEv.embedProgramState+++type GateChunk = Gate.Chunk MIDIEv.Velocity+type Instrument y chunk = y -> y -> PIO.T GateChunk chunk+type Bank y chunk = MIDIEv.Program -> Instrument y chunk++++{-+for distinction of notes with the same pitch++We must use Integer instead of Int, in order to avoid an overflow+that would invalidate the check for unmatched NoteOffs+that is based on comparison of the NoteIds.+We cannot re-use NoteIds easily,+since the events at one time point are handled out of order.+-}+newtype NoteId = NoteId Integer+   deriving (Show, Eq, Ord)++succNoteId :: NoteId -> NoteId+succNoteId (NoteId n) = NoteId (n+1)++flattenNoteIdRange :: (NoteId,NoteId) -> [NoteId]+flattenNoteIdRange (start,afterEnd) =+   takeWhile (<afterEnd) $ iterate succNoteId start+++newtype NoteOffList =+   NoteOffList {+      unwrapNoteOffList :: EventListTT.T StrictTime [NoteBoundary NoteId]+   }+++instance CutG.Read NoteOffList where+   null (NoteOffList evs) =+      EventListTT.isPause evs && EventListTT.duration evs == 0+   length = fromIntegral . EventListTT.duration . unwrapNoteOffList++instance CutG.NormalForm NoteOffList where+   evaluateHead =+      EventListMT.switchTimeL (\t _ -> rnf (NonNegW.toNumber t)) .+      unwrapNoteOffList++instance Monoid NoteOffList where+   mempty = NoteOffList (EventListTT.pause mempty)+   mappend (NoteOffList xs) (NoteOffList ys) =+      NoteOffList (mappend xs ys)++{- |+The function defined here are based on the interpretation+of event lists as piecewise constant signals.+They do not fit to the interpretation of atomic events.+Because e.g. it makes no sense to split an atomic event into two instances by splitAt,+and it is also not clear, whether dropping the first chunk+shall leave a chunk of length zero+or remove that chunk completely.+-}+instance CutG.Transform NoteOffList where+   take n (NoteOffList xs) =+      NoteOffList $+      EventListTT.takeTime+         (NonNegW.fromNumberMsg "NoteOffList.take" $ fromIntegral n) xs+   drop n (NoteOffList xs) =+      NoteOffList $+      EventListTT.dropTime+         (NonNegW.fromNumberMsg "NoteOffList.drop" $ fromIntegral n) xs+   splitAt n (NoteOffList xs) =+      mapPair (NoteOffList, NoteOffList) $+      EventListTT.splitAtTime+         (NonNegW.fromNumberMsg "NoteOffList.splitAtTime" $ fromIntegral n) xs++   -- cf. ChunkySize.dropMarginRem+   dropMarginRem =+      CutG.dropMarginRemChunky+         (fmap fromIntegral . EventListTT.getTimes . unwrapNoteOffList)++   reverse (NoteOffList xs) =+      NoteOffList . EventListTT.reverse $ xs+++findEvent ::+   (a -> Bool) ->+   EventListTT.T StrictTime [a] ->+   (EventListTT.T StrictTime [a], Maybe a)+findEvent p =+   EventListTT.foldr+      (\t -> mapFst (EventListMT.consTime t))+      (\evs rest ->+         case ListHT.break p evs of+            (prefix, suffix) ->+               mapFst (EventListMT.consBody prefix) $+               case suffix of+                  [] -> rest+                  ev:_ -> (EventListTT.pause mempty, Just ev))+      (EventListBT.empty, Nothing)++gateFromNoteOffs ::+   (MIDIEv.Pitch, NoteId) ->+   NoteOffList ->+   GateChunk+gateFromNoteOffs pitchNoteId (NoteOffList noteOffs) =+   let dur = EventListTT.duration noteOffs+       (sustain, mEnd) =+          findEvent+             (\bnd ->+                case bnd of+                   -- AllNotesOff -> True+                   NoteBoundary endPitch _ noteId ->+                      pitchNoteId == (endPitch, noteId))+          noteOffs+   in  Gate.chunk dur $+       flip fmap mEnd $ \end ->+       (EventListTT.duration sustain,+        case end of+           NoteBoundary _ endVel _ -> endVel+           {-+           AllNotesOff ->+              VoiceMsg.toVelocity VoiceMsg.normalVelocity -} )+++data NoteBoundary a =+     NoteBoundary VoiceMsg.Pitch VoiceMsg.Velocity a+--   | AllSoundOff+   deriving (Eq, Show)++{- |+We count NoteIds per pitch,+such that the pair (pitch,noteId) identifies a note.+We treat nested notes in a first-in-first-out order (FIFO).+E.g.++> On, On, On, Off, Off, Off++is interpreted as++> On 0, On 1, On 2, Off 0, Off 1, Off 2++NoteOffs without previous NoteOns are thrown away.+-}+assignNoteIds ::+   (Traversable f) =>+   PIO.T+      (f [MIDIEv.NoteBoundary (Maybe MIDIEv.Program)])+      (f [NoteBoundary (NoteId, Maybe MIDIEv.Program)])+assignNoteIds =+   fmap concat+   ^<<+   traverse Map.empty (\bnd ->+      case bnd of+         MIDIEv.AllNotesOff -> do+            notes <- MS.get+            MS.put Map.empty+            return $+               concatMap (\(pitch, range) ->+                  map+                     (\noteId ->+                        NoteBoundary pitch+                           (VoiceMsg.toVelocity VoiceMsg.normalVelocity)+                           (noteId, Nothing))+                     (flattenNoteIdRange range)) $+               Map.toList notes+         MIDIEv.NoteBoundary pitch vel mpgm ->+            fmap (fmap (\noteId ->+               NoteBoundary pitch vel (noteId,mpgm))) $+            case mpgm of+               Nothing -> do+                  mNoteId <- MS.gets (Map.lookup pitch)+                  case mNoteId of+                     Nothing -> return []+                     Just (nextNoteOffId, nextNoteOnId) ->+                        if nextNoteOffId >= nextNoteOnId+                          then return []+                          else do+                             MS.modify (Map.insert pitch (succNoteId nextNoteOffId, nextNoteOnId))+                             return [nextNoteOffId]+               Just _ -> do+                  mNoteId <- MS.gets (Map.lookup pitch)+                  let (nextNoteOffId, nextNoteOnId) =+                         case mNoteId of+                            Nothing -> (NoteId 0, NoteId 0)+                            Just ids -> ids++                  MS.modify (Map.insert pitch (nextNoteOffId, succNoteId nextNoteOnId))+                  return [nextNoteOnId])++applyInstrumentCore ::+   (Arrow arrow, Trans.C y) =>+   ((MIDIEv.Pitch, NoteId) -> noteOffListCtrl -> gateCtrl) ->+   (MIDIEv.Program -> y -> y -> PIO.T gateCtrl chunk) ->+   arrow+      (EventListTT.T StrictTime+         [NoteBoundary (NoteId, Maybe MIDIEv.Program)])+      (Zip.T+         NoteOffList+         (EventListTT.T StrictTime [PIO.T noteOffListCtrl chunk]))+applyInstrumentCore makeGate bank = arr $+   uncurry Zip.Cons .+   mapFst NoteOffList .+   EventListTT.unzip .+   fmap (ListHT.unzipEithers . fmap (\ev ->+      case ev of+--         MIDIEv.AllNotesOff -> Left MIDIEv.AllNotesOff+         NoteBoundary pitch vel (noteId, mpgm) ->+            case mpgm of+               Nothing -> Left $ NoteBoundary pitch vel noteId+               Just pgm ->+                  Right $+                     bank pgm (MV.velocity vel)+                        (MV.frequencyFromPitch pitch)+                     <<^+                     makeGate (pitch, noteId)))++applyInstrument ::+   (Arrow arrow, Trans.C y) =>+   Bank y chunk ->+   arrow+      (EventListTT.T StrictTime+         [NoteBoundary (NoteId, Maybe MIDIEv.Program)])+      (Zip.T+         NoteOffList+         (EventListTT.T StrictTime [PIO.T NoteOffList chunk]))+applyInstrument = applyInstrumentCore gateFromNoteOffs+++type ModulatedBank y ctrl chunk =+        MIDIEv.Program -> y -> y ->+        PIO.T (Zip.T GateChunk ctrl) chunk++applyModulatedInstrument ::+   (Arrow arrow, Trans.C y, CutG.Read ctrl) =>+   ModulatedBank y ctrl chunk ->+   arrow+      (Zip.T+         (EventListTT.T StrictTime+            [NoteBoundary (NoteId, Maybe MIDIEv.Program)])+         ctrl)+      (Zip.T+         (Zip.T NoteOffList ctrl)+         (EventListTT.T StrictTime+            [PIO.T (Zip.T NoteOffList ctrl) chunk]))+applyModulatedInstrument bank =+   (\(Zip.Cons (Zip.Cons noteOffs events) ctrl) ->+      Zip.Cons (Zip.Cons noteOffs ctrl) events)+   ^<<+   Zip.arrowFirst+      (applyInstrumentCore+         (Zip.arrowFirst . gateFromNoteOffs) bank)+++{- |+Turn an event list with bundles of elements+into an event list with single events.+ToDo: Move to event-list package?+-}+flatten ::+   (NonNeg.C time) =>+   a ->+   EventListTT.T time [a] ->+   EventListTT.T time a+flatten empty =+   EventListTT.foldr+      EventListMT.consTime+      (\bt xs ->+         uncurry EventListMT.consBody $+         case bt of+            [] -> (empty, xs)+            b:bs -> (b, foldr (\c rest -> EventListTT.cons NonNeg.zero c rest) xs bs))+      EventListBT.empty+++flattenControlSchedule ::+   (Monoid chunk, Arrow arrow) =>+   arrow+      (Zip.T ctrl+         (EventListTT.T StrictTime [PIO.T ctrl chunk]))+      (Zip.T ctrl+         (EventListTT.T StrictTime (PIO.T ctrl chunk)))+flattenControlSchedule = arr $+   \(Zip.Cons ctrl evs) ->+      -- Zip.consChecked "flattenControlSchedule" ctrl $+      Zip.Cons ctrl $+      flatten (arr (const mempty)) evs++++data CausalState a b =+   forall state.+   CausalState+      (a -> state -> IO (b, state))+      (state -> IO ())+      state++_applyChunkSimple :: CausalState a b -> a -> IO (b, CausalState a b)+_applyChunkSimple (CausalState next delete state0) input = do+   (output, state1) <- next input state0+   return (output, CausalState next delete state1)++applyChunk ::+   (CutG.Read a, CutG.Read b) =>+   CausalState a b -> a -> IO (b, Maybe (CausalState a b))+applyChunk (CausalState next delete state0) input = do+   (output, state1) <- next input state0+   cs <-+      if CutG.length output < CutG.length input+        then do+           delete state1+           return Nothing+        else return $ Just $ CausalState next delete state1+   return (output, cs)++-- could be moved to synthesizer-core+applyModulation ::+   (CutG.Transform ctrl, CutG.NormalForm ctrl,+    CutG.Read chunk,+    Monoid time, ToInteger.C time) =>+   PIO.T+      (Zip.T ctrl (EventListTT.T time (PIO.T ctrl chunk)))+      (EventListTT.T time chunk)+applyModulation = PIO.Cons+   (\(Zip.Cons ctrl evs) acc0 -> do+      acc1 <- mapM (flip applyChunk ctrl) acc0+      let (accChunks, acc2) = unzip acc1++      (newChunks, newAcc) <-+         MW.runWriterT $+         flip MS.evalStateT ctrl $+         EventListTT.mapM+            (\time -> do+               ctrl_ <- MS.gets (CutG.drop (fromIntegral time))+               MS.put ctrl_+               return (case CutG.evaluateHead ctrl_ of () -> time))+            (\(PIO.Cons next create delete) -> do+               state0 <- liftIO create+               (chunk, state1) <-+                  liftIO . applyChunk (CausalState next delete state0)+                  =<< MS.get+               MT.lift $ MW.tell $ maybeToList state1+               return chunk)+            evs++      return+         (EventListTM.prependBodyEnd+             (EventList.fromPairList $+              map ((,) mempty) accChunks)+             newChunks,+          Maybe.catMaybes acc2 ++ newAcc))++   (return [])+   (mapM_ (\(CausalState _ close state) -> close state))++-- move synthesizer-core:CausalIO+arrangeStorable ::+   (Arrow arrow, Storable a, Additive.C a) =>+   arrow+      (EventListTT.T StrictTime (SV.Vector a))+      (SV.Vector a)+arrangeStorable =+   arr $ \evs ->+   SVST.runSTVector (do+      v <- SVST.new (fromIntegral $ EventListTT.duration evs) zero+      mapM_ (uncurry $ CutSt.addChunkToBuffer v) $+         AbsEventList.toPairList $+         AbsEventList.mapTime fromIntegral $+         EventList.toAbsoluteEventList 0 $+         EventListTM.switchTimeR const evs+      return v)++++sequenceCore ::+   (Check.C event, Monoid chunk, CutG.Read chunk, Trans.C y) =>+   MIDIEv.Channel ->+   Bank y chunk ->+   PIO.T (Events event) (EventListTT.T StrictTime chunk)+sequenceCore channel bank =+   applyModulation+   .+   flattenControlSchedule+   .+   applyInstrument bank+   .+   assignNoteIds+   .+   embedPrograms (VoiceMsg.toProgram 0)+   .+   noteEvents channel+++sequenceModulated ::+   (Check.C event, Monoid chunk, CutG.Read chunk,+    CutG.Transform ctrl, CutG.NormalForm ctrl, Trans.C y) =>+   MIDIEv.Channel ->+   ModulatedBank y ctrl chunk ->+   PIO.T (Zip.T (Events event) ctrl) (EventListTT.T StrictTime chunk)+sequenceModulated channel bank =+   applyModulation+   .+   flattenControlSchedule+   .+   applyModulatedInstrument bank+   .+   Zip.arrowFirst+      (assignNoteIds+       .+       embedPrograms (VoiceMsg.toProgram 0)+       .+       noteEvents channel)+++sequenceModulatedMultiProgram ::+   (Check.C event, Monoid chunk, CutG.Read chunk,+    CutG.Transform ctrl, CutG.NormalForm ctrl, Trans.C y) =>+   MIDIEv.Channel ->+   MIDIEv.Program ->+   ModulatedBank y ctrl chunk ->+   PIO.T (Zip.T (Events event) ctrl) (EventListTT.T StrictTime chunk)+sequenceModulatedMultiProgram channel initPgm bank =+   applyModulation+   .+   flattenControlSchedule+   .+   applyModulatedInstrument bank+   .+   Zip.arrowFirst+      (assignNoteIds+       .+       embedPrograms initPgm+       .+       noteEvents channel)+++sequenceStorable ::+   (Check.C event, Storable a, Additive.C a, Trans.C y) =>+   MIDIEv.Channel ->+   Bank y (SV.Vector a) ->+   PIO.T (Events event) (SV.Vector a)+sequenceStorable channel bank =+   arrangeStorable+   .+   sequenceCore channel bank
+ src/Synthesizer/MIDI/Dimensional.hs view
@@ -0,0 +1,445 @@+{- |+Convert MIDI events of a MIDI controller to a control signal.+-}+{-# LANGUAGE NoImplicitPrelude #-}+module Synthesizer.MIDI.Dimensional where++import qualified Sound.MIDI.Message.Class.Check as Check++import qualified Synthesizer.MIDI.PiecewiseConstant as MidiPC+import qualified Synthesizer.MIDI.EventList as MidiEL+import qualified Synthesizer.MIDI.Generic as MidiG+import Synthesizer.MIDI.EventList+          (Channel, Controller, Note(Note), Program, )+import Synthesizer.MIDI.Generic (errorNoProgram, )++import qualified Synthesizer.MIDI.Value as MV+import qualified Synthesizer.MIDI.Dimensional.Value as DMV++import qualified Synthesizer.Dimensional.Causal.Process    as Causal+import qualified Synthesizer.Dimensional.Causal.Filter     as Filt++import qualified Synthesizer.Dimensional.Rate as Rate+import qualified Synthesizer.Dimensional.Rate.Oscillator as OsciR+import qualified Synthesizer.Dimensional.Signal.Private as SigA+import qualified Synthesizer.Dimensional.Process as Proc+import qualified Synthesizer.Dimensional.Amplitude as Amp+import qualified Synthesizer.Dimensional.Amplitude.Displacement as DispA+import qualified Synthesizer.Dimensional.Amplitude.Filter as FiltA+import qualified Synthesizer.Dimensional.Wave as WaveD++import qualified Synthesizer.Basic.Wave          as Wave++import Synthesizer.Dimensional.Causal.Process ((<<<), )+import Synthesizer.Dimensional.Process (($:), )++import qualified Synthesizer.PiecewiseConstant.Signal as PC+import qualified Synthesizer.ChunkySize as ChunkySize++import qualified Synthesizer.Generic.Cut          as CutG+import qualified Synthesizer.Generic.Signal2      as SigG2+import qualified Synthesizer.Generic.Signal       as SigG+import qualified Synthesizer.Storable.Cut         as CutSt+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.TimeBody  as EventList++import Foreign.Storable (Storable, )++import qualified Number.NonNegative as NonNegW+import qualified Number.NonNegativeChunky as Chunky++import qualified Numeric.NonNegative.Chunky as Chunky98++import qualified Algebra.DimensionTerm as Dim+import qualified Number.DimensionTerm as DN++import qualified Algebra.Transcendental as Trans+import qualified Algebra.Module         as Module+import qualified Algebra.RealField      as RealField+import qualified Algebra.Field          as Field++import Control.Category (Category, (.), )+import Control.Applicative (Applicative, pure, (<*>), liftA2, )+import Control.Monad.Trans.State (State, evalState, state, gets, )+import Control.Monad (liftM, )++import NumericPrelude.Base hiding (id, (.), )+import NumericPrelude.Numeric+import Prelude (RealFrac, )+++type Signal s v y signal =+   AmpSignal s (Amp.Dimensional v y) signal++type AmpSignal s amp signal =+   SigA.T (Rate.Phantom s) amp signal++{- |+This type ensures that all signals generated from the event list+share the same sample rate.+-}+newtype Filter event s u t a =+   Filter (MidiEL.Filter event (Proc.T s u t a))++{-# INLINE runFilter #-}+runFilter ::+   Check.C event =>+   EventList.T MidiEL.StrictTime [event] ->+   Filter event s u t a -> Proc.T s u t a+runFilter evs (Filter f) =+   evalState f evs++instance Functor (Filter event s u t) where+   fmap f (Filter flt) =+      Filter (fmap (fmap f) flt)++instance Applicative (Filter event s u t) where+   pure x = Filter (pure (pure x))+   Filter f <*> Filter x =+      Filter (liftA2 (<*>) f x)+++{-# INLINE piecewiseConstant #-}+piecewiseConstant ::+   (SigG.Write sig y) =>+   SigA.T rate amp (MidiPC.T y) ->+   SigA.T rate amp (sig y)+piecewiseConstant =+   SigA.processBody MidiG.piecewiseConstant++{-# INLINE controllerLinear #-}+controllerLinear ::+   (Check.C event, Field.C y, Ord y, Dim.C u, Dim.C v) =>+   Channel -> Controller ->+   (DN.T v y, DN.T v y) -> DN.T v y ->+   Filter event s u t (Signal s v y (MidiPC.T y))+controllerLinear chan ctrl bnd initial =+   Filter $+   liftM+      (let amp = max initial (uncurry max bnd)+       in  return . SigA.fromBody amp .+           MidiPC.initWith+              (DMV.controllerLinear amp bnd) (DN.divToScalar initial amp)) $+   MidiEL.getControllerEvents chan ctrl+++{-# INLINE controllerExponential #-}+controllerExponential ::+   (Check.C event, Trans.C y, Ord y, Dim.C u, Dim.C v) =>+   Channel -> Controller ->+   (DN.T v y, DN.T v y) -> DN.T v y ->+   Filter event s u t (Signal s v y (MidiPC.T y))+controllerExponential chan ctrl bnd initial =+   Filter $+   liftM+      (let amp = max initial (uncurry max bnd)+       in  return . SigA.fromBody amp .+           MidiPC.initWith+              (DMV.controllerExponential amp bnd) (DN.divToScalar initial amp)) $+   MidiEL.getControllerEvents chan ctrl+++{- |+@pitchBend channel range center@:+emits frequencies on an exponential scale from+@center/range@ to @center*range@.+-}+{-# INLINE pitchBend #-}+pitchBend ::+   (Check.C event, Trans.C y, Ord y, Dim.C u, Dim.C v) =>+   Channel ->+   y -> DN.T v y ->+   Filter event s u t (Signal s v y (MidiPC.T y))+pitchBend chan range center =+   Filter $+   liftM+      (let amp = DN.scale (max range (recip range)) center+       in  return . SigA.fromBody amp .+           MidiPC.initWith+              (DMV.pitchBend amp range center) (DN.divToScalar center amp)) $+   MidiEL.getSlice (Check.pitchBend chan)+--   MidiEL.getPitchBendEvents chan+++{-# INLINE channelPressure #-}+channelPressure ::+   (Check.C event, Trans.C y, Ord y, Dim.C u, Dim.C v) =>+   Channel ->+   DN.T v y -> DN.T v y ->+   Filter event s u t (Signal s v y (MidiPC.T y))+channelPressure chan maxVal initVal =+   Filter $+   liftM+      (return . SigA.fromBody maxVal .+       MidiPC.initWith+          (DMV.controllerLinear maxVal (zero,maxVal))+          (DN.divToScalar initVal maxVal)) $+   MidiEL.getSlice (Check.channelPressure chan)+--   MidiEL.getPitchBendEvents chan+++{-# INLINE bendWheelPressure #-}+bendWheelPressure ::+   (Check.C event,+    SigG.Write sig q, SigG2.Transform sig q q,+    RealField.C q, Trans.C q, Module.C q q, Dim.C u) =>+   Channel ->+   Int -> DN.T (Dim.Recip u) q -> q -> q ->+   Filter event s u q (Signal s Dim.Scalar q (sig q))+bendWheelPressure chan+     pitchRange speed wheelDepth pressDepth =+   pure+      (\bend fm press  osci env ->+         let modu =+                DispA.raise 1 $+                FiltA.envelope+                   osci+                   (DispA.mix+                      (SigA.restore fm)+                      (SigA.restore press))++         in  Causal.apply+                (env <<< Causal.feedSnd modu <<< Causal.canonicalizeFlat)+                (piecewiseConstant bend))++    $: pitchBend chan (2^?(fromIntegral pitchRange/12)) (DN.scalar 1)+    $: controllerLinear chan VoiceMsg.modulation (zero, DN.scalar wheelDepth) zero+    $: channelPressure chan (DN.scalar pressDepth) 0++    $: Filter (return $ OsciR.static (WaveD.flat Wave.sine) zero speed)+    $: Filter (return $ Filt.envelope)+++type LazyTime s = SigA.T (Rate.Phantom s) Amp.Abstract ChunkySize.T+-- type LazyTime s = SigA.T (Rate.Phantom s) Amp.Abstract SigStV.LazySize+-- type LazyTime s = SigA.T (Rate.Phantom s) Amp.Abstract MidiEL.LazyTime++type Instrument s u v q signal =+   ModulatedInstrument s u q (Signal s v q signal)++type ModulatedInstrument s u q signal =+   q -> DN.T (Dim.Recip u) q ->+   Proc.T s u q (LazyTime s -> signal)++type Bank s u q signal =+   Program -> ModulatedInstrument s u q signal+++{-# INLINE chunkySizeFromLazyTime #-}+chunkySizeFromLazyTime :: MidiEL.LazyTime -> ChunkySize.T+chunkySizeFromLazyTime =+   Chunky.fromChunks .+   map (SigG.LazySize . NonNegW.toNumber) .+   concatMap PC.chopLongTime .+   Chunky98.toChunks .+   Chunky98.normalize+++{-# INLINE renderInstrument #-}+renderInstrument ::+   (Trans.C q) =>+   Bank s Dim.Time q signal ->+   Note ->+   Proc.T s Dim.Time q signal+renderInstrument instrument (Note pgm pitch vel dur) =+   fmap ($ SigA.abstractFromBody $ chunkySizeFromLazyTime dur) $+   instrument pgm+      (MV.velocity vel)+      (DMV.frequencyFromPitch pitch)++{- |+Instrument parameters are:+velocity from -1 to 1+(0 is the normal pressure, no pressure aka NoteOff is not supported),+frequency is given in Hertz+-}+{-# INLINE makeInstrumentSounds #-}+makeInstrumentSounds ::+   (Trans.C q) =>+   Bank s Dim.Time q signal ->+   EventList.T time [Note] ->+   Proc.T s Dim.Time q (EventList.T time [signal])+makeInstrumentSounds bank =+   EventList.mapBodyM (mapM (renderInstrument bank))+++{-# INLINE sequence #-}+sequence ::+   (Check.C event, RealFrac q, Storable y, Module.C q y, Trans.C q, Dim.C v) =>+   SVL.ChunkSize ->+   DN.T v q ->+   Channel ->+   Instrument s Dim.Time v q (SigSt.T y) ->+   Filter event s Dim.Time q (Signal s v q (SigSt.T y))+sequence chunkSize amp chan instr =+   fmap (renderSequence chunkSize amp) $+   prepareTones chan errorNoProgram (const instr)++{-+{-# INLINE sequence #-}+sequence ::+   (Check.C event,+    RealFrac q, Storable y, Module.C q y, Trans.C q, Dim.C v) =>+   SVL.ChunkSize ->+   DN.T v q ->+   Channel ->+   Instrument s Dim.Time v q y ->+   Filter event (Proc.T s Dim.Time q (Signal s v q (SigSt.T y)))+sequence chunkSize amp chan instr =+   fmap ((CutA.arrangeStorableVolume undefined  {- chunkSize -} amp undefined $:) .+         fmap+            (EventListTM.switchTimeR const .+             EventListTT.mapTime fromIntegral .+             insertBreaksGen (SigA.fromBody amp SigSt.empty)) .+         makeInstrumentSounds instr .+         MidiEL.matchNoteEvents) $+   MidiEL.getNoteEvents chan+-}+++{-# INLINE sequenceModulated #-}+sequenceModulated ::+   (Check.C event,+    CutG.Transform ctrl,  CutG.NormalForm ctrl,+    RealFrac q, Storable y,+    Module.C q y, Trans.C q, Dim.C v) =>+   SVL.ChunkSize ->+   DN.T v q ->+   Channel ->+   ModulatedInstrument s Dim.Time q+      (AmpSignal s amp ctrl -> Signal s v q (SigSt.T y)) ->+   Filter event s Dim.Time q+      (AmpSignal s amp ctrl -> Signal s v q (SigSt.T y))+sequenceModulated chunkSize amp chan instr =+   fmap (flip $ \ctrl ->+      renderSequence chunkSize amp .+      applyModulator (applyModulation ctrl)) $+   prepareTones chan errorNoProgram (const instr)++{-# INLINE sequenceModulated2 #-}+sequenceModulated2 ::+   (Check.C event,+    CutG.Transform ctrl0, CutG.NormalForm ctrl0,+    CutG.Transform ctrl1, CutG.NormalForm ctrl1,+    RealFrac q, Storable y,+    Module.C q y, Trans.C q, Dim.C v) =>+   SVL.ChunkSize ->+   DN.T v q ->+   Channel ->+   ModulatedInstrument s Dim.Time q+      (AmpSignal s amp0 ctrl0 -> AmpSignal s amp1 ctrl1 -> Signal s v q (SigSt.T y)) ->+   Filter event s Dim.Time q+      (AmpSignal s amp0 ctrl0 -> AmpSignal s amp1 ctrl1 -> Signal s v q (SigSt.T y))+sequenceModulated2 chunkSize amp chan instr =+   fmap (\evs ctrl0 ctrl1 ->+      renderSequence chunkSize amp .+      applyModulator+         (applyModulation ctrl1 .+          applyModulation ctrl0)+      $ evs) $+   prepareTones chan errorNoProgram (const instr)+++{-# INLINE sequenceMultiModulated #-}+sequenceMultiModulated ::+   (Check.C event, RealFrac q, Storable y,+    Module.C q y, Trans.C q, Dim.C v) =>+   SVL.ChunkSize ->+   DN.T v q ->+   Channel ->+   ModulatedInstrument s Dim.Time q instrument ->+   Filter event s Dim.Time q+      (MidiG.Modulator instrument (Signal s v q (SigSt.T y))) ->+   Filter event s Dim.Time q (Signal s v q (SigSt.T y))+sequenceMultiModulated chunkSize amp chan instr modu =+   fmap (renderSequence chunkSize amp) $+   (fmap applyModulator modu $:+    prepareTones chan errorNoProgram (const instr))++{-# INLINE prepareTones #-}+prepareTones ::+   (Check.C event, RealFrac q, Trans.C q) =>+   -- ToDo: use time value+   Channel ->+   Program ->+   Bank s Dim.Time q signal ->+   Filter event s Dim.Time q (EventList.T MidiEL.StrictTime [signal])+prepareTones chan initPgm instr =+   Filter $+   fmap (makeInstrumentSounds instr .+         MidiEL.matchNoteEvents .+         MidiEL.embedPrograms initPgm) $+   MidiEL.getNoteEvents chan++{-# INLINE applyModulation #-}+applyModulation ::+   (CutG.Transform signal, CutG.NormalForm signal) =>+   AmpSignal s amp signal ->+   MidiG.Modulator (AmpSignal s amp signal -> body) body+applyModulation ctrl =+   MidiG.Modulator ctrl advanceModulationChunk gets++{-# INLINE applyModulator #-}+applyModulator ::+   MidiG.Modulator a b ->+   EventList.T MidiEL.StrictTime [a] ->+   EventList.T MidiEL.StrictTime [b]+applyModulator =+   MidiG.applyModulator++{-# INLINE renderSequence #-}+renderSequence ::+   (Storable y, Module.C q y, Dim.C u, Field.C q) =>+   SVL.ChunkSize ->+   DN.T u q ->+   EventList.T MidiEL.StrictTime [Signal s u q (SigSt.T y)] ->+   Signal s u q (SigSt.T y)+renderSequence chunkSize amp =+   SigA.fromBody amp .+   CutSt.arrangeEquidist chunkSize .+   {- This concatenates times across empty events,+      and thus is too strict.+   EventList.flatten .+   -}+   MidiG.flatten .+   EventList.mapTime fromIntegral .+   EventList.mapBody (map (SigA.vectorSamples (flip DN.divToScalar amp)))+++{-# INLINE advanceModulationChunky #-}+advanceModulationChunky ::+   (CutG.Transform signal, CutG.NormalForm signal) =>+   MidiEL.LazyTime -> State (AmpSignal s amp signal) MidiEL.LazyTime+advanceModulationChunky =+   liftM Chunky98.fromChunks .+   mapM advanceModulationChunk .+   Chunky98.toChunks++{-# INLINE advanceModulationChunk #-}+advanceModulationChunk ::+   (CutG.Transform signal, CutG.NormalForm signal) =>+   MidiEL.StrictTime -> State (AmpSignal s amp signal) MidiEL.StrictTime+advanceModulationChunk t = state $ \xs ->+   let ys = SigA.processBody (CutG.drop (fromIntegral t)) xs+   in  (MidiG.evaluateVectorHead (SigA.body ys) t, ys)+++{-# INLINE sequenceMultiProgram #-}+sequenceMultiProgram ::+   (Check.C event, RealFrac q, Storable y, Module.C q y, Trans.C q, Dim.C v) =>+   SVL.ChunkSize ->+   DN.T v q ->+   Channel ->+   Program ->+--   Bank s Dim.Time q (Signal s v q (SigSt.T y)) ->+   [Instrument s Dim.Time v q (SigSt.T y)] ->+   Filter event s Dim.Time q (Signal s v q (SigSt.T y))+sequenceMultiProgram chunkSize amp chan initPgm instrs =+   let bank = MidiEL.makeInstrumentArray instrs+   in  fmap (renderSequence chunkSize amp) $+       prepareTones chan initPgm $+       MidiEL.getInstrumentFromArray bank initPgm
+ src/Synthesizer/MIDI/Dimensional/Example/Instrument.hs view
@@ -0,0 +1,205 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE Rank2Types #-}+module Synthesizer.MIDI.Dimensional.Example.Instrument where++import qualified Synthesizer.MIDI.Dimensional as MIDI+import qualified Synthesizer.MIDI.PiecewiseConstant as PC++import qualified Synthesizer.Dimensional.Causal.Process    as Causal+import qualified Synthesizer.Dimensional.Causal.Filter     as Filt++import qualified Synthesizer.Dimensional.Rate as Rate+import qualified Synthesizer.Dimensional.Rate.Cut as CutR+import qualified Synthesizer.Dimensional.Rate.Control as CtrlR+import qualified Synthesizer.Dimensional.Rate.Oscillator as OsciR+import qualified Synthesizer.Dimensional.Rate.Filter as FiltR+import qualified Synthesizer.Dimensional.Amplitude as Amp+import qualified Synthesizer.Dimensional.Amplitude.Cut as CutA+import qualified Synthesizer.Dimensional.Amplitude.Displacement as DispA+import qualified Synthesizer.Dimensional.Amplitude.Flat as Flat+import qualified Synthesizer.Dimensional.Amplitude.Analysis as AnaA+import qualified Synthesizer.Dimensional.Amplitude.Filter as FiltA+import qualified Synthesizer.Dimensional.RateAmplitude.Control as CtrlD+import qualified Synthesizer.Dimensional.ChunkySize.Signal as SigC+import qualified Synthesizer.Dimensional.Signal.Private as SigA+import qualified Synthesizer.Dimensional.Process as Proc++import Synthesizer.Dimensional.Causal.Process ((<<<), )+import Synthesizer.Dimensional.Wave ((&*~), )+import Synthesizer.Dimensional.Process (($:), )+import Synthesizer.Dimensional.Signal ((&*^), )+import Control.Applicative (liftA3, )++import qualified Synthesizer.Basic.Wave          as Wave+import qualified Synthesizer.Frame.Stereo        as Stereo++import qualified Synthesizer.Storable.Signal      as SigSt++import qualified Algebra.DimensionTerm as Dim+import qualified Number.DimensionTerm  as DN++import NumericPrelude.Numeric+import NumericPrelude.Base hiding (break, )+++type Real = Double+++{-# INLINE ping #-}+ping :: MIDI.Instrument s Dim.Time Dim.Voltage Real (SigSt.T Real)+ping vel freq =+   fmap (flip SigC.store)+      (FiltR.envelope+         $: CtrlR.exponential2 (DN.time 0.2)+         $: OsciR.static (DN.voltage (4**vel) &*~ Wave.saw) zero freq)+++{-+Generating the envelope requires great care:+ - you must avoid an append function that determines the common volume automatically,+   because the volume of the second part is only known after the first part is complete+ - you must terminate the release phase,+   otherwise you get an infinite signal for every played note+-}+{-# INLINE pingReleaseEnvelope #-}+pingReleaseEnvelope ::+   Real ->+   Proc.T s Dim.Time Real+      (MIDI.LazyTime s ->+       SigA.T (Rate.Phantom s) (Amp.Dimensional Dim.Scalar Real) (SigSt.T Real))+pingReleaseEnvelope vel =+   Proc.withParam $ \dur ->+   do decay <-+         fmap (SigC.store dur) $+         CtrlR.exponential2 (DN.time 0.4)+      end <- fmap (AnaA.endPrimitive zero) $ fmap ($decay) SigA.embedSampleRate+      release <-+         SigA.store (DN.time 0.01) $:+         (CutR.take (DN.time 0.3) $:+          fmap Flat.canonicalize+            (DN.scalar end &*^ CtrlR.exponential2 (DN.time 0.1)))+      append <- CutR.append+      return $ (DispA.inflate (DN.fromNumber $ 4**vel) (append decay release))+--      return $ DispA.inflate (DN.fromNumber $ 4**vel) decay++{-+   Proc.withParam $ \dur ->+   liftA2+      (\embed env ->+          let x = SigC.store dur env+              y = AnaA.end $ embed x+          in  )+      SigA.embedSampleRate+      (FiltR.envelope+         $: CtrlR.exponential2 (DN.time 0.2)+         $: OsciR.static (DN.voltage (4**vel) &*~ Wave.saw) zero freq)+-}++{-# INLINE pingRelease #-}+pingRelease :: MIDI.Instrument s Dim.Time Dim.Voltage Real (SigSt.T Real)+pingRelease vel freq =+   liftA3+      (\env ctrl osci dur ->+          Causal.apply+             (env <<< Causal.feedSnd osci)+             (ctrl dur))+      Filt.envelopeScalarDimension+      (pingReleaseEnvelope vel)+      (OsciR.static (DN.voltage 1 &*~ Wave.saw) zero freq)+++{-# INLINE pingReleaseFM #-}+pingReleaseFM ::+   MIDI.ModulatedInstrument s Dim.Time Real+      (MIDI.Signal s Dim.Scalar Real (SigSt.T Real) ->+       MIDI.Signal s Dim.Voltage Real (SigSt.T Real))+pingReleaseFM vel freq =+   liftA3+      (\env ctrl osci dur fm ->+          Causal.apply+             (env <<<+              Causal.feedSnd (osci (FiltA.amplifyScalarDimension freq $ SigA.restore fm)))+             (ctrl dur))+      Filt.envelopeScalarDimension+      (pingReleaseEnvelope vel)+      (OsciR.freqMod (DN.voltage 1 &*~ Wave.saw) zero)+++{-# INLINE pingStereoDetuneFM #-}+pingStereoDetuneFM ::+   MIDI.ModulatedInstrument s Dim.Time Real+      (MIDI.Signal s Dim.Scalar Real (PC.T Real) ->+       MIDI.Signal s Dim.Scalar Real (SigSt.T Real) ->+       MIDI.Signal s Dim.Voltage Real (SigSt.T (Stereo.T Real)))+pingStereoDetuneFM vel freq =+   liftA3+      (\env ctrl osci dur detuneSt fmSt ->+          let fm     = SigA.restore fmSt+              detune = SigA.restore detuneSt+              osciChan d =+                 osci (FiltA.amplifyScalarDimension freq+                    (FiltA.envelope (DispA.raise 1 d) fm))+          in  SigA.rewriteAmplitudeDimension Dim.identityLeft $+              Causal.apply+                 (env <<<+                  Causal.feedSnd (CutA.mergeStereo+                     (osciChan detune)+                     (osciChan $ FiltA.negate detune)))+                 (ctrl dur))+      Filt.envelopeVectorDimension+      (pingReleaseEnvelope vel)+      (OsciR.freqMod (DN.voltage 1 &*~ Wave.saw) zero)+++{- INLINE stringReleaseEnvelope -}+stringReleaseEnvelope ::+   Real ->+   Proc.T s Dim.Time Real+      (MIDI.LazyTime s ->+       SigA.T (Rate.Phantom s) (Amp.Dimensional Dim.Scalar Real) (SigSt.T Real))+stringReleaseEnvelope vel =+   Proc.withParam $ \dur ->+   do let attackTime = DN.time 1+      cnst <- CtrlR.constant+      {-+      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) <-+         CutR.splitAt attackTime $:+         (fmap (SigC.store dur .+                flip CutA.appendPrimitive cnst .+                DispA.map sin . Flat.canonicalize)+            (CtrlD.line attackTime (0, DN.scalar (pi/2))))+      let release = CutA.reverse attack+--          infixr 5 append+      append <- CutR.append+      return $+         DispA.inflate (DN.fromNumber $ 4**vel) $+         attack `append` sustain `append` release++{- INLINE string -}+string ::+   MIDI.ModulatedInstrument s Dim.Time Real+      (MIDI.Signal s Dim.Voltage Real (SigSt.T (Stereo.T Real)))+string vel freq =+   liftA3+      (\env ctrl osci dur ->+          SigA.rewriteAmplitudeDimension Dim.identityLeft $+          Causal.apply+             (env <<< Causal.feedSnd osci)+             (ctrl dur))+      Filt.envelopeVectorDimension+      (stringReleaseEnvelope vel)+      (Proc.pure CutA.mergeStereo+         $: (Proc.pure DispA.mix+              $: OsciR.static (DN.voltage 0.5 &*~ Wave.saw) zero (DN.scale 1.005 freq)+              $: OsciR.static (DN.voltage 0.5 &*~ Wave.saw) zero (DN.scale 0.998 freq))+         $: (Proc.pure DispA.mix+              $: OsciR.static (DN.voltage 0.5 &*~ Wave.saw) zero (DN.scale 1.002 freq)+              $: OsciR.static (DN.voltage 0.5 &*~ Wave.saw) zero (DN.scale 0.995 freq)))
+ src/Synthesizer/MIDI/Dimensional/Value.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE NoImplicitPrelude #-}+{- |+Functions for converting MIDI controller and key values+to something meaningful for signal processing.+-}+module Synthesizer.MIDI.Dimensional.Value (+   controllerLinear,+   controllerExponential,+   pitchBend,+   MV.frequencyFromPitch,+   ) where++import qualified Synthesizer.MIDI.Dimensional.ValuePlain as MV++import qualified Algebra.DimensionTerm as Dim+import qualified Number.DimensionTerm as DN++import qualified Algebra.Transcendental as Trans+import qualified Algebra.Field          as Field+-- import qualified Algebra.Additive       as Additive++import NumericPrelude.Numeric+-- import NumericPrelude.Base+++{-# INLINE controllerLinear #-}+controllerLinear ::+   (Field.C y, Dim.C v) =>+   DN.T v y -> (DN.T v y, DN.T v y) -> Int -> y+controllerLinear amp bnd n =+   DN.divToScalar (MV.controllerLinear bnd n) amp++{-# INLINE controllerExponential #-}+controllerExponential ::+   (Trans.C y, Dim.C v) =>+   DN.T v y -> (DN.T v y, DN.T v y) -> Int -> y+controllerExponential amp bnd n =+   DN.divToScalar (MV.controllerExponential bnd n) amp++{-# INLINE pitchBend #-}+pitchBend ::+   (Trans.C y, Dim.C v) =>+   DN.T v y -> y -> DN.T v y -> Int -> y+pitchBend amp range center n =+   DN.divToScalar (MV.pitchBend range center n) amp
+ src/Synthesizer/MIDI/Dimensional/ValuePlain.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE NoImplicitPrelude #-}+{- |+Functions for converting MIDI controller and key values+to something meaningful for signal processing.+-}+module Synthesizer.MIDI.Dimensional.ValuePlain (+   controllerLinear,+   controllerExponential,+   pitchBend,+   frequencyFromPitch,+   ) where++import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg++import qualified Algebra.DimensionTerm as Dim+import qualified Number.DimensionTerm as DN++import qualified Algebra.Transcendental as Trans+import qualified Algebra.Field          as Field+-- import qualified Algebra.Additive       as Additive++import NumericPrelude.Numeric+import NumericPrelude.Base+++{-# INLINE controllerLinear #-}+controllerLinear ::+   (Field.C y, Dim.C v) =>+   (DN.T v y, DN.T v y) -> Int -> DN.T v y+controllerLinear (lower,upper) n =+   let k = fromIntegral n / 127+   in  DN.scale (1-k) lower + DN.scale k upper++{-# INLINE controllerExponential #-}+controllerExponential ::+   (Trans.C y, Dim.C v) =>+   (DN.T v y, DN.T v y) -> Int -> DN.T v y+controllerExponential (lower,upper) n =+   let k = fromIntegral n / 127+   in  case error "MIDIValue.controllerExponential dimension" of+          d ->+             DN.fromNumberWithDimension d $+             DN.toNumberWithDimension d lower ** (1-k) *+             DN.toNumberWithDimension d upper ** k++{-# INLINE pitchBend #-}+pitchBend ::+   (Trans.C y, Dim.C v) =>+   y -> DN.T v y -> Int -> DN.T v y+pitchBend range center n =+   DN.scale (range ** (fromIntegral n / 8192)) center++{- |+Convert pitch to frequency according to the default tuning+in MIDI 1.0 Detailed Specification.+-}+{-# INLINE frequencyFromPitch #-}+frequencyFromPitch ::+   (Trans.C y) =>+   VoiceMsg.Pitch -> DN.Frequency y+frequencyFromPitch pitch =+   DN.scale+      (2 ^? (fromIntegral (VoiceMsg.fromPitch pitch + 3 - 6*12) / 12))+      (DN.frequency 440)
+ src/Synthesizer/MIDI/EventList.hs view
@@ -0,0 +1,273 @@+{-# LANGUAGE NoImplicitPrelude #-}+module Synthesizer.MIDI.EventList where++import qualified Sound.MIDI.Message.Class.Check as Check++import qualified Sound.MIDI.Message.Channel as ChannelMsg+import qualified Sound.MIDI.Message.Channel.Mode as Mode++import qualified Data.EventList.Relative.TimeBody  as EventList+import qualified Data.EventList.Relative.MixedBody as EventListMB+import qualified Data.EventList.Relative.BodyBody  as EventListBB++import Control.Monad.Trans.State+          (State, state, evalState, gets, put, )+import Data.Traversable (traverse, )++import qualified Numeric.NonNegative.Class   as NonNeg+import qualified Numeric.NonNegative.Wrapper as NonNegW+import qualified Numeric.NonNegative.Chunky as NonNegChunky++import Data.Array (Array, listArray, (!), bounds, inRange, )++import qualified Data.List.HT as ListHT+import Data.Tuple.HT (mapPair, mapFst, mapSnd, )+import Data.Maybe.HT (toMaybe, )+import Data.Maybe (catMaybes, isNothing, )+import Control.Monad.HT ((<=<), )+import Control.Monad (guard, msum, )++import NumericPrelude.Numeric+import NumericPrelude.Base+++type StrictTime = NonNegW.Integer++{-+Maybe we could use StorableVector.Pattern.LazySize+or we could use synthesizer-core/ChunkySize.+What package should we rely on?+Which one is more portable?++We do not use this type for timing in event lists anymore.+It worked in principle but left us with a couple of memory leaks,+that I could never identify and eliminate completely.+-}+type LazyTime = NonNegChunky.T NonNegW.Integer++++-- * event filters++type Filter event = State (EventList.T StrictTime [event])++++{- |+We turn the strict time values into lazy ones+according to the breaks by our beat.+However for the laziness breaks we ignore the events that are filtered out.+That is we loose laziness granularity+but hopefully gain efficiency by larger blocks.+-}+getSlice ::+   (event -> Maybe a) ->+   Filter event (EventList.T StrictTime [a])+getSlice f =+   state $+   EventList.unzip .+   fmap (ListHT.partitionMaybe f)+++type Channel    = ChannelMsg.Channel+type Controller = ChannelMsg.Controller+type Pitch      = ChannelMsg.Pitch+type Velocity   = ChannelMsg.Velocity+type Program    = ChannelMsg.Program+++getControllerEvents ::+   (Check.C event) =>+   Channel -> Controller ->+   Filter event (EventList.T StrictTime [Int])+getControllerEvents chan ctrl =+   getSlice (Check.controller chan ctrl)++{-+getControllerEvents ::+   (Check.C event) =>+   Channel -> Controller ->+   Filter event (EventList.T StrictTime (Maybe Int))+getControllerEvents chan ctrl =+   fmap (fmap (fmap snd . ListHT.viewR)) $+   getSlice (Check.controller chan ctrl)+-}++data NoteBoundary a =+     NoteBoundary Pitch Velocity a+   | AllNotesOff+   deriving (Eq, Show)++data Note = Note Program Pitch Velocity LazyTime+   deriving (Eq, Show)+++case_ :: Maybe a -> (a -> b) -> Maybe b+case_ = flip fmap++{-+We could also provide a function which filters for specific programs/presets.+-}+getNoteEvents ::+   (Check.C event) =>+   Channel ->+   Filter event (EventList.T StrictTime [Either Program (NoteBoundary Bool)])+getNoteEvents chan =+   getSlice $ checkNoteEvent chan++checkNoteEvent ::+   (Check.C event) =>+   Channel -> event ->+   Maybe (Either Program (NoteBoundary Bool))+checkNoteEvent chan e = msum $+   case_ (Check.note chan e) (\(velocity, pitch, press) ->+      Right $ NoteBoundary pitch velocity press) :+   case_ (Check.program chan e) Left :+   {-+   We do not handle AllSoundOff here,+   since this would also mean to clear reverb buffers+   and this cannot be handled here.+   -}+   (Check.mode chan e >>= \mode -> do+      guard (mode == Mode.AllNotesOff)+      return (Right AllNotesOff)) :+   []++embedPrograms ::+   Program ->+   EventList.T StrictTime [Either Program (NoteBoundary Bool)] ->+   EventList.T StrictTime [NoteBoundary (Maybe Program)]+embedPrograms initPgm =+   fmap catMaybes .+   flip evalState initPgm .+   traverse (traverse embedProgramState)++embedProgramState ::+   Either Program (NoteBoundary Bool) ->+   State Program (Maybe (NoteBoundary (Maybe Program)))+embedProgramState =+   -- evaluate program for every event in order to prevent a space leak+   (\n -> state (\s -> (seq s n, s)))+   <=<+   either+      (\pgm -> put pgm >> return Nothing)+      (\bnd ->+         gets (Just .+         case bnd of+            AllNotesOff -> const AllNotesOff+            NoteBoundary p v press ->+               NoteBoundary p v . toMaybe press))+++matchNoteEvents ::+   EventList.T StrictTime [NoteBoundary (Maybe Program)] ->+   EventList.T StrictTime [Note]+matchNoteEvents =+   matchNoteEventsCore $ \bndOn -> case bndOn of+      AllNotesOff -> Nothing+      NoteBoundary pitchOn velOn pressOn ->+         flip fmap pressOn $ \pgm ->+            (\bndOff ->+               case bndOff of+                  AllNotesOff -> True+                  NoteBoundary pitchOff _velOff pressOff ->+                     pitchOn == pitchOff && isNothing pressOff,+             Note pgm pitchOn velOn)++matchNoteEventsCore ::+   (noteBnd ->+    Maybe (noteBnd -> Bool, LazyTime -> Note)) ->+   EventList.T StrictTime [noteBnd] ->+   EventList.T StrictTime [Note]+matchNoteEventsCore methods =+   let recourseEvents =+          EventListMB.switchBodyL $ \evs0 xs0 -> case evs0 of+             [] -> ([], xs0)+             ev:evs ->+                case methods ev of+                   Nothing ->+                      recourseEvents (EventListMB.consBody evs xs0)+                   Just (check, cons) ->+                      case durationRemove check (EventListMB.consBody evs xs0) of+                         (dur, xs1) ->+                            mapFst+                               (cons dur :)+                               (recourseEvents xs1)+       recourse =+          EventList.switchL EventList.empty $ \(t,evs0) xs0 ->+          let (evs1,xs1) = recourseEvents (EventListMB.consBody evs0 xs0)+          in  EventList.cons t evs1 $ recourse xs1+   in  recourse+++{-+durationRemove Char.isUpper ("a" ./ 3 /. "bf" ./ 5 /. "aCcd" ./ empty :: Data.EventList.Relative.BodyBody.T StrictTime [Char])+-}+{- |+Search for specific event,+return its time stamp and remove it.+-}+durationRemove ::+   (NonNeg.C time) =>+   (body -> Bool) ->+   EventListBB.T time [body] ->+   (NonNegChunky.T time, EventListBB.T time [body])+durationRemove p =+   let errorEndOfList =+          (error "no matching body element found",+           error "list ended before matching element found")+       recourse =+          EventListMB.switchBodyL $ \evs xs0 ->+          let (prefix, suffix0) = break p evs+              (suffix1, rest) =+                 case suffix0 of+                    [] -> ([],+                        flip (EventListMB.switchTimeL errorEndOfList) xs0 $ \t xs1 ->+                        mapPair+                           (NonNegChunky.fromChunks . (t:) .+                            NonNegChunky.toChunks,+                            EventListMB.consTime t) $+                        recourse xs1)+                    _:ys -> (ys, (NonNeg.zero, xs0))+          in  mapSnd+                 (EventListMB.consBody (prefix++suffix1))+                 rest+   in  recourse++durationRemoveTB ::+   (NonNeg.C time) =>+   (body -> Bool) ->+   EventList.T time [body] ->+   (NonNegChunky.T time, EventList.T time [body])+durationRemoveTB p =+   let errorEndOfList =+          (error "no matching body element found",+           error "list ended before matching element found")+       recourse =+          EventList.switchL errorEndOfList $ \(t,evs) xs ->+          let (prefix, suffix0) = break p evs+              (suffix1, rest) =+                 case suffix0 of+                    [] -> ([], recourse xs)+                    _:ys -> (ys, (NonNeg.zero, xs))+          in  mapPair+                 (NonNegChunky.fromChunks . (t:) .+                  NonNegChunky.toChunks,+                  EventList.cons t (prefix++suffix1))+                 rest+   in  recourse+++-- ToDo: move to somewhere else, this has nothing todo with event lists++makeInstrumentArray :: [instr] -> Array Program instr+makeInstrumentArray instrs =+   listArray+      (ChannelMsg.toProgram 0, ChannelMsg.toProgram (length instrs - 1))+      instrs++getInstrumentFromArray :: Array Program instr -> Program -> Program -> instr+getInstrumentFromArray bank defltPgm pgm =+   bank !+   if inRange (bounds bank) pgm+     then pgm else defltPgm
+ src/Synthesizer/MIDI/Example/Instrument.hs view
@@ -0,0 +1,501 @@+{-+A set of example instruments to be used in MIDI rendering.++Shall we make the sample rate a parameter+or shall we leave these examples at a low level?+Sample-rate-aware instruments can be found in+"Synthesizer.MIDI.Dimensional.Example.Instrument"+-}+module Synthesizer.MIDI.Example.Instrument where++import Synthesizer.MIDI.Storable (+   Instrument, chunkSizesFromLazyTime, )++import Synthesizer.MIDI.EventList (LazyTime, )++import qualified Synthesizer.MIDI.CausalIO.Process as MIO+import qualified Synthesizer.CausalIO.Gate as Gate+import qualified Synthesizer.CausalIO.Process as PIO++import qualified Synthesizer.Basic.Wave          as Wave+import qualified Synthesizer.Frame.Stereo        as Stereo++import qualified Synthesizer.Causal.Process as Causal+import qualified Synthesizer.Causal.Oscillator as OsciC+import qualified Synthesizer.Causal.Interpolation as Interpolation+import qualified Synthesizer.Causal.Filter.Recursive.Integration as IntegC+import qualified Synthesizer.Causal.Filter.NonRecursive as FiltNRC+import qualified Synthesizer.Interpolation.Module as Ip+import Control.Arrow ((<<<), (^<<), (<<^), (***), )++import qualified Synthesizer.Storable.Filter.NonRecursive as FiltNRSt+import qualified Synthesizer.Storable.Signal      as SigSt+import qualified Data.StorableVector.Lazy.Pattern as SigStV+import qualified Data.StorableVector.Lazy         as SVL+import qualified Data.StorableVector              as SV++import qualified Synthesizer.Generic.Wave      as WaveG+import qualified Synthesizer.State.Signal      as SigS+import qualified Synthesizer.State.Control     as CtrlS+import qualified Synthesizer.State.Noise       as NoiseS+import qualified Synthesizer.State.Oscillator  as OsciS+import qualified Synthesizer.State.Displacement as DispS+import qualified Synthesizer.State.Filter.NonRecursive as FiltNRS+import qualified Synthesizer.Plain.Filter.Recursive    as FiltR+import qualified Synthesizer.Plain.Filter.Recursive.Universal as UniFilter+-- import qualified Synthesizer.Generic.Filter.NonRecursive as FiltG+-- import qualified Synthesizer.Basic.Phase       as Phase++import qualified Sound.Sox.Read          as SoxRead+import qualified Sound.Sox.Option.Format as SoxOption++import Control.Monad.Trans.State (get, modify, )+import Control.Monad (mzero, )+import Control.Category ((.), )++import NumericPrelude.Numeric (zero, round, (*>), )+import Prelude hiding (Real, round, break, id, (.), )++++type Real = Float++sampleRate :: Num a => a+sampleRate = 44100++chunkSize :: SVL.ChunkSize+chunkSize = SVL.chunkSize 512+++{-# INLINE amplitudeFromVelocity #-}+amplitudeFromVelocity :: Real -> Real+amplitudeFromVelocity vel = 4**vel++{-# INLINE ping #-}+ping :: Real -> Real -> SigSt.T Real+ping vel freq =+   SigS.toStorableSignal chunkSize $+   FiltNRS.envelope (CtrlS.exponential2 (0.2*sampleRate) (amplitudeFromVelocity vel)) $+   OsciS.static Wave.saw zero (freq/sampleRate)++pingDur :: Instrument Real Real+pingDur vel freq dur =+   SigStV.take (chunkSizesFromLazyTime dur) $+   ping vel freq++pingCausal :: MIO.Instrument Real (SV.Vector Real)+pingCausal vel freq =+   (PIO.fromCausal $+    Causal.applyStorableChunk $+    Causal.feed $+    FiltNRS.envelope+       (CtrlS.exponential2 (0.2*sampleRate) (amplitudeFromVelocity vel)) $+    OsciS.static Wave.saw zero (freq/sampleRate))+   <<<+   Gate.toStorableVector++pingReleaseEnvelope :: Real -> LazyTime -> SigSt.T Real+pingReleaseEnvelope vel dur =+   SigSt.switchR SigSt.empty+      (\body x ->+          SigSt.append body $+          SigS.toStorableSignal chunkSize $+          SigS.take (round (0.3*sampleRate :: Real)) $+          CtrlS.exponential2 (0.1*sampleRate) x) $+   SigS.toStorableSignalVary (chunkSizesFromLazyTime dur) $+   CtrlS.exponential2 (0.4*sampleRate) (amplitudeFromVelocity vel)++pingRelease :: Instrument Real Real+pingRelease vel freq dur =+   SigS.zipWithStorable (*)+      (OsciS.static Wave.saw zero (freq/sampleRate))+      (pingReleaseEnvelope vel dur)++pingStereoRelease :: Instrument Real (Stereo.T Real)+pingStereoRelease vel freq dur =+--   SigS.zipWithStorable (\y c -> fmap (c*) y)+   SigS.zipWithStorable (flip (*>))+      (SigS.zipWith Stereo.cons+         (OsciS.static Wave.saw zero (freq*0.999/sampleRate))+         (OsciS.static Wave.saw zero (freq*1.001/sampleRate)))+      (pingReleaseEnvelope vel dur)++pingReleaseEnvelopeCausal :: Real -> PIO.T MIO.GateChunk (SV.Vector Real)+pingReleaseEnvelopeCausal vel =+   PIO.continue+      ((PIO.fromCausal $+        Causal.applyStorableChunk $ Causal.feed $+        CtrlS.exponential2 (0.4*sampleRate) (amplitudeFromVelocity vel))+       <<<+       Gate.toStorableVector+       {-+       <<<+       arr (\x -> trace (show x) x) -})+      (\y -> -- trace ("continue with " ++ show y) $+         (PIO.fromCausal $+          Causal.applyStorableChunk $ Causal.feed $+          SigS.take (round (1*sampleRate :: Real)) $+          CtrlS.exponential2 (0.1*sampleRate) y)+         <<<+         Gate.allToStorableVector)++pingReleaseCausal :: MIO.Instrument Real (SV.Vector Real)+pingReleaseCausal vel freq =+   (PIO.fromCausal $+    Causal.applyStorableChunk $+    FiltNRC.envelope <<<+    Causal.feedFst (OsciS.static Wave.saw zero (freq/sampleRate)))+   <<<+   pingReleaseEnvelopeCausal vel++tine :: Instrument Real Real+tine vel freq dur =+   SigS.zipWithStorable (*)+      (OsciS.phaseMod Wave.sine (freq/sampleRate)+         (FiltNRS.envelope+            (CtrlS.exponential (1*sampleRate) (vel+1))+            (OsciS.static Wave.sine zero (2*freq/sampleRate))))+      (pingReleaseEnvelope 0 dur)++tineStereo :: Instrument Real (Stereo.T Real)+tineStereo vel freq dur =+   let ctrl f =+          FiltNRS.envelope+             (CtrlS.exponential (1*sampleRate) (vel+1))+             (OsciS.static Wave.sine zero (2*f/sampleRate))+   in  SigS.zipWithStorable (flip (*>))+          (SigS.zipWith Stereo.cons+             (OsciS.phaseMod Wave.sine (freq*0.995/sampleRate) (ctrl freq))+             (OsciS.phaseMod Wave.sine (freq*1.005/sampleRate) (ctrl freq)))+          (pingReleaseEnvelope 0 dur)+++softStringReleaseEnvelope ::+   Real -> LazyTime -> SigSt.T Real+softStringReleaseEnvelope vel dur =+   let attackTime = sampleRate+       amp = amplitudeFromVelocity vel+       cnst = CtrlS.constant amp+       {-+       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 $+          SigS.toStorableSignalVary (chunkSizesFromLazyTime dur) $+          flip SigS.append cnst $+          SigS.map ((amp*) . sin) $+          CtrlS.line attackTime (0, pi/2)+       release = SigSt.reverse attack+   in  attack `SigSt.append` sustain `SigSt.append` release++-- it's better to avoid inlining here+softString :: Instrument Real (Stereo.T Real)+softString vel freq dur =+   let f = freq/sampleRate+       {-# INLINE osci #-}+       osci d =+          OsciS.static Wave.saw zero (d * f)+   in  flip (SigS.zipWithStorable (flip (*>)))+          (softStringReleaseEnvelope vel dur)+          (SigS.map ((0.3::Real)*>) $+           SigS.zipWith Stereo.cons+             (DispS.mix+                (osci 1.005)+                (osci 0.998))+             (DispS.mix+                (osci 1.002)+                (osci 0.995)))+++softStringReleaseEnvelopeCausal ::+   Real -> LazyTime -> SigSt.T Real+softStringReleaseEnvelopeCausal vel dur =+   Causal.apply+      (softStringReleaseEnvelopeCausalProcess vel)+      (SigSt.append+         (SigStV.replicate (chunkSizesFromLazyTime dur) True)+         (SigSt.repeat chunkSize False))+++{-# INLINE softStringReleaseEnvelopeCausalProcess #-}+softStringReleaseEnvelopeCausalProcess ::+   Real -> Causal.T Bool Real+softStringReleaseEnvelopeCausalProcess vel =+   let vol = amplitudeFromVelocity vel+       attackTime = sampleRate+       {-# INLINE sine #-}+       sine x = sin (x*pi/(2*attackTime))+   in  Causal.fromStateMaybe+          (\b ->+             get >>= \n ->+             if b+               then+                 if n==attackTime+                   then return vol+                   else+                     modify (1+) >>+                     return (vol * sine n)+               else+                 if n==0+                   then mzero+                   else+                     modify (subtract 1) >>+                     return (vol * sine n))+          zero++{-# INLINE softStringCausalProcess #-}+softStringCausalProcess :: Real -> Causal.T Real (Stereo.T Real)+softStringCausalProcess freq =+   let f = freq/sampleRate+       {-# INLINE osci #-}+       osci d =+          OsciS.static Wave.saw zero (d * f)+   in  Causal.applySnd+          (Causal.map (uncurry (*>)))+          (SigS.map ((0.3::Real)*>) $+           SigS.zipWith Stereo.cons+             (DispS.mix+                (osci 1.005)+                (osci 0.998))+             (DispS.mix+                (osci 1.002)+                (osci 0.995)))++softStringCausal :: Instrument Real (Stereo.T Real)+softStringCausal vel freq dur =+   Causal.apply+      (softStringCausalProcess freq <<<+       softStringReleaseEnvelopeCausalProcess vel)+      (SigSt.append+         (SigStV.replicate (chunkSizesFromLazyTime dur) True)+         (SigSt.repeat chunkSize False))+++stringStereoFM :: SigSt.T Real -> Instrument Real (Stereo.T Real)+stringStereoFM fmSt vel freq dur =+   let fm = SigS.fromStorableSignal fmSt+   in  SigS.toStorableSignalVary (chunkSizesFromLazyTime dur) $+       FiltNRS.amplifyVector (amplitudeFromVelocity vel) $+       SigS.zipWith Stereo.cons+          (OsciS.freqMod Wave.saw zero $+           FiltNRS.amplify (freq*0.999/sampleRate) fm)+          (OsciS.freqMod Wave.saw zero $+           FiltNRS.amplify (freq*1.001/sampleRate) fm)++stringStereoDetuneFM ::+   SigSt.T Real -> SigSt.T Real -> Instrument Real (Stereo.T Real)+stringStereoDetuneFM detuneSt fmSt vel freq dur =+   let fm = SigS.fromStorableSignal fmSt+       detune = SigS.fromStorableSignal detuneSt+       {-# INLINE osci #-}+       osci =+          OsciS.freqMod Wave.saw zero .+          FiltNRS.amplify (freq/sampleRate) .+          FiltNRS.envelope fm+   in  SigS.toStorableSignalVary (chunkSizesFromLazyTime dur) $+       FiltNRS.amplifyVector (amplitudeFromVelocity vel) $+       SigS.zipWith Stereo.cons+          (osci $ SigS.map (1-) detune)+          (osci $ SigS.map (1+) detune)++{-# INLINE sampledSoundGenerator #-}+sampledSoundGenerator :: (Real, SigSt.T Real) -> Real -> SigS.T Real+sampledSoundGenerator (period, sample) freq =+   Causal.apply+      (Interpolation.relativeZeroPad zero Ip.linear zero+          (SigS.fromStorableSignal sample)) $+   SigS.repeat (freq/sampleRate*period)++sampledSound :: (Real, SigSt.T Real) -> Instrument Real Real+sampledSound sound vel freq dur =+   SigS.toStorableSignalVary (chunkSizesFromLazyTime dur) $+   SigS.map ((amplitudeFromVelocity vel) *) $+   sampledSoundGenerator sound freq++sampledSoundDetuneStereo ::+   Real -> (Real, SigSt.T Real) -> Instrument Real (Stereo.T Real)+sampledSoundDetuneStereo detune sound vel freq dur =+   SigS.toStorableSignalVary (chunkSizesFromLazyTime dur) $+   SigS.map ((amplitudeFromVelocity vel) *>) $+   SigS.zipWith Stereo.cons+      (sampledSoundGenerator sound (freq*(1-detune)))+      (sampledSoundGenerator sound (freq*(1+detune)))++sampleReleaseEnvelope :: Real -> Real -> LazyTime -> SigSt.T Real+sampleReleaseEnvelope halfLife vel dur =+   let amp = amplitudeFromVelocity vel+   in  SigSt.append+          (SigS.toStorableSignalVary (chunkSizesFromLazyTime dur) $+           CtrlS.constant amp)+          (SigS.toStorableSignal chunkSize $+           SigS.take (round (5*halfLife*sampleRate :: Real)) $+           CtrlS.exponential2 (halfLife*sampleRate) amp)++sampledSoundDetuneStereoRelease ::+   Real -> Real -> (Real, SigSt.T Real) -> Instrument Real (Stereo.T Real)+sampledSoundDetuneStereoRelease release detune sound vel freq dur =+   flip (SigS.zipWithStorable (flip (*>)))+      (sampleReleaseEnvelope release vel dur) $+   SigS.zipWith Stereo.cons+      (sampledSoundGenerator sound (freq*(1-detune)))+      (sampledSoundGenerator sound (freq*(1+detune)))+++readPianoSample :: IO (Real, SigSt.T Real)+readPianoSample =+   fmap ((,) 96) $+   SoxRead.withHandle1 (SVL.hGetContentsSync chunkSize) =<<+   SoxRead.open SoxOption.none "a-piano3"++readStringSample :: IO (Real, SigSt.T Real)+readStringSample =+   fmap ((,) 64) $+   SoxRead.withHandle1 (SVL.hGetContentsSync chunkSize) =<<+   SoxRead.open SoxOption.none "strings7.s8"+++{- |+Resample a sampled sound with a smooth loop+using our time manipulation algorithm.+Time is first controlled linearly,+then switches to a sine or triangular control.+Loop start must be large enough in order provide enough spare data+for interpolation at the beginning+and loop start plus length must preserve according space at the end.+One period is enough space for linear interpolation.+The infinite sound we generate is not just a cycle,+that uses bounded space.+Instead we need to compute all the time.+In order to avoid duplicate interpolation,+we have merged resampling and time looping.+-}+{-# INLINE sampledSoundTimeLoop #-}+sampledSoundTimeLoop ::+   (Real -> Real -> Real -> Real -> SigS.T Real) ->+   (Real, SigSt.T Real) -> Real -> Real -> Instrument Real Real+sampledSoundTimeLoop loopTimeMod+     (period, sample) loopLen loopStart vel freq dur =+   let wave = WaveG.sampledTone Ip.linear Ip.linear period sample+   in  SigS.toStorableSignalVary (chunkSizesFromLazyTime dur) $+       (((0.2 * amplitudeFromVelocity vel) *) ^<<+        OsciC.shapeMod wave zero (freq/sampleRate))+       `Causal.apply`+          loopTimeMod period (loopLen/2) (loopStart + loopLen/2) freq++{-+Graphics.Gnuplot.Simple.plotList [] (SigS.toList $ SigS.take 20000 $ loopTimeMod 64 1000 2000 440)+-}+loopTimeModSine :: Real -> Real -> Real -> Real -> SigS.T Real+loopTimeModSine period loopDepth loopCenter freq =+   let rate = freq*period/sampleRate+   in  SigS.append+          (SigS.takeWhile (loopCenter>=) $+           SigS.iterate (rate+) zero)+          (SigS.map (\t -> loopCenter + loopDepth * sin t) $+           SigS.iterate ((rate/loopDepth)+) zero)++loopTimeModZigZag :: Real -> Real -> Real -> Real -> SigS.T Real+loopTimeModZigZag period loopDepth loopCenter freq =+   let rate = freq*period/sampleRate+   in  SigS.append+          (SigS.takeWhile (loopCenter>=) $+           SigS.iterate (rate+) zero)+          (SigS.map (\t -> loopCenter + loopDepth * t) $+           OsciS.static Wave.triangle zero (rate/(4*loopDepth)))++++timeModulatedSample :: (Real, SigSt.T Real) ->+   SigSt.T Real -> SigSt.T Real -> SigSt.T Real -> Instrument Real Real+timeModulatedSample (period, sample) offsetMod speedMod freqMod vel freq dur =+   let wave = WaveG.sampledTone Ip.linear Ip.linear period sample+   in  SigStV.take (chunkSizesFromLazyTime dur) $+{-+       (((0.2 * amplitudeFromVelocity vel) *) ^<<+        OsciC.freqMod Wave.saw zero <<<+        Causal.map ((freq/sampleRate) *))+       `Causal.apply` freqMod+-}+       (((0.2 * amplitudeFromVelocity vel) *) ^<<+        OsciC.shapeFreqMod wave zero <<<+        (uncurry (+) ^<< Causal.feedFst offsetMod <<< IntegC.run) ***+         Causal.map ((freq/sampleRate) *))+       `Causal.applyFst` speedMod+       `Causal.apply` freqMod+++colourNoise ::+   SigSt.T Real -> SigSt.T Real ->+   Instrument Real Real+colourNoise resonanceMod freqMod vel freq dur =+   SigS.toStorableSignalVary (chunkSizesFromLazyTime dur) $+   ((((sqrt sampleRate/2000 * amplitudeFromVelocity vel) *) . UniFilter.lowpass) ^<<+    UniFilter.causal)+   `Causal.applyFst`+      SigS.zipWith+         (\r f -> UniFilter.parameter $ FiltR.Pole r (f*freq/sampleRate))+         (SigS.fromStorableSignal resonanceMod)+         (SigS.fromStorableSignal freqMod)+   `Causal.apply` NoiseS.white+++toneFromNoise ::+   SigSt.T Real -> SigSt.T Real ->+   Instrument Real Real+toneFromNoise speedMod freqMod vel freq dur =+   SigS.toStorableSignalVary (chunkSizesFromLazyTime dur) $+   (((0.1 * amplitudeFromVelocity vel) *) ^<<+    OsciC.shapeFreqModFromSampledTone+       Ip.linear Ip.linear+       100 (SigS.toStorableSignal chunkSize NoiseS.white)+       zero zero <<<+    Causal.second (Causal.map ((freq/sampleRate)*)))+   `Causal.applyFst`+      SigS.fromStorableSignal speedMod+   `Causal.apply`+      SigS.fromStorableSignal freqMod++{-+I like to control the filter parameters+before phase and time modulation.+Unfortunately this means,+that we have to translate those control signals back+using the speed profile, which is tricky.+We need an inverse frequency modulation, that is:++freqMod ctrl (invFreqMod ctrl signal) = signal++The problem is, that the chunk boundaries will not match.+invFreqMod must be a StorableSignal function and it is not causal+in any of its inputs.+-}+toneFromFilteredNoise ::+   SigSt.T Real -> SigSt.T Real ->+   SigSt.T Real -> SigSt.T Real ->+   Instrument Real Real+toneFromFilteredNoise resonanceMod cutoffMod speedMod freqMod vel freq dur =+   let period = 100+       filtNoise =+          ((((amplitudeFromVelocity vel) *) . UniFilter.lowpass) ^<<+           UniFilter.causal <<< Causal.feedSnd NoiseS.white+           <<^ (\(r,f) -> UniFilter.parameter $+                  FiltR.Pole r (f/period)))+          `Causal.applyFst`+             FiltNRSt.inverseFrequencyModulationFloor chunkSize speedMod resonanceMod+          `Causal.apply`+             FiltNRSt.inverseFrequencyModulationFloor chunkSize speedMod cutoffMod+   in  SigStV.take (chunkSizesFromLazyTime dur) $+       (((0.1 * amplitudeFromVelocity vel) *) ^<<+        OsciC.shapeFreqModFromSampledTone+           Ip.linear Ip.linear+           period filtNoise+           zero zero <<<+        Causal.second (Causal.map ((freq/sampleRate)*)))+       `Causal.applyFst` speedMod+       `Causal.apply`    freqMod
+ src/Synthesizer/MIDI/Generic.hs view
@@ -0,0 +1,347 @@+{-# LANGUAGE ExistentialQuantification #-}+{- |+Convert MIDI events of a MIDI controller to a control signal.+-}+{-# LANGUAGE NoImplicitPrelude #-}+module Synthesizer.MIDI.Generic where++import Synthesizer.MIDI.EventList+   (LazyTime, StrictTime, Filter, Channel,+    Program, embedPrograms, makeInstrumentArray, getInstrumentFromArray,+    Note(Note), matchNoteEvents, getNoteEvents, )++import qualified Sound.MIDI.Message.Class.Check as Check+import qualified Sound.MIDI.Message.Channel as ChannelMsg++import qualified Synthesizer.PiecewiseConstant.Signal as PC+import qualified Synthesizer.Generic.Cut        as CutG+import qualified Synthesizer.Generic.Signal     as SigG++import qualified Synthesizer.MIDI.Value as MV++import qualified Data.EventList.Relative.MixedBody as EventListMB+import qualified Data.EventList.Relative.BodyTime  as EventListBT+import qualified Data.EventList.Relative.TimeBody  as EventList++import Data.Monoid (Monoid, mempty, )++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 Control.Arrow (Arrow, arr, first, )+import Control.Category (Category, id, (.), )+import qualified Control.Monad.Trans.State.Strict as MS+import Control.Monad.Trans.State+          (State, evalState, runState, state, gets, put, get, )+import Control.Monad (liftM, )+import Data.Traversable (traverse, )+import Data.Foldable (traverse_, )++import Control.DeepSeq (NFData, )++import NumericPrelude.Base hiding (id, (.), )+import NumericPrelude.Numeric+import Prelude ()++++{-+ToDo: move to Generic.Signal+-}+replicateLong ::+   (SigG.Write sig y) =>+   StrictTime -> y -> sig y+replicateLong tl y =+   CutG.concat $+   map (\t ->+      SigG.replicate+--         (SigG.LazySize $ fromIntegral $ maxBound::Int)+         SigG.defaultLazySize+         (NonNegW.toNumber t) y) $+   PC.chopLongTime tl++{-+ToDo: move to Generic.Signal+-}+{-# INLINE piecewiseConstant #-}+piecewiseConstant ::+   (SigG.Write sig y) =>+   EventListBT.T StrictTime y -> sig y+piecewiseConstant =+   EventListBT.foldrPair+      (\y t -> SigG.append (replicateLong t y))+      SigG.empty++{-# INLINE piecewiseConstantInit #-}+piecewiseConstantInit ::+   (SigG.Write sig y) =>+   y -> EventList.T StrictTime y -> sig y+piecewiseConstantInit initial =+   (\ ~(t,rest) ->+      SigG.append (replicateLong t initial) rest)+   .+   EventList.foldr+      (,)+      (\y ~(t,rest) ->+         SigG.append (replicateLong t y) rest)+      (0, SigG.empty)++{-# INLINE piecewiseConstantInitWith #-}+piecewiseConstantInitWith ::+   (SigG.Write sig c) =>+   (y -> c) ->+   c -> EventList.T StrictTime [y] -> sig c+piecewiseConstantInitWith f initial =+   piecewiseConstantInit initial .+   flip evalState initial .+   traverse (\evs -> traverse_ (put . f) evs >> get)++++type Instrument y signal = y -> y -> LazyTime -> signal+type Bank y signal = Program -> Instrument y signal++{- |+Instrument parameters are:+velocity from -1 to 1 (0 is the normal pressure, no pressure aka NoteOff is not supported),+frequency is given in Hertz+-}+renderInstrument ::+   (Trans.C y) =>+   Bank y signal ->+   Note ->+   signal+renderInstrument instrument (Note pgm pitch vel dur) =+   instrument pgm+      (MV.velocity vel)+      (MV.frequencyFromPitch pitch)+      dur++renderInstrumentIgnoreProgram ::+   (Trans.C y) =>+   Instrument y signal ->+   Note ->+   signal+renderInstrumentIgnoreProgram instrument =+   renderInstrument (const instrument)+++{- |+Turn an event list with bundles of elements+into an event list with single events.+ToDo: Move to event-list package?+-}+flatten ::+   (Monoid signal, NonNeg.C time) =>+   EventList.T time [signal] ->+   EventList.T time signal+flatten =+   EventList.foldr+      EventListMB.consTime+      (\bt xs ->+         uncurry EventListMB.consBody $+         case bt of+            [] -> (mempty, xs)+            b:bs -> (b, foldr (EventList.cons NonNeg.zero) xs bs))+      EventList.empty+++applyModulation ::+   (CutG.Transform signal, CutG.NormalForm signal) =>+   signal ->+   Modulator (signal -> instr, note) (instr, note)+applyModulation ctrl =+   first $+   Modulator ctrl advanceModulationChunk gets++{- |+We have to evaluate the head value at each 'drop'+in order to avoid growing thunks that lead to a space leak.+-}+evaluateVectorHead ::+   (CutG.NormalForm signal) =>+   signal -> t -> t+evaluateVectorHead xs t =+   case CutG.evaluateHead xs of () -> t+--   if CutG.null xs then t else t++advanceModulation ::+   (CutG.Transform signal, CutG.NormalForm signal) =>+   LazyTime -> State signal LazyTime+advanceModulation =+   liftM NonNegChunky.fromChunks .+   mapM advanceModulationChunk .+   NonNegChunky.toChunks++advanceModulationChunk ::+   (CutG.Transform signal, CutG.NormalForm signal) =>+   StrictTime -> State signal StrictTime+advanceModulationChunk t = state $ \xs ->+   let ys = CutG.drop (fromIntegral t) xs+   in  (evaluateVectorHead ys t, ys)++advanceModulationChunkStrict ::+   (CutG.Transform signal, CutG.NormalForm signal) =>+   StrictTime -> MS.State signal StrictTime+advanceModulationChunkStrict t = MS.state $ \xs ->+   let ys = CutG.drop (fromIntegral t) xs+   in  (evaluateVectorHead ys t, ys)++advanceModulationChunkPC ::+   (NFData body) =>+   StrictTime ->+   State (EventListBT.T StrictTime body) StrictTime+advanceModulationChunkPC t = state $ \xs ->+   let ys =+          EventListBT.fromPairList $ tail $+          EventListBT.toPairList xs+   in  (evaluateVectorHead ys t, ys)++type FilterSequence event signal =+   Filter event (EventList.T PC.ShortStrictTime signal)++{- |+The state action for the time+should just return the argument time.+However we need this time (or alternatively another result type)+for triggering the 'drop' in 'advanceModulationChunk'.+Without this strict evaluation,+the drop will be delayed until the control curve is actually needed.+-}+data Modulator note signal =+   forall state.+   Modulator+      state+      (StrictTime -> State state StrictTime)+      (note -> State state signal)++instance Category Modulator where+   id = Modulator () return return+   (Modulator yInit yTime yBody) . (Modulator xInit xTime xBody) =+      let compose ym xm r0 =+             state $ \(xState0,yState0) ->+                let (r1, xState1) = runState (xm r0) xState0+                    (r2, yState1) = runState (ym r1) yState0+                in  (r2, (xState1,yState1))+      in  Modulator+             (xInit,yInit)+             (compose yTime xTime)+             (compose yBody xBody)++instance Arrow Modulator where+   arr f = Modulator () return (return . f)+   first (Modulator xInit xTime xBody) =+      Modulator xInit xTime+         (\(a0,c) -> fmap (\a1 -> (a1,c)) $ xBody a0)+++applyModulator ::+   Modulator a b ->+   EventList.T StrictTime [a] ->+   EventList.T StrictTime [b]+applyModulator+      (Modulator modulatorInit modulatorTime modulatorBody) =+   flip evalState modulatorInit .+   EventList.traverse modulatorTime (traverse modulatorBody)+++{-# INLINE sequenceCore #-}+sequenceCore ::+   (Check.C event, Monoid signal) =>+   Channel ->+   Program ->+   Modulator Note signal ->+   FilterSequence event signal+sequenceCore chan initPgm md =+   fmap (EventList.mapTime fromIntegral .+         flatten .+         applyModulator md .+         matchNoteEvents .+         embedPrograms initPgm) $+   getNoteEvents chan+++errorNoProgram :: Program+errorNoProgram =+   ChannelMsg.toProgram 0+{-+Since we compute the current program strictly in embedPrograms,+initializing with undefined does no longer work.+   error "MIDI program not initialized"+-}+++{-# INLINE sequence #-}+sequence ::+   (Check.C event, Monoid signal, Trans.C y) =>+   Channel ->+   Instrument y signal ->+   FilterSequence event signal+sequence chan instr =+   sequenceCore chan errorNoProgram+      (Modulator () return+          (return . renderInstrumentIgnoreProgram instr))+++{-# INLINE sequenceModulated #-}+sequenceModulated ::+   (Check.C event, CutG.Transform ctrl, CutG.NormalForm ctrl,+    Monoid signal, Trans.C y) =>+   ctrl ->+   Channel ->+   (ctrl -> Instrument y signal) ->+   FilterSequence event signal+sequenceModulated ctrl chan instr =+   sequenceCore chan errorNoProgram+      (Modulator ctrl advanceModulationChunk+          (\note -> gets $ \c -> renderInstrumentIgnoreProgram (instr c) note))+++{-# INLINE sequenceMultiModulated #-}+sequenceMultiModulated ::+   (Check.C event, Monoid signal, Trans.C y) =>+   Channel ->+   instrument ->+   Modulator (instrument, Note) (Instrument y signal, Note) ->+   FilterSequence event signal+sequenceMultiModulated chan instr+      (Modulator modulatorInit modulatorTime modulatorBody) =+   sequenceCore chan errorNoProgram+      (Modulator modulatorInit modulatorTime+          (fmap (uncurry renderInstrumentIgnoreProgram) .+           modulatorBody .+           (,) instr))++{-# INLINE sequenceMultiProgram #-}+sequenceMultiProgram ::+   (Check.C event, Monoid signal, Trans.C y) =>+   Channel ->+   Program ->+   [Instrument y signal] ->+   FilterSequence event signal+sequenceMultiProgram chan initPgm instrs =+   let bank = makeInstrumentArray instrs+   in  sequenceCore chan initPgm+          (Modulator () return+              (return . renderInstrument+                 (getInstrumentFromArray bank initPgm)))++{-# INLINE sequenceModulatedMultiProgram #-}+sequenceModulatedMultiProgram ::+   (CutG.Transform ctrl, CutG.NormalForm ctrl,+    Check.C event, Monoid signal, Trans.C y) =>+   ctrl ->+   Channel ->+   Program ->+   [ctrl -> Instrument y signal] ->+   FilterSequence event signal+sequenceModulatedMultiProgram ctrl chan initPgm instrs =+   let bank = makeInstrumentArray instrs+   in  sequenceCore chan initPgm+          (Modulator+              ctrl advanceModulationChunk+              (\note -> gets $ \c -> renderInstrument+                 (\pgm -> getInstrumentFromArray bank initPgm pgm c) note))
+ src/Synthesizer/MIDI/PiecewiseConstant.hs view
@@ -0,0 +1,170 @@+{- |+Convert MIDI events of a MIDI controller to a control signal.+-}+{-# LANGUAGE NoImplicitPrelude #-}+module Synthesizer.MIDI.PiecewiseConstant (+   T,+   duration,+   PC.zipWith,++   initWith,+   controllerLinear,+   controllerExponential,+   pitchBend,+   channelPressure,+   bendWheelPressure,+   bendWheelPressureZip,+   ) where++import qualified Synthesizer.MIDI.EventList as Ev+import Synthesizer.MIDI.EventList (LazyTime, StrictTime, Filter, Channel, )++import qualified Sound.MIDI.Message.Class.Check as Check+import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg+import qualified Synthesizer.MIDI.Value.BendModulation as BM+import qualified Synthesizer.MIDI.Value.BendWheelPressure as BWP+import qualified Synthesizer.MIDI.Value as MV++import qualified Synthesizer.PiecewiseConstant.Signal as PC++import qualified Data.EventList.Relative.TimeMixed as EventListTM+import qualified Data.EventList.Relative.MixedTime as EventListMT+import qualified Data.EventList.Relative.BodyTime  as EventListBT+import qualified Data.EventList.Relative.TimeBody  as EventList++import qualified Numeric.NonNegative.Class   as NonNeg+import qualified Numeric.NonNegative.Chunky as NonNegChunky++import qualified Algebra.Transcendental as Trans+import qualified Algebra.RealRing       as RealRing+import qualified Algebra.Field          as Field++import Control.Monad.Trans.State (State, evalState, state, get, put, )+import Control.Monad (liftM, liftM2, )+import Data.Traversable (traverse, )+import Data.Foldable (traverse_, )++import qualified Data.List.HT as ListHT+import Data.Either (Either(Left, Right), )+import Data.Maybe (maybe, )+import Data.Function ((.), ($), flip, )++import NumericPrelude.Numeric+import NumericPrelude.Base (fmap, (>>), )+++type T = EventListBT.T StrictTime+++duration :: T y -> LazyTime+duration =+   NonNegChunky.fromChunks . EventListBT.getTimes+++{-# INLINE initWith #-}+initWith ::+   (y -> c) ->+   c -> EventList.T StrictTime [y] -> T c+initWith f initial =+{-+   EventListTM.switchBodyR EventListBT.empty+      (\xs _ -> EventListMT.consBody initial xs) .+-}+   EventListMT.consBody initial .+   flip EventListTM.snocTime NonNeg.zero .+   flip evalState initial .+   traverse+      (\ys -> traverse_ (put . f) ys >> get)+++{-# INLINE controllerLinear #-}+controllerLinear ::+   (Check.C event, Field.C y) =>+   Channel -> Ev.Controller ->+   (y,y) -> y ->+   Filter event (T y)+controllerLinear chan ctrl bnd initial =+   liftM (initWith (MV.controllerLinear bnd) initial) $+   Ev.getControllerEvents chan ctrl+++{-# INLINE controllerExponential #-}+controllerExponential ::+   (Check.C event, Trans.C y) =>+   Channel -> Ev.Controller ->+   (y,y) -> y ->+   Filter event (T y)+controllerExponential chan ctrl bnd initial =+   liftM (initWith (MV.controllerExponential bnd) initial) $+   Ev.getControllerEvents chan ctrl+++{- |+@pitchBend channel range center@:+emits frequencies on an exponential scale from+@center/range@ to @center*range@.+-}+{-# INLINE pitchBend #-}+pitchBend ::+   (Check.C event, Trans.C y) =>+   Channel ->+   y -> y ->+   Filter event (T y)+pitchBend chan range center =+   liftM (initWith (MV.pitchBend range center) center) $+   Ev.getSlice (Check.pitchBend chan)+--   getPitchBendEvents chan++{-# INLINE channelPressure #-}+channelPressure ::+   (Check.C event, Trans.C y) =>+   Channel ->+   y -> y ->+   Filter event (T y)+channelPressure chan maxVal initVal =+   liftM (initWith (MV.controllerLinear (0,maxVal)) initVal) $+   Ev.getSlice (Check.channelPressure chan)+++{-# INLINE bendWheelPressure #-}+bendWheelPressure ::+   (Check.C event, RealRing.C y, Trans.C y) =>+   Channel ->+   Int -> y -> y ->+   Filter event (T (BM.T y))+bendWheelPressure chan+      pitchRange wheelDepth pressDepth =+   let toBM = BM.fromBendWheelPressure pitchRange wheelDepth pressDepth+   in  liftM (initWith toBM (toBM BWP.deflt)) $+       state $+       EventList.unzip .+       fmap ListHT.unzipEithers .+       flip evalState BWP.deflt .+       traverse (traverse (separateBWP chan))++separateBWP ::+   Check.C event =>+   Channel -> event -> State BWP.T (Either BWP.T event)+separateBWP chan ev =+   fmap (maybe (Right ev) Left) $+   BWP.check chan ev+++{- |+This one is certainly not as efficient as 'bendWheelPressure'+since it first slices the event list+and then zips the slices together.+-}+{-# INLINE bendWheelPressureZip #-}+bendWheelPressureZip ::+   (Check.C event, RealRing.C y, Trans.C y) =>+   Channel ->+   Int -> y -> y ->+   Filter event (T (BM.T y))+bendWheelPressureZip chan+     pitchRange wheelDepth pressDepth =+   liftM2 (PC.zipWith BM.Cons)+      (pitchBend chan (2^?(fromIntegral pitchRange/12)) 1)+      (liftM2 (PC.zipWith (+))+         (controllerLinear chan VoiceMsg.modulation (0,wheelDepth) 0)+         (channelPressure chan pressDepth 0))
+ src/Synthesizer/MIDI/PiecewiseConstant/ControllerSet.hs view
@@ -0,0 +1,380 @@+{- |+Treat a stream of MIDI events as parallel streams of MIDI controller events.+-}+{-# LANGUAGE NoImplicitPrelude #-}+module Synthesizer.MIDI.PiecewiseConstant.ControllerSet (+   T(Cons),+   mapStream,++   Controller(Controller,PitchBend,Pressure),+   fromChannel,+   maybeController,+   controllerLinear,+   controllerExponential,+   pitchBend,+   channelPressure,+   bendWheelPressure,+   checkBendWheelPressure,+   bendWheelPressureZip,++   -- * internal data needed in synthesizer-llvm+   initial, stream,+   ) where++import qualified Synthesizer.PiecewiseConstant.Signal as PC+import qualified Synthesizer.MIDI.EventList as Ev+import Synthesizer.MIDI.EventList (StrictTime, Channel, )++import qualified Sound.MIDI.Message.Class.Check as Check+import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg+import qualified Synthesizer.MIDI.Value.BendModulation as BM+import qualified Synthesizer.MIDI.Value.BendWheelPressure as BWP+import qualified Synthesizer.MIDI.Value as MV++import qualified Synthesizer.Generic.Cut as CutG+import Control.DeepSeq (NFData, rnf, )++import qualified Data.EventList.Relative.TimeTime  as EventListTT+import qualified Data.EventList.Relative.TimeMixed as EventListTM+import qualified Data.EventList.Relative.MixedTime as EventListMT+import qualified Data.EventList.Relative.BodyTime  as EventListBT+-- import qualified Data.EventList.Relative.TimeBody  as EventListTB++import qualified Numeric.NonNegative.Class   as NonNeg98+-- import qualified Numeric.NonNegative.Wrapper as NonNegW+-- import qualified Numeric.NonNegative.Chunky as NonNegChunky+-- import Numeric.NonNegative.Class ((-|), )++import qualified Algebra.Transcendental as Trans+import qualified Algebra.RealRing       as RealRing+import qualified Algebra.Field          as Field+import qualified Algebra.Additive       as Additive++import qualified Data.Map as Map+import Data.Map (Map, )++import qualified Data.Accessor.Monad.Trans.State as AccState+import qualified Data.Accessor.Basic as Acc+import Control.Monad.Trans.State (State, evalState, state, get, put, )+import Control.Monad (liftM2, msum, )+import Data.Traversable (traverse, )+import Data.Foldable (traverse_, )+import Data.Monoid (Monoid, mempty, mappend, )++import Data.Maybe.HT (toMaybe, )+import Data.Tuple.HT (mapFst, mapPair, )+import qualified Data.List.HT as ListHT+import qualified Data.List as List++import NumericPrelude.Numeric+import NumericPrelude.Base+import qualified Prelude as P+          (Num, Integral, fromInteger, fromIntegral, toInteger, sum, )+++{-+This data structure stores the initial values of all supported controllers+and an event list of all changes of individal controllers.+-}+data T key a =+   Cons {+      initial :: Map key a,+      stream :: EventListTT.T StrictTime [(key, a)]+   }+   deriving Show+++mapStream ::+   (EventListTT.T StrictTime [(key, a)] ->+    EventListTT.T StrictTime [(key, a)]) ->+   T key a -> T key a+mapStream f s = Cons (initial s) (f (stream s))+++data Controller =+     Controller VoiceMsg.Controller+   | PitchBend+   | Pressure+   deriving (Show, Eq, Ord)++instance NFData Controller where+   rnf (Controller c) =+      rnf (VoiceMsg.fromController c)+   rnf _ = ()+++fromChannel ::+   (Check.C event) =>+   Channel ->+   Ev.Filter event (T Controller Int)+fromChannel chan =+   fmap (Cons Map.empty) $+   fmap (flip EventListTM.snocTime NonNeg98.zero) $+   Ev.getSlice (maybeController chan)++maybeController ::+   (Check.C event) =>+   Channel -> event -> Maybe (Controller, Int)+maybeController chan e = msum $+   (fmap (mapFst Controller) $ Check.anyController chan e) :+   (fmap ((,) PitchBend) $ Check.pitchBend chan e) :+   (fmap ((,) Pressure) $ Check.channelPressure chan e) :+   []+++instance CutG.Read (T key a) where+   null =+      List.null . List.filter (> P.fromInteger 0) .+      EventListTT.getTimes . stream+   length =+      fromIntegral . P.toInteger .+      P.sum . EventListTT.getTimes . stream++instance Monoid (T key y) where+   mempty = Cons Map.empty (EventListTT.pause mempty)+   mappend x y =+      Cons+         (initial x)+         (EventListTT.append (stream x) (flatten y))++instance (NFData key, NFData a) => CutG.NormalForm (T key a) where+   evaluateHead xs = rnf (initial xs)++{- |+Prepend the initial values as events to the event-list.+-}+flatten ::+   T key a -> EventListTT.T StrictTime [(key, a)]+flatten xs =+   EventListTT.cons+      mempty (Map.toList $ initial xs)+      (stream xs)+++mapInsertMany ::+   (Ord key) =>+   [(key,a)] -> Map key a -> Map key a+mapInsertMany assignments inits =+   foldl (flip (uncurry Map.insert)) inits assignments+++reverseList ::+   (Ord key) =>+   (Map key a, [(key,a)]) ->+   (Map key a, [(key,a)])+reverseList (inits,xs) =+   foldl+      (\(inits0,ys) (key,a) ->+         let (ma,inits1) =+                Map.insertLookupWithKey+                   (\ _k new _old -> new) key a inits0+         in  (inits1,+              maybe+                 (error "MIDIControllerSet.reverse: uninitialized controller")+                 ((,) key) ma+                 : ys))+      (inits, [])+      xs++{- |+For reverse you must make sure,+that all controller events have an corresponding initial value.+Controllers that miss an initial value+their last constant piece will be undefined.+-}+instance (Ord key) => CutG.Transform (T key y) where+   take n =+      mapStream (EventListTT.takeTime (P.fromIntegral n))++   drop n0 xs =+      let recourse n inits =+             EventListMT.switchTimeL $ \t xs1 ->+             let (b,d) = snd $ NonNeg98.split t n+             in  mapStream (EventListTT.forceTimeHead) $+                 if not b+                   then Cons inits (EventListMT.consTime d xs1)+                   else+                     flip (EventListMT.switchBodyL+                        (Cons inits (EventListTT.pause mempty))) xs1 $ \assignments xs2 ->+                     recourse d (mapInsertMany assignments inits) xs2+      in  recourse (P.fromIntegral n0) (initial xs) (stream xs)++   -- cf. ChunkySize.dropMarginRem+   dropMarginRem n m xs =+      List.foldl'+         (\(mi,xsi) k -> (mi-k, CutG.drop k xsi))+         (m, xs)+         (List.map P.fromIntegral $ EventListTT.getTimes $+          EventListTT.takeTime (P.fromIntegral m) $+          EventListTT.dropTime (P.fromIntegral n) $+          stream xs)++   -- cf. StorableVector.Lazy.splitAt+   splitAt n0 xs =+      let recourse n inits =+             EventListMT.switchTimeL $ \t xs1 ->+             let (m, ~(b,d)) = NonNeg98.split t n+             in  mapPair+                    (EventListMT.consTime m,+                     mapStream (EventListTT.forceTimeHead)) $+                 if not b+                   then+                     (EventListBT.empty,+                      Cons inits (EventListMT.consTime d xs1))+                   else+                     flip (EventListMT.switchBodyL+                        (EventListBT.empty,+                         Cons inits (EventListTT.pause mempty))) xs1 $ \keyAs xs2 ->+                     mapFst (EventListMT.consBody keyAs) $+                     recourse d (mapInsertMany keyAs inits) xs2+      in  mapFst (Cons (initial xs)) $+          recourse (P.fromIntegral n0) (initial xs) (stream xs)++   reverse xs =+      EventListTT.foldl+         (\(inits,ys) t -> Cons inits $ EventListMT.consTime t ys)+         (\(Cons inits0 ys) evs0 ->+            let (inits1, evs1) = reverseList (inits0, evs0)+            in  (inits1, EventListMT.consBody evs1 ys))+         (initial xs, EventListBT.empty)+         (stream xs)+{-+*Synthesizer.MIDI.PiecewiseConstant.ControllerSet Data.EventList.Relative.MixedTime> CutG.reverse $ Cons (Map.singleton 'a' GT) (2 /. [('a',EQ)] ./ 3 /. empty) :: T Char Ordering+-}++++type Filter = State (T Controller Int)+++_errorUninitialized :: Controller -> Int+_errorUninitialized c =+   error $+   "getSlice: uninitialized controller " ++ show c++{-# INLINE getSlice #-}+getSlice ::+   Controller ->+   (Int -> a) ->+   a -> Filter (PC.T a)+getSlice c f deflt =+   state $ \xs ->+      let (ys,zs) =+             EventListTT.unzip $+             fmap+                (ListHT.partitionMaybe+                   (\(ci,a) -> toMaybe (c==ci) a))+                (stream xs)+          (yin0,zis) =+             Map.updateLookupWithKey+                (\ _k _a -> Nothing) c+                (initial xs)+          yin1 = maybe deflt f yin0+          fill =+             flip evalState yin1 .+             traverse+                (\ys0 -> traverse_ (put . f) ys0 >> get)+      in  (EventListMT.consBody yin1 (fill ys),+           Cons zis zs)+++{-# INLINE controllerLinear #-}+controllerLinear ::+   (Field.C y) =>+   Ev.Controller -> (y,y) -> y -> Filter (PC.T y)+controllerLinear ctrl bnd =+   getSlice (Controller ctrl) (MV.controllerLinear bnd)+++{-# INLINE controllerExponential #-}+controllerExponential ::+   (Trans.C y) =>+   Ev.Controller -> (y,y) -> y -> Filter (PC.T y)+controllerExponential ctrl bnd =+   getSlice (Controller ctrl) (MV.controllerExponential bnd)++++{- |+@pitchBend channel range center@:+emits frequencies on an exponential scale from+@center/range@ to @center*range@.+-}+{-# INLINE pitchBend #-}+pitchBend ::+   (Trans.C y) =>+   y -> y ->+   Filter (PC.T y)+pitchBend range center =+   getSlice PitchBend (MV.pitchBend range center) center++{-# INLINE channelPressure #-}+channelPressure ::+   (Trans.C y) =>+   y -> y ->+   Filter (PC.T y)+channelPressure maxVal =+   getSlice Pressure (MV.controllerLinear (Additive.zero,maxVal))++++-- adapted from getSlice+{-# INLINE bendWheelPressure #-}+bendWheelPressure ::+   (RealRing.C y, Trans.C y) =>+   Int -> y -> y ->+   Filter (PC.T (BM.T y))+bendWheelPressure pitchRange wheelDepth pressDepth =+   state $ \xs ->+      let (ys,zs) =+             EventListTT.unzip $+             fmap ListHT.unzipEithers $+             flip evalState BWP.deflt $+             traverse (traverse separateBWP) (stream xs)+          move key field (bwp,mp) =+             mapFst (maybe bwp (\y -> Acc.set field y bwp)) $+             Map.updateLookupWithKey+                (\ _k _a -> Nothing) key mp+          (yin,zis) =+             move PitchBend BWP.bend $+             move (Controller VoiceMsg.modulation) BWP.wheel $+             move Pressure BWP.pressure $+             (BWP.deflt, initial xs)+          fill =+             flip evalState yin .+             traverse+                (\ys0 -> traverse_ put ys0 >> get)+      in  (fmap (BM.fromBendWheelPressure pitchRange wheelDepth pressDepth) $+           EventListMT.consBody yin (fill ys),+           Cons zis zs)++separateBWP ::+   (Controller, Int) -> State BWP.T (Either BWP.T (Controller, Int))+separateBWP ev =+   fmap (maybe (Right ev) Left) $+   checkBendWheelPressure ev++checkBendWheelPressure ::+   (Controller, Int) -> State BWP.T (Maybe BWP.T)+checkBendWheelPressure (ctrl,val) =+   let update field = AccState.set field val >> fmap Just get+   in  case ctrl of+          PitchBend -> update BWP.bend+          Pressure -> update BWP.pressure+          Controller cc ->+             if cc == VoiceMsg.modulation+               then update BWP.wheel+               else return $ Nothing+++{-# INLINE bendWheelPressureZip #-}+bendWheelPressureZip ::+   (RealRing.C y, Trans.C y) =>+   Int -> y -> y ->+   Filter (PC.T (BM.T y))+bendWheelPressureZip pitchRange wheelDepth pressDepth =+   liftM2 (PC.zipWith BM.Cons)+      (pitchBend (2 ^? (fromIntegral pitchRange / 12)) 1)+      (liftM2 (PC.zipWith (+))+         (controllerLinear VoiceMsg.modulation (0,wheelDepth) 0)+         (channelPressure pressDepth 0))
+ src/Synthesizer/MIDI/Storable.hs view
@@ -0,0 +1,313 @@+{- |+Convert MIDI events of a MIDI controller to a control signal.+-}+{-# LANGUAGE NoImplicitPrelude #-}+module Synthesizer.MIDI.Storable (+   chunkSizesFromLazyTime,+   piecewiseConstant,+   piecewiseConstantInit,+   piecewiseConstantInitWith,+   controllerLinear,+   controllerExponential,+   pitchBend,+   channelPressure,+   bendWheelPressure,++   Instrument, Bank,+   sequenceCore,+   sequence,+   sequenceModulated,+   sequenceMultiModulated,+   applyModulation,+   advanceModulationLazy,+   advanceModulationStrict,+   advanceModulationChunky,+   sequenceMultiProgram,++   Gen.renderInstrument,+   Gen.renderInstrumentIgnoreProgram,+   Gen.evaluateVectorHead,+   Gen.advanceModulationChunk,+   ) where++import Synthesizer.MIDI.EventList+          (LazyTime, StrictTime, Filter, Note,+           Program, Channel, Controller,+           getControllerEvents, getSlice, )+import qualified Synthesizer.MIDI.Generic as Gen+import qualified Synthesizer.MIDI.Value as MV++import qualified Synthesizer.Storable.Cut        as CutSt+import qualified Synthesizer.Storable.Signal     as SigSt+import qualified Data.StorableVector.Lazy.Pattern as SigStV+import qualified Data.StorableVector.Lazy        as SVL++import qualified Synthesizer.State.Signal       as SigS+import qualified Synthesizer.State.Oscillator   as OsciS+import qualified Synthesizer.State.Displacement as DispS+import qualified Synthesizer.State.Filter.NonRecursive as FiltNRS+import qualified Synthesizer.Basic.Wave         as Wave++import qualified Sound.MIDI.Message.Class.Check as Check+import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg++import qualified Synthesizer.PiecewiseConstant.Signal as PC+import qualified Data.EventList.Relative.BodyTime  as EventListBT+import qualified Data.EventList.Relative.TimeBody  as EventList++import Foreign.Storable (Storable, )++import qualified Numeric.NonNegative.Wrapper as NonNegW+import qualified Numeric.NonNegative.Chunky as NonNegChunky++import qualified Algebra.Transcendental as Trans+import qualified Algebra.RealRing      as RealRing+import qualified Algebra.Field          as Field+import qualified Algebra.Additive       as Additive++import Control.Monad.Trans.State (State, evalState, state, modify, put, get, )+import Control.Monad (liftM, )+import Data.Traversable (traverse, )+import Data.Foldable (traverse_, )++import NumericPrelude.Base hiding (sequence, )+import NumericPrelude.Numeric++++chunkSizesFromStrictTime :: StrictTime -> NonNegChunky.T SigSt.ChunkSize+chunkSizesFromStrictTime =+   NonNegChunky.fromChunks .+   map (SVL.ChunkSize . NonNegW.toNumber) .+   PC.chopLongTime+++chunkSizesFromLazyTime :: LazyTime -> NonNegChunky.T SigSt.ChunkSize+chunkSizesFromLazyTime =+   NonNegChunky.fromChunks .+   map (SVL.ChunkSize . NonNegW.toNumber) .+   concatMap PC.chopLongTime .+   NonNegChunky.toChunks .+   NonNegChunky.normalize++++{-+ToDo: move to Storable.Signal+-}+{-# INLINE piecewiseConstant #-}+piecewiseConstant ::+   (Storable y) =>+   EventListBT.T StrictTime y -> SigSt.T y+piecewiseConstant =+   EventListBT.foldrPair+      (\y t -> SigSt.append (SigStV.replicate (chunkSizesFromStrictTime t) y))+      SigSt.empty++{-# INLINE piecewiseConstantInit #-}+piecewiseConstantInit ::+   (Storable y) =>+   y -> EventList.T StrictTime y -> SigSt.T y+piecewiseConstantInit initial =+   (\ ~(t,rest) ->+      SigSt.append (SigStV.replicate (chunkSizesFromStrictTime t) initial) rest)+   .+   EventList.foldr+      (,)+      (\y ~(t,rest) ->+         SigSt.append (SigStV.replicate (chunkSizesFromStrictTime t) y) rest)+      (0, SigSt.empty)+{-+   piecewiseConstant .+--   EventListBM.switchBodyR const .+--   EventListBM.snocTime NonNeg.zero .+--   EventListMB.consBody initial .+   -- switchBodyR causes a space leak+   EventListTM.switchBodyR EventListBT.empty+      (\xs _ -> EventListMT.consBody initial xs)+-}++{-# INLINE piecewiseConstantInitWith #-}+piecewiseConstantInitWith ::+   (Storable c) =>+   (y -> c) ->+   c -> EventList.T StrictTime [y] -> SigSt.T c+piecewiseConstantInitWith f initial =+   piecewiseConstantInit initial .+   flip evalState initial .+   traverse (\evs -> traverse_ (put . f) evs >> get)+++{-# INLINE controllerLinear #-}+controllerLinear ::+   (Check.C event, Storable y, Field.C y) =>+   Channel -> Controller ->+   (y,y) -> y ->+   Filter event (SigSt.T y)+controllerLinear chan ctrl bnd initial =+   liftM (piecewiseConstantInitWith (MV.controllerLinear bnd) initial) $+   getControllerEvents chan ctrl+++{-# INLINE controllerExponential #-}+controllerExponential ::+   (Check.C event, Storable y, Trans.C y) =>+   Channel -> Controller ->+   (y,y) -> y ->+   Filter event (SigSt.T y)+controllerExponential chan ctrl bnd initial =+   liftM (piecewiseConstantInitWith (MV.controllerExponential bnd) initial) $+   getControllerEvents chan ctrl+++{- |+@pitchBend channel range center@:+emits frequencies on an exponential scale from+@center/range@ to @center*range@.+-}+{-# INLINE pitchBend #-}+pitchBend ::+   (Check.C event, Storable y, Trans.C y) =>+   Channel ->+   y -> y ->+   Filter event (SigSt.T y)+pitchBend chan range center =+   liftM (piecewiseConstantInitWith (MV.pitchBend range center) center) $+   getSlice (Check.pitchBend chan)+--   getPitchBendEvents chan++{-# INLINE channelPressure #-}+channelPressure ::+   (Check.C event, Storable y, Trans.C y) =>+   Channel ->+   y -> y ->+   Filter event (SigSt.T y)+channelPressure chan maxVal initVal =+   liftM (piecewiseConstantInitWith (MV.controllerLinear (0,maxVal)) initVal) $+   getSlice (Check.channelPressure chan)+++{-+We could use 'getBendWheelPressureSignal' here,+but this may be less efficient.+-}+{-# INLINE bendWheelPressure #-}+bendWheelPressure ::+   (Check.C event, Storable y, RealRing.C y, Trans.C y) =>+   Channel ->+   Int -> y -> y -> y ->+   Filter event (SigSt.T y)+bendWheelPressure chan+     pitchRange speed wheelDepth pressDepth =+   do bend  <- pitchBend chan (2^?(fromIntegral pitchRange/12)) 1+      fm    <- controllerLinear chan VoiceMsg.modulation (0,wheelDepth) 0+      press <- channelPressure chan pressDepth 0+      return $+         flip (SigS.zipWithStorable (*)) bend $+         SigS.map (1+) $+         FiltNRS.envelope+            (DispS.mix+               (SigS.fromStorableSignal fm)+               (SigS.fromStorableSignal press))+            (OsciS.static Wave.sine zero speed)+++type Instrument y yv = Gen.Instrument y (SigSt.T yv)+type Bank y yv = Gen.Bank y (SigSt.T yv)+++{-# INLINE sequenceCore #-}+sequenceCore ::+   (Check.C event, Storable yv, Additive.C yv) =>+   SVL.ChunkSize ->+   Channel ->+   Program ->+   Gen.Modulator Note (SigSt.T yv) ->+   Filter event (SigSt.T yv)+sequenceCore chunkSize chan pgm modu =+   fmap (CutSt.arrangeEquidist chunkSize) $+   Gen.sequenceCore chan pgm modu+++{-# INLINE sequence #-}+sequence ::+   (Check.C event, Storable yv, Additive.C yv, Trans.C y) =>+   SVL.ChunkSize ->+   Channel ->+   Instrument y yv ->+   Filter event (SigSt.T yv)+sequence chunkSize chan bank =+   fmap (CutSt.arrangeEquidist chunkSize) $+   Gen.sequence chan bank+++{-# INLINE sequenceModulated #-}+sequenceModulated ::+   (Check.C event, Storable c, Storable yv, Additive.C yv, Trans.C y) =>+   SVL.ChunkSize ->+   SigSt.T c ->+   Channel ->+   (SigSt.T c -> Instrument y yv) ->+   Filter event (SigSt.T yv)+sequenceModulated chunkSize modu chan instr =+   fmap (CutSt.arrangeEquidist chunkSize) $+   Gen.sequenceModulated modu chan instr+++{-# INLINE sequenceMultiModulated #-}+sequenceMultiModulated ::+   (Check.C event, Storable yv, Additive.C yv, Trans.C y) =>+   SVL.ChunkSize ->+   Channel ->+   instrument ->+   Gen.Modulator (instrument, Note) (Instrument y yv, Note) ->+   Filter event (SigSt.T yv)+sequenceMultiModulated chunkSize chan instr modu =+   fmap (CutSt.arrangeEquidist chunkSize) $+   Gen.sequenceMultiModulated chan instr modu+++applyModulation ::+   (Storable c) =>+   SigSt.T c ->+   Gen.Modulator (SigSt.T c -> instr, note) (instr, note)+applyModulation =+   Gen.applyModulation++advanceModulationLazy, advanceModulationStrict, advanceModulationChunky ::+   (Storable a) =>+   LazyTime -> State (SigSt.T a) LazyTime++{-+This one drops lazily,+such that the control signal will be cached until it is used.+That is, if for a long time no new note is played,+more and more memory will be allocated.+-}+advanceModulationLazy t =+   modify (SigStV.drop (chunkSizesFromLazyTime t)) >> return t++{-+This one is too strict,+because the complete drop is forced+also if only the first chunk of the lazy time is requested.+-}+advanceModulationStrict t = state $ \xs ->+   let ys = SigStV.drop (chunkSizesFromLazyTime t) xs+   in  (Gen.evaluateVectorHead ys t, ys)++advanceModulationChunky =+   Gen.advanceModulation+++{-# INLINE sequenceMultiProgram #-}+sequenceMultiProgram ::+   (Check.C event, Storable yv, Additive.C yv, Trans.C y) =>+   SVL.ChunkSize ->+   Channel ->+   Program ->+   [Instrument y yv] ->+   Filter event (SigSt.T yv)+sequenceMultiProgram chunkSize chan pgm bank =+   fmap (CutSt.arrangeEquidist chunkSize) $+   Gen.sequenceMultiProgram chan pgm bank
+ src/Synthesizer/MIDI/Value.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE NoImplicitPrelude #-}+{- |+Functions for converting MIDI controller and key values+to something meaningful for signal processing.+-}+module Synthesizer.MIDI.Value where++import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg++import qualified Algebra.Transcendental as Trans+import qualified Algebra.Field          as Field++import NumericPrelude.Numeric+-- import NumericPrelude.Base+++{-# INLINE controllerLinear #-}+controllerLinear ::+   (Field.C y) =>+   (y,y) -> Int -> y+controllerLinear (lower,upper) n =+   let k = fromIntegral n / 127+   in  (1-k) * lower + k * upper++{-# INLINE controllerExponential #-}+controllerExponential ::+   (Trans.C y) =>+   (y,y) -> Int -> y+controllerExponential (lower,upper) n =+   let k = fromIntegral n / 127+   in  lower**(1-k) * upper**k++{-# INLINE pitchBend #-}+pitchBend ::+   (Trans.C y) =>+   y -> y -> Int -> y+pitchBend range center n =+   center * range ** (fromIntegral n / 8192)++{-# INLINE velocity #-}+velocity ::+   (Field.C y) =>+   VoiceMsg.Velocity -> y+velocity vel =+   fromIntegral (VoiceMsg.fromVelocity vel - 64)/63++{- |+Convert pitch to frequency according to the default tuning+in MIDI 1.0 Detailed Specification.+-}+{-# INLINE frequencyFromPitch #-}+frequencyFromPitch ::+   (Trans.C y) =>+   VoiceMsg.Pitch -> y+frequencyFromPitch pitch =+   440 * 2 ^? (fromIntegral (VoiceMsg.fromPitch pitch + 3 - 6*12) / 12)
+ src/Synthesizer/MIDI/Value/BendModulation.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE NoImplicitPrelude #-}+{- |+Combine pitchbend and modulation in one data type.+-}+module Synthesizer.MIDI.Value.BendModulation where++import qualified Synthesizer.MIDI.Value.BendWheelPressure as BWP+import qualified Synthesizer.MIDI.Value as MV++import qualified Algebra.Transcendental as Trans+import qualified Algebra.RealRing       as RealRing+import qualified Algebra.Ring           as Ring++import Foreign.Storable (Storable(sizeOf, alignment, peek, poke), )+import qualified Foreign.Storable.Traversable as Store++import qualified Data.Foldable as Fold+import qualified Data.Traversable as Trav++import Control.Applicative (Applicative, (<*>), pure, liftA2, )++import Control.DeepSeq (NFData, rnf, )++import NumericPrelude.Numeric+import NumericPrelude.Base+++{- |+'bend' is a frequency factor+and 'depth' is a modulation depth to be interpreted by the instrument.+-}+data T a = Cons {bend, depth :: a}+   deriving (Show, Eq)++deflt :: (Ring.C a) => T a+deflt = Cons one zero+++instance (NFData a) => NFData (T a) where+   rnf bm =+      case rnf (bend bm) of () -> rnf (depth bm)+++instance Functor T where+   {-# INLINE fmap #-}+   fmap f (Cons b m) = Cons (f b) (f m)++-- useful for defining 'peek' instance+instance Applicative T where+   {-# INLINE pure #-}+   pure a = Cons a a+   {-# INLINE (<*>) #-}+   (Cons fb fm) <*> (Cons b m) =+      Cons (fb b) (fm m)++instance Fold.Foldable T where+   {-# INLINE foldMap #-}+   foldMap = Trav.foldMapDefault++-- this allows for kinds of generic programming+instance Trav.Traversable T where+   {-# INLINE sequenceA #-}+   sequenceA (Cons b m) =+      liftA2 Cons b m+++force :: T a -> T a+force ~(Cons a b) = (Cons a b)++instance (Storable a) => Storable (T a) where+   {-# INLINE sizeOf #-}+   sizeOf = Store.sizeOf . force+   {-# INLINE alignment #-}+   alignment = Store.alignment . force+   {-# INLINE peek #-}+   peek = Store.peekApplicative+   {-# INLINE poke #-}+   poke = Store.poke++++{- |+Multiply the pitch bend by a given factor.+This way you can e.g. shift the pitch bend from around 1+to the actual frequency.+-}+shift ::+   (Ring.C a) =>+   a -> T a -> T a+shift k (Cons b d) = Cons (k*b) d++fromBendWheelPressure ::+   (RealRing.C a, Trans.C a) =>+   Int -> a -> a ->+   BWP.T -> T a+fromBendWheelPressure+      pitchRange wheelDepth pressDepth bwp =+   Cons+      (MV.pitchBend (2^?(fromIntegral pitchRange/12)) 1 (BWP.bend_ bwp))+      (MV.controllerLinear (0,wheelDepth) (BWP.wheel_ bwp) ++       MV.controllerLinear (0,pressDepth) (BWP.pressure_ bwp))
+ src/Synthesizer/MIDI/Value/BendWheelPressure.hs view
@@ -0,0 +1,60 @@+module Synthesizer.MIDI.Value.BendWheelPressure where++import qualified Sound.MIDI.Message.Class.Check as Check+import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg+import Sound.MIDI.Message.Channel (Channel, )++import qualified Data.Accessor.Monad.Trans.State as AccState+import qualified Data.Accessor.Basic as Accessor++import Control.Monad.Trans.State (State, get, )+import Control.Monad (msum, )++import Data.Traversable (sequence, )++import Control.DeepSeq (NFData, rnf, )++import Prelude hiding (sequence, )+++data T = Cons {bend_, wheel_, pressure_ :: Int}+   deriving (Show, Eq)++deflt :: T+deflt = Cons 0 0 0+++bend, wheel, pressure :: Accessor.T T Int+bend =+   Accessor.fromSetGet+      (\b (Cons _ w p) -> Cons b w p)+      bend_++wheel =+   Accessor.fromSetGet+      (\w (Cons b _ p) -> Cons b w p)+      wheel_++pressure =+   Accessor.fromSetGet+      (\p (Cons b w _) -> Cons b w p)+      pressure_+++instance NFData T where+   rnf (Cons b w p) =+      case (rnf b, rnf w, rnf p) of+         ((), (), ()) -> ()+++check ::+   Check.C event =>+   Channel -> event -> State T (Maybe T)+check chan ev =+   sequence $+   (fmap (>> get)) $+   msum $ map ($ev) $+      (fmap (AccState.set bend) . Check.pitchBend chan) :+      (fmap (AccState.set wheel) . Check.controller chan VoiceMsg.modulation) :+      (fmap (AccState.set pressure) . Check.channelPressure chan) :+      []
+ src/Test.hs view
@@ -0,0 +1,219 @@+module Main where++import qualified Synthesizer.MIDI.PiecewiseConstant as PC++import qualified Synthesizer.MIDI.Generic as Gen+import Synthesizer.MIDI.Storable (+   Instrument, chunkSizesFromLazyTime, )++import qualified Synthesizer.Basic.Wave          as Wave+import qualified Synthesizer.Frame.Stereo        as Stereo++import Foreign.Storable (Storable, )++import qualified Synthesizer.Storable.Cut         as CutSt+import qualified Synthesizer.Storable.Signal      as SigSt+import qualified Data.StorableVector.Lazy         as SVL++import qualified Synthesizer.State.Signal      as SigS+import qualified Synthesizer.State.Oscillator  as OsciS+import qualified Synthesizer.State.Filter.NonRecursive as FiltNRS++import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg+import qualified Sound.MIDI.Message.Channel       as ChannelMsg+import Sound.MIDI.Message.Channel (Channel, )++import qualified Data.EventList.Relative.TimeBody  as EventList+import qualified Data.EventList.Relative.BodyTime  as EventListBT+-- import Data.EventList.Relative.MixedBody ((/.), (./), )++import Control.Monad.Trans.State (evalState, )+import Control.Monad (when, )++import qualified Algebra.Additive  as Additive++import NumericPrelude.Numeric (zero, (^?), )+import Prelude hiding (Real, break, )+++import qualified System.IO as IO++++channel :: Channel+channel = ChannelMsg.toChannel 0++sampleRate :: Num a => a+-- sampleRate = 24000+-- sampleRate = 48000+sampleRate = 44100++latency :: Int+latency = 0+-- latency = 256+-- latency = 1000++chunkSize :: SVL.ChunkSize+chunkSize = SVL.defaultChunkSize++consNone ::+   time ->+   EventList.T time [body] ->+   EventList.T time [body]+consNone t = EventList.cons t []++consSingle ::+   time -> body ->+   EventList.T time [body] ->+   EventList.T time [body]+consSingle t b = EventList.cons t [b]++emptys :: time -> EventList.T time [ChannelMsg.T]+emptys t =+   let evs = consNone t evs+   in  evs+++type Real = Float+++evaluatePrefix ::+   (Storable a, Additive.C a, Eq a) =>+   SVL.Vector a -> Bool+evaluatePrefix =+   (\x -> x==x) .+   SVL.foldl' (Additive.+) zero .+   SVL.take 100000+++sequenceSpaceLeakEmpty :: Bool+sequenceSpaceLeakEmpty =+   evaluatePrefix $+   CutSt.arrange chunkSize $+   evalState (Gen.sequence channel+      (error "no sound" :: Instrument Real Real)) $+   emptys 10++sequenceSpaceLeakModulatedEmpty :: Bool+sequenceSpaceLeakModulatedEmpty =+   evaluatePrefix $+   CutSt.arrange chunkSize $+   evalState+      (Gen.sequenceModulated+         (SigSt.iterate chunkSize (1+) 0) channel+         (error "no sound" :: SigSt.T Real -> Instrument Real Real)) $+   emptys 10+++sequenceSpaceLeakLazyDrop :: Bool+sequenceSpaceLeakLazyDrop =+   evaluatePrefix $+   CutSt.arrange chunkSize $+   evalState+      (let fm y = (EventListBT.cons $! y) 10 (fm (2-y))+       in  Gen.sequenceModulated (fm 1) channel+              (error "no sound" ::+                  PC.T Real -> Instrument Real Real)) $+   emptys 10+++stringStereoFM :: SigSt.T Real -> Instrument Real (Stereo.T Real)+stringStereoFM fmSt vel freq dur =+   let fm = SigS.fromStorableSignal fmSt+   in  SigS.toStorableSignalVary (chunkSizesFromLazyTime dur) $+       FiltNRS.amplifyVector (4^?vel) $+       SigS.zipWith Stereo.cons+          (OsciS.freqMod Wave.saw zero $+           FiltNRS.amplify (freq*0.999/sampleRate) fm)+          (OsciS.freqMod Wave.saw zero $+           FiltNRS.amplify (freq*1.001/sampleRate) fm)+++makeNote ::+   (ChannelMsg.Pitch ->+    ChannelMsg.Velocity ->+    VoiceMsg.T) ->+   Int -> ChannelMsg.T+makeNote note pitch =+   ChannelMsg.Cons+      (ChannelMsg.toChannel 0)+      (ChannelMsg.Voice $+       note (VoiceMsg.toPitch pitch)+            (VoiceMsg.toVelocity VoiceMsg.normalVelocity))++makeNoteOn, makeNoteOff :: Int -> ChannelMsg.T+makeNoteOn  = makeNote VoiceMsg.NoteOn+makeNoteOff = makeNote VoiceMsg.NoteOff+++sequenceSpaceLeakModulatedInfinite :: Bool+sequenceSpaceLeakModulatedInfinite =+   evaluatePrefix $+   CutSt.arrange chunkSize $+   evalState+      (Gen.sequenceModulated+         (SigSt.iterate chunkSize (1e-7 +) 1) channel+         stringStereoFM) $+   let evs t = consNone t (evs (20-t))+   in  consSingle 10 (makeNoteOn 60) $+       evs 10++sequenceSpaceLeakModulatedChordStep :: Bool+sequenceSpaceLeakModulatedChordStep =+   evaluatePrefix $+   CutSt.arrange chunkSize $+   evalState+      (Gen.sequenceModulated+         (SigSt.iterate chunkSize (1e-7 +) 1) channel+         stringStereoFM) $+   let evs t = consNone t (evs (20-t))+   in  consSingle 10 (makeNoteOn 60) $+       consSingle 10 (makeNoteOn 64) $+       consSingle 10 (makeNoteOn 67) $+       evs 10++sequenceSpaceLeakModulatedChordSimultaneous :: Bool+sequenceSpaceLeakModulatedChordSimultaneous =+   evaluatePrefix $+   CutSt.arrange chunkSize $+   evalState+      (Gen.sequenceModulated+         (SigSt.iterate chunkSize (1e-7 +) 1) channel+         stringStereoFM) $+   let evs t = EventList.cons t [] (evs (20-t))+   in  EventList.cons 10+          [makeNoteOn 60,+           makeNoteOn 64,+           makeNoteOn 67] $+       evs 10++sequenceSpaceLeakStaccato :: Bool+sequenceSpaceLeakStaccato =+   evaluatePrefix $+   CutSt.arrange chunkSize $+   evalState+      (Gen.sequenceModulated+         (SigSt.iterate chunkSize (1e-7 +) 1) channel+         stringStereoFM) $+   let evs t =+          consSingle t (makeNoteOn  60) $+          consSingle t (makeNoteOff 60) $+          evs (20-t)+   in  evs 10+++test :: String -> Bool -> IO ()+test name result = do+   putStr name+   IO.hFlush IO.stdout+   when result (putStrLn " ok")++main :: IO ()+main = do+   test "sequenceSpaceLeakEmpty"                      sequenceSpaceLeakEmpty+   test "sequenceSpaceLeakModulatedEmpty"             sequenceSpaceLeakModulatedEmpty+   test "sequenceSpaceLeakLazyDrop"                   sequenceSpaceLeakLazyDrop+   test "sequenceSpaceLeakModulatedInfinite"          sequenceSpaceLeakModulatedInfinite+   test "sequenceSpaceLeakModulatedChordStep"         sequenceSpaceLeakModulatedChordStep+   test "sequenceSpaceLeakModulatedChordSimultaneous" sequenceSpaceLeakModulatedChordSimultaneous+   test "sequenceSpaceLeakStaccato"                   sequenceSpaceLeakStaccato
+ synthesizer-midi.cabal view
@@ -0,0 +1,114 @@+Name:           synthesizer-midi+Version:        0.5+License:        GPL+License-File:   LICENSE+Author:         Henning Thielemann <haskell@henning-thielemann.de>+Maintainer:     Henning Thielemann <haskell@henning-thielemann.de>+Homepage:       http://www.haskell.org/haskellwiki/Synthesizer+Category:       Sound, Music+Synopsis:       Render audio signals from MIDI files or realtime messages+Description:+  This package allows to read MIDI events+  and to convert them to audio and control signals.+  Included is a basic synthesizer that renders MIDI to WAV+  (or other audio signal formats supported by SoX).+Stability:      Experimental+Tested-With:    GHC==6.12.3+Tested-With:    GHC==7.2.1+Cabal-Version:  >=1.6+Build-Type:     Simple++Source-Repository this+  Tag:         0.4+  Type:        darcs+  Location:    http://code.haskell.org/synthesizer/midi/++Source-Repository head+  Type:        darcs+  Location:    http://code.haskell.org/synthesizer/midi/++Flag splitBase+  description: Choose the new smaller, split-up base package.++Flag buildExamples+  description: Build example executables+  default:     False++Flag buildTests+  description: Build test executables+  default:     False++Library+  Build-Depends:+    synthesizer-dimensional >=0.6 && <0.7,+    synthesizer-core >=0.5 && <0.6,+    sox >=0.2.1 && <0.3,+    midi >=0.1.7 && <0.2,+    storable-record >=0.0.2 && <0.1,+    storablevector >=0.2.5 && <0.3,+    deepseq >=1.1 && <1.2,+    numeric-prelude >=0.3 && <0.4,+    non-negative >=0.1 && <0.2,+    event-list >=0.1 && <0.2,+    data-accessor-transformers >=0.2.1 && <0.3,+    data-accessor >=0.2.1 && <0.3,+    containers >=0.1 && <0.5,+    array >=0.1 && <0.5,+    transformers >=0.2 && <0.3,+    utility-ht >=0.0.1 && <0.1++  If flag(splitBase)+    Build-Depends:+      base >= 3 && <5+  Else+    Build-Depends:+      base >= 1.0 && < 2++  If impl(ghc>=7.0)+    GHC-Options: -fwarn-unused-do-bind+    CPP-Options: -DNoImplicitPrelude=RebindableSyntax+    Extensions: CPP++  GHC-Options:    -Wall+  Hs-source-dirs: src+  Exposed-modules:+    Synthesizer.MIDI.EventList+    Synthesizer.MIDI.Generic+    Synthesizer.MIDI.Storable+    Synthesizer.MIDI.CausalIO.ControllerSelection+    Synthesizer.MIDI.CausalIO.ControllerSet+    Synthesizer.MIDI.CausalIO.Process+    Synthesizer.MIDI.PiecewiseConstant+    Synthesizer.MIDI.PiecewiseConstant.ControllerSet+    Synthesizer.MIDI.Dimensional+    Synthesizer.MIDI.Example.Instrument+    Synthesizer.MIDI.Dimensional.Example.Instrument+    -- these modules could be as well located in the midi package,+    -- but they are based on NumericPrelude+    Synthesizer.MIDI.Value.BendWheelPressure+    Synthesizer.MIDI.Value.BendModulation+    Synthesizer.MIDI.Value+    Synthesizer.MIDI.Dimensional.Value+    Synthesizer.MIDI.Dimensional.ValuePlain++Executable render-midi+  If !flag(buildExamples)+    Buildable: False+  GHC-Options: -Wall+  If impl(ghc>=7.0)+    GHC-Options: -fwarn-unused-do-bind+    CPP-Options: -DNoImplicitPrelude=RebindableSyntax+    Extensions: CPP+  Hs-Source-Dirs: src+  Main-Is: Render.hs++Executable test+  If !flag(buildTests)+    Buildable: False+  GHC-Options: -Wall+  If impl(ghc>=7.0)+    GHC-Options: -fwarn-unused-do-bind+    CPP-Options: -DNoImplicitPrelude=RebindableSyntax+    Extensions: CPP+  Hs-Source-Dirs: src+  Main-Is: Test.hs