packages feed

synthesizer-core (empty) → 0.2

raw patch · 137 files changed

+24651/−0 lines, 137 filesdep +QuickCheckdep +arraydep +basesetup-changed

Dependencies added: QuickCheck, array, base, binary, bytestring, containers, directory, event-list, filepath, non-negative, numeric-prelude, numeric-quest, old-time, process, random, sox, special-functors, storable-record, storablevector, 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>.
+ Makefile view
@@ -0,0 +1,7 @@+MODULE_PATH = src:src-3++ghci:+	ghci -Wall -odirdist/build -hidirdist/build -hide-package synthesizer -i:$(MODULE_PATH)++tutorial:+	ghci -Wall -fobject-code -fexcess-precision -O2 -fvia-C -optc-O2 -odirdist/build -hidirdist/build -hide-package synthesizer -i:$(MODULE_PATH) src/Synthesizer/Generic/Tutorial.hs
+ Setup.lhs view
@@ -0,0 +1,3 @@+#! /usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ speedtest/FusionTest.hs view
@@ -0,0 +1,819 @@+{-# OPTIONS_GHC -O2 #-}+module Main (main) where++import qualified Synthesizer.Storable.Signal as SigSt+import qualified Synthesizer.Storable.Oscillator as OsciSt+import qualified Synthesizer.Storable.Cut as CutSt++import qualified Synthesizer.State.Signal as SigS+import qualified Synthesizer.State.Oscillator as OsciS+import qualified Synthesizer.State.Control as CtrlS+import qualified Synthesizer.State.Filter.NonRecursive as FiltNRS+import qualified Synthesizer.State.Cut as CutS+import qualified Synthesizer.State.NoiseCustom as NoiseS+import qualified Synthesizer.State.Interpolation as InterpolationS++import qualified Synthesizer.FusionList.Signal as SigFL+import qualified Synthesizer.FusionList.Oscillator as OsciFL+import qualified Synthesizer.FusionList.Control as CtrlFL+import qualified Synthesizer.FusionList.Filter.NonRecursive as FiltNRFL++import qualified Synthesizer.Generic.Signal as SigG+import qualified Synthesizer.Generic.Filter.Delay as DelayG+import qualified Synthesizer.Generic.Interpolation as InterpolationG++import qualified Synthesizer.Interpolation.Module as InterpolationM+import qualified Synthesizer.Basic.Wave       as Wave+import qualified Synthesizer.Basic.Phase      as Phase+import qualified Synthesizer.Basic.DistortionControlled as Dist+import qualified Synthesizer.Plain.Filter.Recursive.Universal as UniFilter+import qualified Synthesizer.Plain.Filter.Recursive    as FiltR+import qualified Synthesizer.Plain.Control as Ctrl+import Synthesizer.Piecewise ((|#), (#|-), (-|#), (#|), )++import qualified Data.EventList.Relative.TimeBody as EventList++import Synthesizer.Basic.Binary (int16FromCanonical, int16FromDouble, )+import Data.Int (Int8, Int16, )+import Foreign.Storable (Storable, )+import qualified Data.List as List+import qualified Data.Char as Char++import GHC.Float (double2Int, int2Double)+import NumericPrelude ((^?))+import qualified NumericPrelude as NP++import qualified Algebra.Transcendental as Trans+import qualified Algebra.Field          as Field+import qualified Algebra.Ring           as Ring+import qualified Algebra.Additive       as Additive++import System.Random (mkStdGen)+import qualified Synthesizer.RandomKnuth as Knuth+++{-+If you increase the chunk size to 10000 the computation becomes slower.+Is this reproducable?+-}+defaultChunkSize :: SigSt.ChunkSize+defaultChunkSize = SigSt.chunkSize 1000+++{-# INLINE storableFromFusionList #-}+storableFromFusionList :: Storable a => SigFL.T a -> SigSt.T a+storableFromFusionList =+   SigFL.toStorableSignal defaultChunkSize+--   SigSt.fromFusionList defaultChunkSize++mapTest0 :: SigSt.T Char+mapTest0 =+   SigSt.fromList defaultChunkSize+      (List.map succ (List.replicate 200000 'a'))++mapTest1 :: [Char] -> SigSt.T Char+mapTest1 =+   SigSt.fromList defaultChunkSize . List.map Char.toUpper++mapTest2 :: [Char] -> SigSt.T Char+mapTest2 xs =+   SigSt.fromList defaultChunkSize (List.map Char.toUpper xs)++mapTest3 :: SigSt.T Int8+mapTest3 =+   SigSt.fromList defaultChunkSize+      (List.map succ (List.replicate 200000 1234))++mapTest4 :: SigSt.T Int8+mapTest4 =+   SigSt.fromList defaultChunkSize+      (List.map pred (List.replicate 200000 1234))++mapTest5 :: SigSt.T Int8+mapTest5 =+   storableFromFusionList+      (SigFL.map pred (SigFL.replicate 200000 1234))++{- inlining here even reduces the application of rules - Why? -}+{- INLINE mapTest6 -}+mapTest6 :: SigSt.T Int16+mapTest6 =+   storableFromFusionList $ SigFL.take 200000 $+   SigFL.map int16FromCanonical $+--   SigFL.map (^2) $+   SigFL.repeat (3::Double)+++{-# INLINE zeroPhase #-}+zeroPhase :: Phase.T Double+zeroPhase = NP.zero++osciTest0 :: SigSt.T Int16+osciTest0 =+   storableFromFusionList $+   SigFL.take 200000 $+   -- int16FromCanonical is not only slow in execution but also blocks fusion - why?+   SigFL.map int16FromCanonical $+   (OsciFL.staticSaw zeroPhase 0.01 :: SigFL.T Double)++osciTest0a :: SigSt.T Int16+osciTest0a =+   storableFromFusionList $+   SigFL.take 200000 $+   SigFL.map int16FromDouble $+   OsciFL.staticSaw zeroPhase 0.01++{-+{-# INLINE exponential2 #-}+exponential2 :: Trans.C a =>+      a   {-^ half life -}+   -> a   {-^ initial value -}+   -> SigFL.T a+          {-^ exponential decay -}+exponential2 halfLife =+   SigFL.iterate (((Ring.one Field./ (Ring.one Additive.+ Ring.one)) Trans.^? Field.recip halfLife) Ring.*)+-}+++osciTest0b :: SigSt.T Int16+osciTest0b =+   storableFromFusionList $+   SigFL.take 200000 $+   SigFL.map int16FromDouble $+   FiltNRFL.envelope+      (CtrlFL.exponential2 50000 1)+      (OsciFL.staticSaw zeroPhase 0.01)++osciTest0ba :: SigSt.T Int16+osciTest0ba =+   storableFromFusionList $+   SigFL.take 200000 $+   SigFL.map int16FromDouble $+   CtrlFL.exponential2 50000 1++osciTest0c :: SigSt.T Int16+osciTest0c =+   storableFromFusionList $+   SigFL.take 200000 $+   SigFL.map int16FromDouble $+   FiltNRFL.envelope+      (CtrlFL.exponential2 50000 0.5)+      (OsciFL.shapeMod Wave.squareBalanced zeroPhase 0.01 $+          SigFL.map (0.5*) $ OsciFL.staticSine zeroPhase 0.00002)++osciTest0d :: SigSt.T Int16+osciTest0d =+   storableFromFusionList $+   SigFL.take 200000 $+   SigFL.map int16FromDouble $+   FiltNRFL.envelope+--      (exponential2 50000 0.5)+      (CtrlFL.exponential2 50000 0.5)+--      (SigFL.iterate ((0.5 ^? recip 50000)*) 0.5)+      (OsciFL.freqMod Wave.square zeroPhase+          (SigFL.map (0.01+) $ SigFL.map (0.0001*) $ OsciFL.staticSine zeroPhase 0.0001))++osciTest0e :: SigSt.T Int16+osciTest0e =+   storableFromFusionList $+   SigFL.take 200000 $+   SigFL.map int16FromDouble $+   FiltNRFL.envelope+      (CtrlFL.exponential2 50000 0.5)+      (OsciFL.shapeFreqMod Wave.squareBalanced zeroPhase+          (SigFL.map (0.5*) $ OsciFL.staticSine zeroPhase 0.00002)+          (SigFL.map (0.01+) $ SigFL.map (0.0001*) $ OsciFL.staticSine zeroPhase 0.0001))++osciTest0ea :: SigSt.T Int16+osciTest0ea =+   storableFromFusionList $+   SigFL.take 200000 $+   SigFL.map int16FromDouble $+      (OsciFL.shapeFreqMod Wave.squareBalanced zeroPhase+          (OsciFL.staticSine zeroPhase 0.00002)+          (OsciFL.staticSine zeroPhase 0.0001))++osciTest0f :: SigSt.T Int16+osciTest0f =+   storableFromFusionList $+   SigFL.take 200000 $+   SigFL.map int16FromDouble $+   FiltNRFL.envelope+      (CtrlFL.exponential2 50000 1)+--      (SigFL.zipWith (\x y -> (x+y)/2)+--      (MiscFL.mix+      (SigFL.mix+         (OsciFL.static Wave.saw zeroPhase 0.01003)+         (OsciFL.static Wave.saw zeroPhase 0.00997))+-- staticSaw blocks fusion+--         (OsciFL.staticSaw zeroPhase 0.01003)+--         (OsciFL.staticSaw zeroPhase 0.00997))++osciTest0fa :: SigSt.T Int16+osciTest0fa =+   storableFromFusionList $+   SigFL.take 200000 $+   SigFL.map int16FromDouble $+   FiltNRFL.envelope+      (CtrlFL.exponential2 50000 1)+      (SigFL.mix+         (SigFL.mix+            (OsciFL.staticSaw zeroPhase 0.01001)+            (OsciFL.staticSaw zeroPhase 0.00998))+         (SigFL.mix+            (OsciFL.staticSaw zeroPhase 0.01005)+            (OsciFL.staticSaw zeroPhase 0.00996)))++osciTest1 :: SigSt.T Double+osciTest1 =+   storableFromFusionList $+   SigFL.take 200000 $+   (OsciFL.staticSaw zeroPhase 0.01 :: SigFL.T Double)++osciTest2 :: SigSt.T Int16+osciTest2 =+   storableFromFusionList $+   SigFL.take 200000 $+   SigFL.iterate (200+) 0++osciTest3 :: SigSt.T Double+osciTest3 =+   SigSt.take 200000 $+   SigSt.map (\x->x*x) $+   SigSt.iterate defaultChunkSize (200+) 0++osciTest4 :: SigSt.T Int16+osciTest4 =+   SigSt.take 200000 $+   SigSt.map int16FromCanonical $  -- this is now really fast thanks to specialisation+   (SigSt.iterate defaultChunkSize (1+) 0 :: SigSt.T Double)++osciTest5 :: SigSt.T Int16+osciTest5 =+   SigSt.take 200000 $+   SigSt.map int16FromDouble $+   (SigSt.iterate defaultChunkSize (1+) 0 :: SigSt.T Double)++osciTest6 :: SigSt.T Int16+osciTest6 =+   -- takeCrochet is slow if not fused away+   SigSt.takeCrochet 200000 $+   SigSt.map int16FromDouble $+   (SigSt.iterate defaultChunkSize (1+) 0 :: SigSt.T Double)+++{-+waveSine :: Floating a => a -> a+waveSine x = sin (2*pi*x)+-}++{-+waveSine :: Trans.C a => a -> a+waveSine x = Trans.sin (NP.fromInteger 2 NP.* Trans.pi NP.* x)++incrFracDouble :: Double -> Double -> Double+incrFracDouble d x = NP.fraction (d + x)++{-# ONLINE incrFrac #-}+incrFrac :: NP.RealFrac a => a -> a -> a+incrFrac d x = NP.fraction (d NP.+ x)++fraction :: Double -> Double+fraction x =+   let second :: (Int, a) -> a+       second = snd+       f = second (properFraction x)+   in  if f>=0 then f else f+1+-}++{-+fraction :: Double -> Double+fraction x = x - fromIntegral (floor x :: Int)+-}++{-+fraction :: Double -> Double+fraction x = x - int2Double (double2Int x)++incrFracDouble :: Double -> Double -> Double+incrFracDouble d x = fraction (d + x)+-}++{-+incrFracDouble :: Double -> Double -> Double+incrFracDouble d x = d + x+-}+++osciTest7 :: SigSt.T Int16+osciTest7 =+   SigSt.take 200000 $+   SigSt.map int16FromDouble $+--   SigSt.map (\x -> sin (2*pi*x)) $+   SigSt.map (Wave.apply Wave.sine) $+--   SigSt.map (Wave.apply waveSine) $+--   (SigSt.iterate defaultChunkSize (0.01 +) NP.zero :: SigSt.T (Phase.T Double))+   (SigSt.iterate defaultChunkSize (Phase.increment 0.01) NP.zero :: SigSt.T (Phase.T Double))+--   (SigSt.iterate defaultChunkSize (incrFrac 0.01) NP.zero :: SigSt.T (Phase.T Double))+--   (SigSt.iterate defaultChunkSize (incrFracDouble 0.01) NP.zero :: SigSt.T (Phase.T Double))++osciTest8 :: SigSt.T Int16+osciTest8 =+   SigSt.take 200000 $+   SigSt.map int16FromDouble $+   (OsciSt.staticSaw defaultChunkSize zeroPhase 0.01 :: SigSt.T Double)+++appendTest0 :: SigSt.T Int16+appendTest0 =+   storableFromFusionList $+   SigFL.map int16FromDouble $+      let tone0 = SigFL.take 100000 $ OsciFL.static Wave.saw zeroPhase 0.010+          tone1 = SigFL.take 100000 $ OsciFL.static Wave.saw zeroPhase 0.015+      in  SigFL.append tone0 tone1++appendTest1 :: SigSt.T Int16+appendTest1 =+   let tone0 = SigFL.take 100000 $ OsciFL.static Wave.saw zeroPhase 0.010+       tone1 = SigFL.take 100000 $ OsciFL.static Wave.saw zeroPhase 0.015+   in  storableFromFusionList $+       SigFL.map int16FromDouble $+       SigFL.append tone0 tone1++appendTest2 :: SigSt.T Int16+appendTest2 =+   SigSt.map int16FromDouble $+   SigSt.appendFromFusionList defaultChunkSize+      (SigFL.take 100000 $ OsciFL.static Wave.saw zeroPhase 0.010)+      (SigFL.take 100000 $ OsciFL.static Wave.saw zeroPhase 0.015)++appendTest3 :: SigSt.T Int16+appendTest3 =+   storableFromFusionList $+   SigFL.map int16FromDouble $+   SigSt.appendFusionList defaultChunkSize+      (SigFL.take 100001 $ OsciFL.static Wave.sine zeroPhase 0.010)+      (SigFL.take 100000 $ OsciFL.static Wave.saw zeroPhase 0.015)++mixTest0 :: SigSt.T Int16+mixTest0 =+   SigSt.map int16FromDouble $+   SigSt.mixSize defaultChunkSize+      (SigSt.replicate defaultChunkSize 100000 NP.zero)+      (SigSt.replicate defaultChunkSize 100001 NP.one)++mixTest3 :: SigSt.T Int16+mixTest3 =+   SigSt.map int16FromDouble $+   SigSt.mixSize defaultChunkSize+--      (storableFromFusionList $ SigFL.take 100000 $ OsciFL.static Wave.sine zeroPhase 0.010)+--      (storableFromFusionList $ SigFL.take 100000 $ CtrlFL.exponential2 50000 1)+      (storableFromFusionList $ SigFL.take 100001 $ OsciFL.static Wave.saw zeroPhase 0.015)+      (SigSt.empty)++mixTest4 :: SigSt.T Int16+mixTest4 =+   SigSt.map int16FromDouble $+   SigSt.mixSize defaultChunkSize+      (SigSt.take 100002 $ OsciSt.staticSine defaultChunkSize zeroPhase 0.020) $+   SigSt.mixSize defaultChunkSize+      (SigSt.take 100001 $ OsciSt.staticSine defaultChunkSize zeroPhase 0.010)+      (SigSt.take 100000 $ OsciSt.staticSaw  defaultChunkSize zeroPhase 0.015)+++mixTest5 :: SigSt.T Int16+mixTest5 =+   SigSt.map int16FromDouble $+   SigSt.take 441000 $+--   SigSt.append+   SigSt.mix+--   SigSt.mixSize defaultChunkSize+      (SigSt.iterate defaultChunkSize ((1-1e-6)*) 0.5)+      (SigSt.iterate defaultChunkSize (1e-6 +) 0)++mixTest6 :: SigSt.T Int16+mixTest6 =+   SigSt.map int16FromDouble $+   SigSt.take 441000 $+--   SigSt.append+   SigSt.mix+--   SigSt.mixSize defaultChunkSize+      (SigS.toStorableSignal defaultChunkSize $ SigS.iterate ((1-1e-6)*) 0.5)+      (SigS.toStorableSignal defaultChunkSize $ SigS.iterate (1e-6 +) 0)+++stateTest0 :: SigSt.T Int16+stateTest0 =+   SigS.toStorableSignal defaultChunkSize $+   SigS.map int16FromDouble $+   SigS.take 441000 $+   SigS.zipWith (*) (SigS.iterate ((1-1e-4)*) 1) $+--   SigS.map (\t -> if even (floor t :: Int) then 1 else -1) $+   SigS.map sin $+   SigS.iterate ((2*pi/100)+) (0::Double)++stateTest1 :: SigSt.T Int16+stateTest1 =+   SigS.toStorableSignal defaultChunkSize $+   SigS.map int16FromDouble $+   SigS.take 100000 $+   SigS.zipWith Dist.sine (SigS.iterate ((1-0.3e-4)*) 1) $+   SigS.map (Wave.apply Wave.sine) $+   SigS.iterate (Phase.increment 0.01) zeroPhase++stateTest2 :: SigSt.T Int16+stateTest2 =+   SigS.toStorableSignal defaultChunkSize $+   SigS.map int16FromDouble $+   SigS.take 100000 $+   SigS.map (Dist.logit 1) $+   SigS.map (Dist.sine 5) $+   SigS.zipWith (*) (SigS.iterate ((1-0.3e-4)*) 30) $+   SigS.map (Wave.apply Wave.sine) $+   SigS.iterate (Phase.increment 0.01) zeroPhase++stateOsciTest0 :: SigSt.T Int16+stateOsciTest0 =+   SigS.toStorableSignal defaultChunkSize $+   SigS.take 200000 $+   SigS.map int16FromCanonical $+   (OsciS.static Wave.saw zeroPhase 0.01 :: SigS.T Double)++stateOsciTest0a :: SigSt.T Int16+stateOsciTest0a =+   SigS.toStorableSignal defaultChunkSize $+   SigS.take 200000 $+   SigS.map int16FromDouble $+   OsciS.static Wave.saw zeroPhase 0.01++stateOsciTest0fa :: SigSt.T Int16+stateOsciTest0fa =+   SigS.toStorableSignal defaultChunkSize $+   SigS.take 200000 $+   SigS.map int16FromDouble $+--   FiltNRS.envelope+--      (CtrlS.exponential2 50000 1)+   SigS.map (0.5*) $+      (SigS.mix+         (SigS.mix+            (OsciS.static Wave.saw (Phase.fromRepresentative 0.1) 0.01001)+            (OsciS.static Wave.saw (Phase.fromRepresentative 0.7) 0.00998))+         (SigS.mix+            (OsciS.static Wave.saw (Phase.fromRepresentative 0.2) 0.01005)+            (OsciS.static Wave.saw (Phase.fromRepresentative 0.4) 0.00996)))++{-# INLINE chord #-}+chord :: SigS.T Double+chord =+   let freq = 0.005+       {-# INLINE tone #-}+       tone f =+          SigS.mix+             (SigS.mix+                (OsciS.static Wave.saw zeroPhase (f*1.001))+                (OsciS.static Wave.saw zeroPhase (f*0.998)))+             (SigS.mix+                (OsciS.static Wave.saw zeroPhase (f*1.005))+                (OsciS.static Wave.saw zeroPhase (f*0.996)))+   in  tone (freq*1.00) `SigS.mix`+       tone (freq*1.25) `SigS.mix`+       tone (freq*1.50)++stateOsciTestChord :: SigSt.T Int16+stateOsciTestChord =+   SigS.toStorableSignal defaultChunkSize $+   SigS.take 200000 $+   SigS.map int16FromDouble $+   SigS.map (0.2*) $+   chord++stateFilterTest :: SigSt.T Int16+stateFilterTest =+   SigS.toStorableSignal defaultChunkSize $+   SigS.take 200000 $+   SigS.map int16FromDouble $+   SigS.map (0.05*) $+   SigS.map UniFilter.lowpass $+   SigS.modifyModulated+      UniFilter.modifier+      (SigS.map UniFilter.parameter $+       SigS.zipWith FiltR.Pole+          (SigS.repeat (5::Double))+          (SigS.map (\f -> 0.02*3 ^? f) $+           OsciS.static Wave.fastSine2 (Phase.fromRepresentative 0.75) 0.000005)) $+   chord++stateAppendTest0 :: SigSt.T Int16+stateAppendTest0 =+   SigS.toStorableSignal defaultChunkSize $+   SigS.map int16FromDouble $+      let tone f =+             SigS.take 50000 $+             SigS.map (Wave.apply Wave.saw) $+             SigS.iterate (Phase.increment f) zeroPhase+      in  tone 0.010 `SigS.append`+          tone 0.015 `SigS.append`+          tone 0.020++stateAppendTest1 :: SigSt.T Int16+stateAppendTest1 =+   SigS.toStorableSignal defaultChunkSize $+   SigS.map int16FromDouble $+      let tone f =+             SigS.take 50000 $+             SigS.map (Wave.apply Wave.saw) $+             SigS.iterate (Phase.increment f) zeroPhase+      in  tone 0.010 `SigS.appendStored`+          tone 0.015 `SigS.appendStored`+          tone 0.020++stateAppendTest2 :: SigSt.T Int16+stateAppendTest2 =+   SigSt.map int16FromDouble $+      let tone f =+             SigS.toStorableSignal defaultChunkSize $+             SigS.take 50000 $+             SigS.map (Wave.apply Wave.saw) $+             SigS.iterate (Phase.increment f) zeroPhase+      in  tone 0.010 `SigSt.append`+          tone 0.015 `SigSt.append`+          tone 0.020++stateConcatTest0 :: SigSt.T Int16+stateConcatTest0 =+   SigS.toStorableSignal defaultChunkSize $+   SigS.map int16FromDouble $+      let tone f =+             SigS.take 50000 $+             SigS.map (Wave.apply Wave.saw) $+             SigS.iterate (Phase.increment f) zeroPhase+      in  SigS.concat $+             tone 0.010 :+             tone 0.015 :+             tone 0.020 :+             []++stateConcatTest1 :: SigSt.T Int16+stateConcatTest1 =+   SigS.toStorableSignal defaultChunkSize $+   SigS.map int16FromDouble $+      let tone f =+             SigS.take 50000 $+             SigS.map (Wave.apply Wave.saw) $+             SigS.iterate (Phase.increment f) zeroPhase+      in  SigS.concatStored $+             tone 0.010 :+             tone 0.015 :+             tone 0.020 :+             []++{-# NOINLINE storablePercTone #-}+storablePercTone :: Double -> SigSt.T Double+storablePercTone f =+   SigS.toStorableSignal defaultChunkSize $+   SigS.take 22000 $+   FiltNRS.envelope (CtrlS.exponential2 10000 1) $+--   OsciS.static Wave.saw zero f+   SigS.map (0.5*) $+   SigS.mix+      (OsciS.static Wave.saw zeroPhase (f*0.999))+      (OsciS.static Wave.saw zeroPhase (f*1.001))++storableConcatTest :: SigSt.T Int16+storableConcatTest =+   SigSt.map int16FromDouble $+   SigSt.concat $+   take 13 $+   map storablePercTone $+   iterate (* 2^?(1/12)) 0.005++storableArrangeTest :: SigSt.T Int16+storableArrangeTest =+   SigSt.map int16FromDouble $+   SigSt.map (0.5*) $+   CutSt.arrange defaultChunkSize $+   foldr (EventList.cons 4000) (EventList.empty) $+--   foldr (EventList.cons 4000) (EventList.pause 0) $+   take 25 $+   map storablePercTone $+   iterate (* 2^?(1/12)) 0.005++-- This is much faster than Arrange.+-- about 2 seconds+storableConcatInfTest :: SigSt.T Int16+storableConcatInfTest =+   SigSt.map int16FromDouble $+   SigSt.map (0.5*) $+   SigSt.concat $+   take 110 $+   map storablePercTone $+   iterate (* 2^?(1/12)) 0.002++-- about 5-6 seconds+storableArrangeInfTest :: SigSt.T Int16+storableArrangeInfTest =+   SigSt.map int16FromDouble $+   SigSt.map (0.5*) $+   SigSt.take 440000 $+   CutSt.arrange defaultChunkSize $+   foldr (EventList.cons 4000) (EventList.empty) $+   map storablePercTone $+   iterate (* 2^?(1/12)) 0.002++++statePercTone :: Double -> SigS.T Double+statePercTone f =+   SigS.take 22000 $+   FiltNRS.envelope (CtrlS.exponential2 10000 1) $+--   OsciS.static Wave.saw zeroPhase f+   SigS.map (0.5*) $+   SigS.mix+      (OsciS.static Wave.saw zeroPhase (f*0.999))+      (OsciS.static Wave.saw zeroPhase (f*1.001))++stateArrangeInfTest :: SigSt.T Int16+stateArrangeInfTest =+   SigS.toStorableSignal defaultChunkSize $+   SigS.map int16FromDouble $+   SigS.map (0.5*) $+   SigS.take 440000 $+   CutS.arrange $+   foldr (EventList.cons 4000) (EventList.empty) $+   map statePercTone $+   iterate (* 2^?(1/12)) 0.002+++{-# INLINE fastSine2 #-}+fastSine2 :: (Ord a, Ring.C a, Num a) => a -> a+fastSine2 x =+   if 2*x<1+     then 1 - NP.sqr (4*x-1)+     else NP.sqr (4*x-3) - 1++fastSineTest :: SigSt.T Int16+fastSineTest =+   SigS.toStorableSignal defaultChunkSize $+   SigS.map int16FromDouble $+   SigS.take 440000 $+--   OsciS.static Wave.sine zeroPhase $+--   OsciS.static Wave.fastSine4 zeroPhase $+   OsciS.static Wave.fastSine2 zeroPhase $+--   OsciS.static fastSine2 zeroPhase $+   0.01+++{-# INLINE stateBubbles #-}+stateBubbles :: SigS.T Double+stateBubbles =+   OsciS.freqMod Wave.sine zeroPhase $+   SigS.map (\p -> 0.01 * exp(-p)) $+   SigS.mix+      (SigS.map (1.5*) $ OsciS.static Wave.saw zeroPhase 0.00001)+      (SigS.map (0.5*) $ OsciS.static Wave.saw zeroPhase 0.0002)++stateBubblesTest :: SigSt.T Int16+stateBubblesTest =+   SigS.toStorableSignal defaultChunkSize $+   SigS.map int16FromDouble $+   SigS.take 440000 $+   stateBubbles++storableCombTest :: SigSt.T Int16+storableCombTest =+   SigSt.map int16FromDouble $+   SigSt.delayLoopOverlap 11000 (SigSt.map (0.5*)) $+   SigS.toStorableSignal defaultChunkSize $+--   SigS.append (statePercTone 0.01) (SigS.replicate 40000 0)+   SigS.take 440000 $+   SigS.map (0.5*) $+   stateBubbles+++storableTakeTest :: SigSt.T Int16+storableTakeTest =+   SigSt.take 440000 $+   SigS.toStorableSignal defaultChunkSize $+   SigS.map int16FromDouble $+   OsciS.static Wave.saw zeroPhase 0.01+++stateNoiseTest :: SigSt.T Int16+stateNoiseTest =+   SigS.toStorableSignal defaultChunkSize $+   SigS.take 440000 $+   SigS.map int16FromDouble $+   SigS.map (0.3*) $+   SigS.map UniFilter.lowpass $+   SigS.modifyModulated+      UniFilter.modifier+      (SigS.map UniFilter.parameter $+       SigS.zipWith FiltR.Pole+          (SigS.repeat (10::Double))+          (SigS.map (\f -> 0.02*3 ^? f) $+           OsciS.static Wave.sine (Phase.fromRepresentative 0.75) 0.000005)) $+--   NoiseS.whiteGen (mkStdGen 1)+   NoiseS.whiteGen (Knuth.cons 1)+++stateADSRTest :: SigSt.T Int16+stateADSRTest =+   SigS.toStorableSignal defaultChunkSize $+   SigS.map int16FromDouble $+   FiltNRS.envelope+      (CtrlS.piecewise+          (0    |#  (5000, CtrlS.cubicPiece 0.001 0) #|-+           0.5 -|# (40000, CtrlS.stepPiece) #|-+           0.5 -|#  (8000, CtrlS.exponentialPiece 0) #|+           0.01)) $+   OsciS.static Wave.saw zeroPhase 0.01+++phaserTest :: SigSt.T Int16+phaserTest =+   SigSt.take 440000 $+   SigSt.map int16FromDouble $+   SigSt.map (0.5*) $+   (\noise ->+       SigSt.mix+          noise+          (DelayG.modulated InterpolationM.linear (-500)+             (SigS.toStorableSignal defaultChunkSize+                (SigS.map+                   (\x -> 100*(2+x) :: Double)+                   (OsciS.static Wave.sine zeroPhase 0.00001)))+             noise)) $+   SigS.toStorableSignal defaultChunkSize $+--   OsciS.static Wave.saw zeroPhase 0.01+   NoiseS.whiteGen (Knuth.cons 1)+++phaserTest0 :: SigSt.T Int16+phaserTest0 =+   SigSt.take 440000 $+   SigSt.map int16FromDouble $+   DelayG.modulated InterpolationM.constant (-500)+      (SigSt.repeat defaultChunkSize (142::Double)) $+   SigSt.repeat defaultChunkSize (23::Double)+++phaserTest1 :: SigSt.T Int16+phaserTest1 =+   SigSt.take 440000 $+   SigSt.map int16FromDouble $+--   SigG.mapTails (maybe 0 fst . SigSt.viewL . SigSt.drop 100) $+{-+   (\noise ->+       SigSt.mix+          (SigG.zipWithTails+             (\n -> maybe 0 fst . SigSt.viewL . SigSt.drop (div n 50))+             (SigG.iterate succ 0) noise)+          noise) $+-}+{-+   SigG.zipWithTails+      (\n -> maybe 0 fst . SigSt.viewL . SigSt.drop (div n 50))+      (SigG.iterate succ 0) $+-}+   (\noise -> SigSt.mix noise noise) $+   SigS.toStorableSignal defaultChunkSize $+   NoiseS.whiteGen (Knuth.cons 1)++++main :: IO ()+main =+   do SigSt.writeFile "storable-fusion.sw" phaserTest+      -- SigSt.writeFile "storable-fusion.sw" stateFilterTest+      -- SigSt.writeFile "storable-fusion.sw" osciTest4+      -- SigSt.writeFile "storable-fusion.sw" mapTest5+++{-+show highlighted core output++ghc-core -o dist/build/fusiontest/fusiontest -O -Wall -fexcess-precision -package synthesizer speedtest/FusionTest.hs++use installed synthesizer package++ghc -o dist/build/fusiontest/fusiontest -O -Wall -fexcess-precision -ddump-simpl-stats -package synthesizer speedtest/FusionTest.hs++ghc -o dist/build/fusiontest/fusiontest -O -Wall -fexcess-precision -ddump-simpl-stats -ddump-simpl -package synthesizer speedtest/FusionTest.hs >dist/build/fusiontest/FusionTest.log+++with make and no explicit package specification:++ghc -Idist/build -o dist/build/fusiontest/fusiontest --make -Wall -O2 -fexcess-precision -ddump-simpl-stats -i -idist/build/autogen -isrc -odir dist/build/fusiontest/fusiontest-tmp -hidir dist/build/fusiontest/fusiontest-tmp src/FusionTest.hs++with make and explicit package specification:++ghc -Idist/build -o dist/build/fusiontest/fusiontest --make -Wall -O2 -fexcess-precision -hide-all-packages -i -idist/build/autogen -isrc -odir dist/build/fusiontest/fusiontest-tmp -hidir dist/build/fusiontest/fusiontest-tmp -package base-1.0 -package mtl-1.0 -package non-negative-0.0.2 -package numeric-prelude-0.0.3 -package event-list-0.0.7 -package Haskore-0.0.2 -package HTam-0.0 -package numeric-quest-0.1 -package bytestring-0.9.0.5 -package binary-0.4.1 -package storablevector-0.1 -package UniqueLogicNP-0.0 -package QuickCheck-1.0 src/FusionTest.hs++without make and with detailed simplifier report:++ghc -Idist/build -o dist/build/fusiontest/fusiontest -Wall -O2 -fexcess-precision -ddump-simpl-stats -ddump-simpl-iterations -ddump-asm -i -idist/build/autogen -isrc -idist/build/fusiontest/fusiontest-tmp -odir dist/build/fusiontest/fusiontest-tmp -hidir dist/build/fusiontest/fusiontest-tmp -package base-1.0 -package mtl-1.0 -package non-negative-0.0.2 -package numeric-prelude-0.0.3 -package event-list-0.0.7 -package Haskore-0.0.2 -package HTam-0.0 -package numeric-quest-0.1 -package bytestring-0.9.0.5 -package binary-0.4.1 -package storablevector-0.1 -package UniqueLogicNP-0.0 -package QuickCheck-1.0 dist/build/HSsynthesizer*.o src/FusionTest.hs++ghc -Idist/build -o dist/build/fusiontest/fusiontest -Wall -O2 -fexcess-precision -ddump-simpl-stats -ddump-simpl-iterations -i -idist/build/autogen -isrc -idist/build/fusiontest/fusiontest-tmp -odir dist/build/fusiontest/fusiontest-tmp -hidir dist/build/fusiontest/fusiontest-tmp -package base-1.0 -package mtl-1.0 -package non-negative-0.0.2 -package numeric-prelude-0.0.3 -package event-list-0.0.7 -package Haskore-0.0.2 -package HTam-0.0 -package numeric-quest-0.1 -package bytestring-0.9.0.5 -package binary-0.4.1 -package storablevector-0.1 -package UniqueLogicNP-0.0 -package QuickCheck-1.0 dist/build/HSsynthesizer*.o src/FusionTest.hs >src/FusionTest.log++ghc-6.8.2 -Idist/build -o dist/build/fusiontest/fusiontest -Wall -O2 -fexcess-precision -ddump-simpl-stats -ddump-simpl-iterations -i -idist/build/autogen -isrc -idist/build/fusiontest/fusiontest-tmp -odir dist/build/fusiontest/fusiontest-tmp -hidir dist/build/fusiontest/fusiontest-tmp -package base -package mtl -package non-negative -package numeric-prelude -package event-list -package Haskore -package HTam -package numeric-quest -package bytestring -package binary -package storablevector -package UniqueLogicNP -package QuickCheck dist/build/HSsynthesizer*.o src/FusionTest.hs >src/FusionTest.log+-}
+ speedtest/SpeedTest.hs view
@@ -0,0 +1,318 @@+{-# OPTIONS -fno-implicit-prelude #-}+module Main (main) where++-- import BinarySample (numToInt16)++import System.Time (getClockTime, diffClockTimes, tdSec, tdPicosec)+import System.Directory (removeFile)++-- the strict ByteString variant is not faster here+import qualified Data.ByteString.Lazy as B+import qualified Data.Binary.Put as Bin++import Foreign (Int16, Ptr, alloca, allocaBytes, poke, pokeElemOff, sizeOf)+import System.IO (openBinaryFile, IOMode(WriteMode), hClose, Handle, hPutBuf)+import Control.Exception (bracket)++import qualified Algebra.Transcendental as Trans+import qualified Algebra.RealField      as RealField++import GHC.Float (double2Int)++import Data.Word (Word8)++import Control.Monad (when, foldM, zipWithM_, )+import Data.List (unfoldr)+import Data.Maybe.HT (toMaybe, )+import Data.List.HT (sliceVertical, )++import PreludeBase+import NumericPrelude++import qualified Prelude as P98++{-+  ghc -prof -auto-all -O -fvia-C SpeedTest.hs+  a.out +RTS -p -RTS+-}+++{-# SPECIALIZE osciModSaw :: Double -> [Double] -> [Double] #-}+{-# SPECIALIZE freqToPhase :: Double -> [Double] -> [Double] #-}+{-# SPECIALIZE exponential2 :: Double -> Double -> [Double] #-}+{-# SPECIALIZE clip :: Double -> Double -> Double -> Double #-}+{-# SPECIALIZE numToInt :: Double -> Int #-}+{-# SPECIALIZE numToInt16 :: Double -> Int16 #-}++{- INLINE zeroSignal #-}+{- INLINE sawSignal #-}+{- INLINE zeroSignal16 #-}+{- INLINE sawSignal16 #-}+++{- |+saw tooth oscillator with modulated frequency+-}+osciModSaw :: RealField.C a => a -> [a] -> [a]+osciModSaw phase freq = map (\x -> 2*x-1) (freqToPhase phase freq)++{- |+Convert a list of phase steps into a list of momentum phases+phase is a number in the interval [0,1)+freq contains the phase steps+-}+freqToPhase :: RealField.C a => a -> [a] -> [a]+freqToPhase phase freq =+   scanl (\curphase dif -> fraction (curphase+dif)) phase freq++exponential2 :: Trans.C a => a -> a -> [a]+exponential2 halfLife y0 =+   let k = 0.5**(1/halfLife)+   in  iterate (k*) y0++++-- write the signal as binary file containing 16 bit words+writeSignalMono, writeSignalMonoS ::+   FilePath -> [Int16] -> IO ()+writeSignalMono fileName signal =+   writeFile fileName (signalToBinaryMono signal)+writeSignalMonoS fileName signal =+   writeFile fileName (signalToBinaryMonoS signal)++signalToBinaryMono, signalToBinaryMonoS ::+   [Int16] -> String+signalToBinaryMono  = concatMap (int16ToChars . P98.fromIntegral)+signalToBinaryMonoS = foldr int16ToCharsS [] . map P98.fromIntegral++writeSignalMonoInt ::+   FilePath -> [Int] -> IO ()+writeSignalMonoInt fileName signal =+   writeFile fileName (signalToBinaryMonoInt signal)++signalToBinaryMonoInt :: [Int] -> String+signalToBinaryMonoInt = concatMap int16ToChars+++writeSignalMonoBStr :: FilePath -> [Int16] -> IO ()+writeSignalMonoBStr fileName =+   B.writeFile fileName . signalToBinaryMonoBStr++signalToBinaryMonoBStr :: [Int16] -> B.ByteString+signalToBinaryMonoBStr =+   B.pack . concatMap (int16ToBytes . P98.fromIntegral)+++writeSignalMonoBinaryPut ::+   FilePath -> [Int16] -> IO ()+writeSignalMonoBinaryPut fileName =+   B.writeFile fileName . signalToBinaryBinaryPut++signalToBinaryBinaryPut :: [Int16] -> B.ByteString+signalToBinaryBinaryPut =+   Bin.runPut . mapM_ (Bin.putWord16host . P98.fromIntegral)+++writeSignalMonoBinaryIntPut ::+   FilePath -> [Int] -> IO ()+writeSignalMonoBinaryIntPut fileName =+   B.writeFile fileName . signalToBinaryBinaryIntPut++signalToBinaryBinaryIntPut :: [Int] -> B.ByteString+signalToBinaryBinaryIntPut =+   Bin.runPut . mapM_ (Bin.putWord16host . P98.fromIntegral)++++-- from BinarySample+clip :: Ord a => a -> a -> a -> a+clip lower upper = max lower . min upper++numToInt :: (RealField.C a) => a -> Int+numToInt x = round (32767 * clip (-1) 1 x)++-- from BinarySample+-- return type could be Int16, but that is not well supported by NumericPrelude+numToInt16 :: (RealField.C a) => a -> Int16+numToInt16 = P98.fromIntegral . numToInt++roundDouble :: Double -> Int+roundDouble x =+   double2Int (if x<0 then x-0.5 else x+0.5)++doubleToInt :: Double -> Int+doubleToInt x = roundDouble (32767 * clip (-1) 1 x)++doubleToInt16 :: Double -> Int16+doubleToInt16 = P98.fromIntegral . doubleToInt+++++int16ToChars :: Int -> String+int16ToChars x =+   let (hi,lo) = divMod x 256+   in  [toEnum lo, toEnum (mod hi 256)]++int16ToCharsS :: Int -> String -> String+int16ToCharsS x s =+   let (hi,lo) = divMod x 256+   in  toEnum lo : toEnum (mod hi 256) : s++int16ToBytes :: Int -> [Word8]+int16ToBytes x =+   let (hi,lo) = divMod x 256+--    in  [P98.fromIntegral lo, P98.fromIntegral (mod hi 256)]+   in  [P98.fromIntegral lo, P98.fromIntegral hi]+        -- conversion to Word8 wraps silently to positive values+++{- * machine oriented techniques -}++writeSignalMonoPoke ::+   FilePath -> [Int16] -> IO ()+writeSignalMonoPoke fileName signal =+   bracket (openBinaryFile fileName WriteMode) hClose $+      \h -> alloca $+         \p -> mapM_ (putInt h p) signal++putInt :: Handle -> Ptr Int16 -> Int16 -> IO ()+putInt h p n =+   poke p n >> hPutBuf h p (sizeOf n)+++maxBlockSize :: Int+maxBlockSize = 1000++int16size :: Int+int16size = sizeOf (undefined::Int16)++writeSignalMonoBlock ::+   FilePath -> [Int16] -> IO ()+writeSignalMonoBlock fileName signal =+   bracket (openBinaryFile fileName WriteMode) hClose $+      \h -> let blocks = sliceVertical maxBlockSize signal+            in  allocaBytes (int16size * maxBlockSize) $+                   \p -> mapM_ (putIntBlock h p) blocks++putIntBlock :: Handle -> Ptr Int16 -> [Int16] -> IO ()+putIntBlock h p xs =+   do cnt <- foldM (\n x -> pokeElemOff p n x >> return (n+1)) 0 xs+      hPutBuf h p (int16size * cnt)++putIntBlockSlow :: Handle -> Ptr Int16 -> [Int16] -> IO ()+putIntBlockSlow h p xs =+   do zipWithM_ (pokeElemOff p) [0..] xs+      hPutBuf h p (int16size * length xs)+++chopLength :: Int {- ^ block size -} -> Int {- ^ length -} -> [Int]+chopLength blockSize =+   unfoldr (\l -> let chunkSize = min blockSize l+                  in  toMaybe (l>0) (chunkSize, l-chunkSize))++writeZeroBlocks ::+   FilePath -> Int -> IO ()+writeZeroBlocks fileName len =+   bracket (openBinaryFile fileName WriteMode) hClose $+      \h -> allocaBytes (int16size * maxBlockSize) $+         \p ->+             do mapM_ (\off -> pokeElemOff p off (P98.fromInteger 0 :: Int16))+                      [0 .. maxBlockSize-1]+                mapM_ (hPutBuf h p)+                      (map (int16size*) (chopLength maxBlockSize len))+++{- * driver -}++measureTime :: String -> IO () -> IO ()+measureTime name act =+   do putStr (name++": ")+      timeA <- getClockTime+      act+      timeB <- getClockTime+      let td = diffClockTimes timeB timeA+      print (fromIntegral (tdSec td) ++             fromInteger (tdPicosec td) * 1e-12 :: Double)++numSamples :: Int+numSamples = 200000++zeroSignal, sawSignal :: [Double]+zeroSignal = replicate numSamples 0+sawSignal  = take numSamples (osciModSaw 0 (exponential2 100000 0.1))++polysawSignal :: [Double]+polysawSignal =+   take numSamples+      (osciModSaw 0 (exponential2 100000 0.1) ++       osciModSaw 0 (exponential2 100000 0.1001))++zeroSignal16, sawSignal16 :: [Int16]+zeroSignal16 = map numToInt16 zeroSignal+sawSignal16  = map numToInt16 sawSignal++sawSignal16NonShared :: Double -> [Int16]+sawSignal16NonShared halfLife =+   map numToInt16+       (take numSamples (osciModSaw 0 (exponential2 halfLife 0.1) :: [Double]))++sawSignalIntNonShared :: Double -> [Int]+sawSignalIntNonShared halfLife =+   map doubleToInt+       (take numSamples (osciModSaw 0 (exponential2 halfLife 0.1) :: [Double]))++zeroStream, zeroStreamPaired :: String+zeroStream       = replicate (2*numSamples) '\000'+zeroStreamPaired = concat $ replicate numSamples "\001\000"++sawStream :: String+sawStream = take (2*numSamples) (cycle ['\000'..'\177'])++zeroByteString :: B.ByteString+zeroByteString =+   B.replicate (P98.fromIntegral (2 * numSamples))+      (P98.fromIntegral (0::Int))++zeroByteStringPaired :: B.ByteString+zeroByteStringPaired =+   B.concat $ replicate numSamples $+      B.pack [P98.fromIntegral (0::Int), P98.fromIntegral (1::Int)]+++tests :: [(String, FilePath, FilePath -> IO ())]+tests =+   ("zero bytestring",        "zerobytestring.sw", flip B.writeFile zeroByteString) :+   ("zero bytestring words",  "zerobytestrnwd.sw", flip B.writeFile zeroByteStringPaired) :+   ("zero blocks",            "zerofastblocks.sw", flip writeZeroBlocks numSamples) :+   ("zero bytes",             "zerofast.sw",       flip writeFile zeroStream) :+   ("zero words",             "zerowords.sw",      flip writeFile zeroStreamPaired) :+   ("saw bytes",              "sawbytes.sw",       flip writeFile sawStream) :+   -- only the first test is reliable, because the subsequent test can access the already computed data+   ("zero signal binary put", "zerowordbinary.sw", flip writeSignalMonoBinaryPut zeroSignal16) :+   ("zero signal bytestring", "zerowordstring.sw", flip writeSignalMonoBStr  zeroSignal16) :+   ("zero signal block-wise", "zeroblock.sw",      flip writeSignalMonoBlock zeroSignal16) :+   ("zero signal poke",       "zeropoke.sw",       flip writeSignalMonoPoke  zeroSignal16) :+   ("zero signal foldr",      "zerofoldr.sw",      flip writeSignalMonoS     zeroSignal16) :+   ("zero signal",            "zero.sw",           flip writeSignalMono      zeroSignal16) :+   ("saw binary int lib",     "sawbinaryint.sw",   flip writeSignalMonoBinaryIntPut $ sawSignalIntNonShared 100004) :+   ("saw int",                "sawint.sw",         flip writeSignalMonoInt $ sawSignalIntNonShared 100005) :+   -- the same problem as with zeros+   ("saw bytestring",         "sawbytestring.sw",  flip writeSignalMono      sawSignal16) :+   ("saw",                    "saw.sw",            flip writeSignalMono      sawSignal16) :+   ("saw bytestring non-shd", "sawbytestrngns.sw", flip writeSignalMono      $ sawSignal16NonShared 100001) :+   ("saw non-shared",         "sawns.sw",          flip writeSignalMono      $ sawSignal16NonShared 100002) :+   ("saw binary lib",         "sawbinary.sw",      flip writeSignalMonoBinaryPut $ sawSignal16NonShared 100003) :+   ("poly-saw binary lib",    "polysawbinary.sw",  flip writeSignalMonoBinaryPut $ map numToInt16 polysawSignal) :+   []+++main :: IO ()+main =+   do mapM (\(label, fileName, action) ->+              measureTime label (action fileName))+           tests++      when False $+         mapM_ (\(_,fileName,_) -> removeFile fileName)+           tests
+ speedtest/SpeedTestExp.hs view
@@ -0,0 +1,160 @@+module Main (main) where++import System.Time (getClockTime, diffClockTimes, tdSec, tdPicosec)++import qualified Data.StorableVector as V+import qualified Data.StorableVector.Base as VB+import Foreign.ForeignPtr (withForeignPtr)++import qualified Data.ByteString.Lazy as B+import qualified Data.Binary.Put as Bin++import Data.Array.IO (IOUArray, newArray_, castIOUArray, hPutArray, writeArray)++import Data.Word(Word8)++import System.IO (openBinaryFile, hClose, hPutBuf, IOMode(WriteMode))+import Foreign (Int16, pokeElemOff, allocaBytes)+import Control.Exception (bracket)+import Control.Monad (zipWithM_)++import GHC.Float (double2Int)++++{- INLINE exponential2  - makes things even worse -}++{- INLINE writeSignal -}++signalToBinaryPut :: [Int16] -> B.ByteString+signalToBinaryPut =+   Bin.runPut . mapM_ (Bin.putWord16host . fromIntegral)++writeSignalBinaryPut ::+   FilePath -> [Int16] -> IO ()+writeSignalBinaryPut fileName =+   B.writeFile fileName . signalToBinaryPut+++round' :: Double -> Int16+round' x =+   fromIntegral (double2Int+     (if x<0 then x-0.5 else x+0.5))++doubleToInt16 :: Double -> Int16+doubleToInt16 x = round (32767 * x)++doubleToInt16' :: Double -> Int16+doubleToInt16' x = round' (32767 * x)++doubleToInt16'' :: Double -> Int16+doubleToInt16'' x = seq x 0+++exponential2 :: Double -> Double -> [Double]+exponential2 hl y0 =+   let k = 0.5 ** recip hl+   in  iterate (k*) y0+++writeSignal :: FilePath -> Int -> [Double] -> IO ()+writeSignal name num signal =+   bracket (openBinaryFile name WriteMode) hClose $ \h ->+   allocaBytes (2*num) $ \buf ->+      zipWithM_+         (pokeElemOff buf) [0..(num-1)]+         (map doubleToInt16' signal) >>+      hPutBuf h buf (2*num)++writeExponentialList :: FilePath -> Int -> Double -> Double -> IO ()+writeExponentialList name num hl y0 =+   bracket (openBinaryFile name WriteMode) hClose $ \h ->+   allocaBytes (2*num) $ \buf ->+      zipWithM_+         (pokeElemOff buf) [0..(num-1)]+         (map doubleToInt16' (let k = 0.5 ** recip hl+                              in  iterate (k*) y0)) >>+      hPutBuf h buf (2*num)++writeExponential :: FilePath -> Int -> Double -> Double -> IO ()+writeExponential name num hl y0 =+   bracket (openBinaryFile name WriteMode) hClose $ \h ->+   allocaBytes (2*num) $ \buf ->+{-+      let k = 0.5**(1/hl)+          loop :: Int -> Int -> IO ()+          loop i y =+             if i<num+               then pokeElemOff buf i (fromIntegral y :: Int16) >>+                    loop (succ i) (y+1)+               else return ()+      in  loop 0 (-10) >>+          hPutBuf h buf (2*num)+-}+      let k = 0.5**(1/hl)+          loop i y =+             if i<num+               then pokeElemOff buf i (doubleToInt16' y) >>+                    loop (succ i) (y*k)+               else return ()+      in  loop 0 y0 >>+          hPutBuf h buf (2*num)++writeExponentialIOUArray :: FilePath -> Int -> Double -> Double -> IO ()+writeExponentialIOUArray name num hl y0 =+   bracket (openBinaryFile name WriteMode) hClose $ \h ->+   newArray_ (0,2*num-1) >>= \arr ->+      let k = 0.5**(1/hl)+          loop i y =+             if i<num+               then writeArray (arr :: IOUArray Int Int16)+                       i (doubleToInt16' y) >>+                    loop (succ i) (y*k)+               else return ()+      in  loop 0 y0 >>+          castIOUArray arr >>= \word8arr ->+          hPutArray h (word8arr :: IOUArray Int Word8) (2*num)++writeExponentialStorableVector :: FilePath -> Int -> Double -> Double -> IO ()+writeExponentialStorableVector name num hl y0 =+   bracket (openBinaryFile name WriteMode) hClose $ \h ->+      let k = 0.5**(1/hl)+          (fp, _offset, _size) =+             VB.toForeignPtr $ fst $+             V.unfoldrN num (\y -> Just (doubleToInt16' y, y*k)) y0+      in  withForeignPtr fp $ \ buf -> hPutBuf h buf (2*num)++++measureTime :: String -> IO () -> IO ()+measureTime name act =+   do putStr (name++": ")+      timeA <- getClockTime+      act+      timeB <- getClockTime+      let td = diffClockTimes timeB timeA+      print (fromIntegral (tdSec td) ++             fromInteger (tdPicosec td) * 1e-12 :: Double)++numSamples :: Int+numSamples = 1000000++halfLife :: Double+halfLife = 100000+++main :: IO ()+main =+   do measureTime "poke exponential int16"+         (writeExponential "exp-poked.sw" numSamples halfLife 1)+      measureTime "IOUArray exponential int16"+         (writeExponentialIOUArray "exp-iouarray.sw" numSamples halfLife 1)+      measureTime "StorableVector exponential int16"+         (writeExponentialStorableVector "exp-storablevector.sw" numSamples halfLife 1)+      measureTime "put exponential int16"+         (writeSignalBinaryPut "exp-int16string.sw"+            (take numSamples (map doubleToInt16' (exponential2 halfLife 1))))+      measureTime "poke exponential list of int16"+         (writeSignal "exp-list-poked.sw" numSamples (exponential2 halfLife 1))+      measureTime "poke exponential internal list of int16"+         (writeExponentialList "exp-intern-poked.sw" numSamples halfLife 1)
+ speedtest/SpeedTestSimple.hs view
@@ -0,0 +1,45 @@+module Main (main) where++import System.Time (getClockTime, diffClockTimes, tdSec, tdPicosec)++import qualified Data.ByteString.Lazy as B+import qualified Data.Binary.Put as Bin++import Foreign (Int16)+++signalToBinaryPut :: [Int16] -> B.ByteString+signalToBinaryPut =+   Bin.runPut . mapM_ (Bin.putWord16host . fromIntegral)++writeSignalBinaryPut ::+   FilePath -> [Int16] -> IO ()+writeSignalBinaryPut fileName =+   B.writeFile fileName . signalToBinaryPut+++measureTime :: String -> IO () -> IO ()+measureTime name act =+   do putStr (name++": ")+      timeA <- getClockTime+      act+      timeB <- getClockTime+      let td = diffClockTimes timeB timeA+      print (fromIntegral (tdSec td) ++             fromInteger (tdPicosec td) * 1e-12 :: Double)++numSamples :: Int+numSamples = 1000000++zeroSignal16 :: [Int16]+zeroSignal16 = replicate numSamples 0++zeroByteString :: B.ByteString+zeroByteString = B.replicate (fromIntegral (2 * numSamples)) 0++main :: IO ()+main =+   do measureTime "write zero bytestring"+         (B.writeFile "zero-bytestring.sw" zeroByteString)+      measureTime "put zero int16"+         (writeSignalBinaryPut "zero-int16string.sw" zeroSignal16)
+ src-3/Synthesizer/Causal/Process.hs view
@@ -0,0 +1,393 @@+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ExistentialQuantification #-}+{- |+Processes that use only the current and past data.+Essentially this is a data type for the 'Synthesizer.State.Signal.crochetL' function.+-}+{-+ToDo:+Causal process usually depend on the sample rate,+so we need a phantom type parameter of T for the rate.++Include ST monad for mutable arrays,+this can be useful for delay lines.+On the other hand, couldn't we also use the StorableVector.Cursor data structure+and avoid the ST monad here?+-}+module Synthesizer.Causal.Process (+   T,+   fromStateMaybe,+   fromState,+   fromSimpleModifier,++   id,+   map,+   first,+   second,+   compose,+   split,+   fanout,+   loop,++{-+   We don't re-export these identifiers+   because people could abuse them for other Arrows.++   (>>>), (***), (&&&),+   (Arrow.^<<), (Arrow.^>>), (Arrow.<<^), (Arrow.>>^),+-}++   apply,+   applyFst,+   applySnd,+   applyGeneric,+   applyGenericSameType,+   applyConst,+   apply2,+   apply3,++   feed,+   feedFst,+   feedSnd,+   feedGenericFst,+   feedGenericSnd,+   feedConstFst,+   feedConstSnd,++   crochetL,+   scanL,+   scanL1,+   zipWith,+   consInit,+   chainControlled,+   replicateControlled,+   feedback,+   feedbackControlled,++   -- for testing+   applyFst',+   applySnd',+) where++import qualified Synthesizer.State.Signal as Sig+import qualified Synthesizer.Generic.Signal as SigG+import qualified Synthesizer.Generic.Signal2 as SigG2++import qualified Synthesizer.Plain.Modifier as Modifier++-- import qualified Control.Arrow as Arrow++import Control.Arrow+          (Arrow(..), returnA, (<<<), (^>>), {- ArrowApply(..), -} ArrowLoop(..),+           Kleisli(Kleisli), runKleisli, )+import Control.Monad.Trans.State+          (State, state, runState,+           StateT(StateT), runStateT, )+import Control.Monad (liftM, )++import Data.Tuple.HT (mapSnd, )+import Data.Function.HT (nest, )+import Prelude hiding (id, map, zipWith, )++++-- | Cf. StreamFusion  'Synthesizer.State.Signal.T'+data T a b =+   forall s. -- Seq s =>+      Cons !(a -> StateT s Maybe b)  -- compute next value+           !s                        -- initial state++++{-# INLINE fromStateMaybe #-}+fromStateMaybe :: (a -> StateT s Maybe b) -> s -> T a b+fromStateMaybe = Cons++{-# INLINE fromState #-}+fromState :: (a -> State s b) -> s -> T a b+fromState f =+   fromStateMaybe (\x -> StateT (Just . runState (f x)))++{-# INLINE fromSimpleModifier #-}+fromSimpleModifier ::+   Modifier.Simple s ctrl a b -> T (ctrl,a) b+fromSimpleModifier (Modifier.Simple s f) =+   fromState (uncurry f) s+++{-+It's almost a Kleisli Arrow,+but the hidden type of the state disturbs.+-}+instance Arrow T where+   {-# INLINE pure #-}+   {-# INLINE (>>>) #-}+   {-# INLINE first #-}+   {-# INLINE second #-}+   {-# INLINE (***) #-}+   {-# INLINE (&&&) #-}++   pure   = map+   (>>>)  = compose+   first  = liftKleisli first+   second = liftKleisli second+   (***)  = split+   (&&&)  = fanout+++{-+I think we cannot define an ArrowApply instance,+because we must extract the initial state somehow+from the inner (T a b) which is not possible.++instance ArrowApply T where+--   app = Cons (runKleisli undefined) ()+   app = first (arr (flip Cons () . runKleisli)) >>> app+-}+++instance ArrowLoop T where+   {-# INLINE loop #-}+   loop = liftKleisli loop+++{-# INLINE extendStateFstT #-}+extendStateFstT :: Monad m => StateT s m a -> StateT (t,s) m a+extendStateFstT st =+   StateT (\(t0,s0) -> liftM (mapSnd (\s1 -> (t0,s1))) (runStateT st s0))++{-# INLINE extendStateSndT #-}+extendStateSndT :: Monad m => StateT s m a -> StateT (s,t) m a+extendStateSndT st =+   StateT (\(s0,t0) -> liftM (mapSnd (\s1 -> (s1,t0))) (runStateT st s0))+++{-# INLINE liftKleisli #-}+liftKleisli ::+   (forall s.+    Kleisli (StateT s Maybe) a0 a1 ->+    Kleisli (StateT s Maybe) b0 b1) ->+   T a0 a1 -> T b0 b1+liftKleisli op (Cons f s) =+   Cons (runKleisli $ op $ Kleisli f) s++{-# INLINE liftKleisli2 #-}+liftKleisli2 ::+   (forall s.+      Kleisli (StateT s Maybe) a0 a1 ->+      Kleisli (StateT s Maybe) b0 b1 ->+      Kleisli (StateT s Maybe) c0 c1) ->+   T a0 a1 -> T b0 b1 -> T c0 c1+liftKleisli2 op (Cons f s) (Cons g t) =+   Cons+      (runKleisli+         (Kleisli (extendStateSndT . f) `op`+          Kleisli (extendStateFstT . g)))+      (s,t)+++{-# INLINE id #-}+id :: T a a+id = returnA++{-# INLINE map #-}+map :: (a -> b) -> T a b+map f = fromState (return . f) ()++{-# INLINE compose #-}+compose :: T a b -> T b c -> T a c+compose = liftKleisli2 (>>>)++{-# INLINE split #-}+split :: T a b -> T c d -> T (a,c) (b,d)+split = liftKleisli2 (***)++{-# INLINE fanout #-}+fanout :: T a b -> T a c -> T a (b,c)+fanout = liftKleisli2 (&&&)+++{-# INLINE getNext #-}+getNext :: StateT (Sig.T a) Maybe a+getNext = StateT Sig.viewL++{-# INLINE apply #-}+apply :: T a b -> Sig.T a -> Sig.T b+apply (Cons f s) =+   Sig.crochetL (runStateT . f) s++{- |+I think this function does too much.+Better use 'feedFst' and (>>>).+-}+{-# INLINE applyFst #-}+applyFst, applyFst' :: T (a,b) c -> Sig.T a -> T b c+applyFst c as =+   c <<< feedFst as++applyFst' (Cons f s) as =+   Cons (\b ->+           do a <- extendStateFstT getNext+              extendStateSndT (f (a,b)))+        (s,as)++{- |+I think this function does too much.+Better use 'feedSnd' and (>>>).+-}+{-# INLINE applySnd #-}+applySnd, applySnd' :: T (a,b) c -> Sig.T b -> T a c+applySnd c as =+   c <<< feedSnd as++applySnd' (Cons f s) bs =+   Cons (\a ->+           do b <- extendStateFstT getNext+              extendStateSndT (f (a,b)))+        (s,bs)++{-# INLINE applyGeneric #-}+applyGeneric :: (SigG2.Transform sig a b) =>+   T a b -> sig a -> sig b+applyGeneric (Cons f s) =+   SigG2.crochetL (runStateT . f) s++{-# INLINE applyGenericSameType #-}+applyGenericSameType :: (SigG.Transform sig a) =>+   T a a -> sig a -> sig a+applyGenericSameType (Cons f s) =+   SigG.crochetL (runStateT . f) s+++{- |+applyConst c x == apply c (repeat x)+-}+{-# INLINE applyConst #-}+applyConst :: T a b -> a -> Sig.T b+applyConst (Cons f s) a =+   Sig.unfoldR (runStateT (f a)) s++{-+Can be easily done by converting the result of applyConst to generic signal+{-# INLINE applyConstGeneric #-}+applyConstGeneric :: SigG.LazySize -> T a b -> a -> sig b+applyConstGeneric size (Cons f s) a =+   SigG.unfoldR size (runStateT (f a)) s+-}+++{-# INLINE apply2 #-}+apply2 :: T (a,b) c -> Sig.T a -> Sig.T b -> Sig.T c+apply2 f x y =+   apply (applyFst f x) y++{-# INLINE apply3 #-}+apply3 :: T (a,b,c) d -> Sig.T a -> Sig.T b -> Sig.T c -> Sig.T d+apply3 f x y z =+   apply2 (applyFst ((\(a,(b,c)) -> (a,b,c)) ^>> f) x) y z+++{-# INLINE feed #-}+feed :: Sig.T a -> T () a+feed = fromStateMaybe (const getNext)++{-# INLINE feedFst #-}+feedFst :: Sig.T a -> T b (a,b)+feedFst = fromStateMaybe (\b -> fmap (flip (,) b) getNext)++{-# INLINE feedSnd #-}+feedSnd :: Sig.T a -> T b (b,a)+feedSnd = fromStateMaybe (\b -> fmap ((,) b) getNext)++{-# INLINE feedConstFst #-}+feedConstFst :: a -> T b (a,b)+feedConstFst a = map (\b -> (a,b))++{-# INLINE feedConstSnd #-}+feedConstSnd :: a -> T b (b,a)+feedConstSnd a = map (\b -> (b,a))++{-# INLINE feedGenericFst #-}+feedGenericFst :: (SigG.Read sig a) =>+   sig a -> T b (a,b)+feedGenericFst =+   feedFst . SigG.toState++{-# INLINE feedGenericSnd #-}+feedGenericSnd :: (SigG.Read sig a) =>+   sig a -> T b (b,a)+feedGenericSnd =+   feedSnd . SigG.toState++++-- * list like functions++{-# INLINE crochetL #-}+crochetL :: (x -> acc -> Maybe (y, acc)) -> acc -> T x y+crochetL f s = fromStateMaybe (StateT . f) s++{-# INLINE scanL #-}+scanL :: (acc -> x -> acc) -> acc -> T x acc+scanL f start =+   fromState (\x -> state $ \acc -> (acc, f acc x)) start++{-# INLINE scanL1 #-}+scanL1 :: (x -> x -> x) -> T x x+scanL1 f =+   crochetL (\x acc -> Just (x, Just $ maybe x (flip f x) acc)) Nothing++{-# INLINE zipWith #-}+zipWith :: (a -> b -> c) -> Sig.T a -> T b c+zipWith f = applyFst (map (uncurry f))++{- |+Prepend an element to a signal,+but keep the signal length,+i.e. drop the last element.+-}+{-# INLINE consInit #-}+consInit :: x -> T x x+consInit =+   crochetL (\x acc -> Just (acc, x))++++{-# INLINE chainControlled #-}+chainControlled :: [T (c,x) x] -> T (c,x) x+chainControlled =+   foldr+      (\p rest -> map fst &&& p  >>>  rest)+      (map snd)++{- |+If @T@ would be the function type @->@+then @replicateControlled 3 f@ computes+@\(c,x) -> f(c, f(c, f(c, x)))@.+-}+{-# INLINE replicateControlled #-}+replicateControlled :: Int -> T (c,x) x -> T (c,x) x+replicateControlled n p =+   nest n+      (map fst &&& p  >>> )+      (map snd)+++{-# INLINE feedback #-}+feedback :: T (a,c) b -> T b c -> T a b+feedback forth back =+   loop (forth >>>  id &&& back)++{-# INLINE feedbackControlled #-}+feedbackControlled :: T ((ctrl,a),c) b -> T (ctrl,b) c -> T (ctrl,a) b+feedbackControlled forth back =+   loop (map (fst.fst) &&& forth  >>>  map snd &&& back)++{-+{-# INLINE feedbackControlled #-}+feedbackControlled :: T (ctrl, (a,c)) b -> T (ctrl,b) c -> T (ctrl,a) b+feedbackControlled forth back =+   loop ((\((ctrl,a),c) -> (ctrl, (a,c)))  ^>>+         map fst &&& forth  >>>+         map snd &&& back)+-}
+ src-4/Synthesizer/Causal/Process.hs view
@@ -0,0 +1,398 @@+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ExistentialQuantification #-}+{- |+Processes that use only the current and past data.+Essentially this is a data type for the 'Synthesizer.State.Signal.crochetL' function.+-}+{-+ToDo:+Causal process usually depend on the sample rate,+so we need a phantom type parameter of T for the rate.++Include ST monad for mutable arrays,+this can be useful for delay lines.+On the other hand, couldn't we also use the StorableVector.Cursor data structure+and avoid the ST monad here?+-}+module Synthesizer.Causal.Process (+   T,+   fromStateMaybe,+   fromState,+   fromSimpleModifier,++   id,+   map,+   first,+   second,+   compose,+   split,+   fanout,+   loop,++{-+   We don't re-export these identifiers+   because people could abuse them for other Arrows.++   (>>>), (***), (&&&),+   (Arrow.^<<), (Arrow.^>>), (Arrow.<<^), (Arrow.>>^),+-}++   apply,+   applyFst,+   applySnd,+   applyGeneric,+   applyGenericSameType,+   applyConst,+   apply2,+   apply3,++   feed,+   feedFst,+   feedSnd,+   feedGenericFst,+   feedGenericSnd,+   feedConstFst,+   feedConstSnd,++   crochetL,+   scanL,+   scanL1,+   zipWith,+   consInit,+   chainControlled,+   replicateControlled,+   feedback,+   feedbackControlled,++   -- for testing+   applyFst',+   applySnd',+) where++import qualified Synthesizer.State.Signal as Sig+import qualified Synthesizer.Generic.Signal as SigG+import qualified Synthesizer.Generic.Signal2 as SigG2++import qualified Synthesizer.Plain.Modifier as Modifier++-- import qualified Control.Arrow as Arrow++import qualified Control.Category as Cat+import Control.Arrow+          (Arrow(..), returnA, (<<<), (>>>), (^>>), {- ArrowApply(..), -} ArrowLoop(..),+           Kleisli(Kleisli), runKleisli, )+import Control.Monad.Trans.State+          (State, state, runState,+           StateT(StateT), runStateT, )+import Control.Monad (liftM, )++import Data.Tuple.HT (mapSnd, )+import Data.Function.HT (nest, )+import Prelude hiding (id, map, zipWith, )++++-- | Cf. StreamFusion  'Synthesizer.State.Signal.T'+data T a b =+   forall s. -- Seq s =>+      Cons !(a -> StateT s Maybe b)  -- compute next value+           !s                        -- initial state++++{-# INLINE fromStateMaybe #-}+fromStateMaybe :: (a -> StateT s Maybe b) -> s -> T a b+fromStateMaybe = Cons++{-# INLINE fromState #-}+fromState :: (a -> State s b) -> s -> T a b+fromState f =+   fromStateMaybe (\x -> StateT (Just . runState (f x)))++{-# INLINE fromSimpleModifier #-}+fromSimpleModifier ::+   Modifier.Simple s ctrl a b -> T (ctrl,a) b+fromSimpleModifier (Modifier.Simple s f) =+   fromState (uncurry f) s+++{-+It's almost a Kleisli Arrow,+but the hidden type of the state disturbs.+-}+instance Cat.Category T where+   {-# INLINE id #-}+   {-# INLINE (.) #-}++   id  = fromState return ()+   (.) = flip compose++instance Arrow T where+   {-# INLINE arr #-}+   {-# INLINE first #-}+   {-# INLINE second #-}+   {-# INLINE (***) #-}+   {-# INLINE (&&&) #-}++   arr    = map+   first  = liftKleisli first+   second = liftKleisli second+   (***)  = split+   (&&&)  = fanout++{-+I think we cannot define an ArrowApply instance,+because we must extract the initial state somehow+from the inner (T a b) which is not possible.++instance ArrowApply T where+--   app = Cons (runKleisli undefined) ()+   app = first (arr (flip Cons () . runKleisli)) >>> app+-}+++instance ArrowLoop T where+   {-# INLINE loop #-}+   loop = liftKleisli loop+++{-# INLINE extendStateFstT #-}+extendStateFstT :: Monad m => StateT s m a -> StateT (t,s) m a+extendStateFstT st =+   StateT (\(t0,s0) -> liftM (mapSnd (\s1 -> (t0,s1))) (runStateT st s0))++{-# INLINE extendStateSndT #-}+extendStateSndT :: Monad m => StateT s m a -> StateT (s,t) m a+extendStateSndT st =+   StateT (\(s0,t0) -> liftM (mapSnd (\s1 -> (s1,t0))) (runStateT st s0))+++{-# INLINE liftKleisli #-}+liftKleisli ::+   (forall s.+    Kleisli (StateT s Maybe) a0 a1 ->+    Kleisli (StateT s Maybe) b0 b1) ->+   T a0 a1 -> T b0 b1+liftKleisli op (Cons f s) =+   Cons (runKleisli $ op $ Kleisli f) s++{-# INLINE liftKleisli2 #-}+liftKleisli2 ::+   (forall s.+      Kleisli (StateT s Maybe) a0 a1 ->+      Kleisli (StateT s Maybe) b0 b1 ->+      Kleisli (StateT s Maybe) c0 c1) ->+   T a0 a1 -> T b0 b1 -> T c0 c1+liftKleisli2 op (Cons f s) (Cons g t) =+   Cons+      (runKleisli+         (Kleisli (extendStateSndT . f) `op`+          Kleisli (extendStateFstT . g)))+      (s,t)+++{-# INLINE id #-}+id :: T a a+id = returnA++{-# INLINE map #-}+map :: (a -> b) -> T a b+map f = fromState (return . f) ()++{-# INLINE compose #-}+compose :: T a b -> T b c -> T a c+compose = liftKleisli2 (>>>)++{-# INLINE split #-}+split :: T a b -> T c d -> T (a,c) (b,d)+split = liftKleisli2 (***)++{-# INLINE fanout #-}+fanout :: T a b -> T a c -> T a (b,c)+fanout = liftKleisli2 (&&&)+++{-# INLINE getNext #-}+getNext :: StateT (Sig.T a) Maybe a+getNext = StateT Sig.viewL++{-# INLINE apply #-}+apply :: T a b -> Sig.T a -> Sig.T b+apply (Cons f s) =+   Sig.crochetL (runStateT . f) s++{- |+I think this function does too much.+Better use 'feedFst' and (>>>).+-}+{-# INLINE applyFst #-}+applyFst, applyFst' :: T (a,b) c -> Sig.T a -> T b c+applyFst c as =+   c <<< feedFst as++applyFst' (Cons f s) as =+   Cons (\b ->+           do a <- extendStateFstT getNext+              extendStateSndT (f (a,b)))+        (s,as)++{- |+I think this function does too much.+Better use 'feedSnd' and (>>>).+-}+{-# INLINE applySnd #-}+applySnd, applySnd' :: T (a,b) c -> Sig.T b -> T a c+applySnd c as =+   c <<< feedSnd as++applySnd' (Cons f s) bs =+   Cons (\a ->+           do b <- extendStateFstT getNext+              extendStateSndT (f (a,b)))+        (s,bs)++{-# INLINE applyGeneric #-}+applyGeneric :: (SigG2.Transform sig a b) =>+   T a b -> sig a -> sig b+applyGeneric (Cons f s) =+   SigG2.crochetL (runStateT . f) s++{-# INLINE applyGenericSameType #-}+applyGenericSameType :: (SigG.Transform sig a) =>+   T a a -> sig a -> sig a+applyGenericSameType (Cons f s) =+   SigG.crochetL (runStateT . f) s+++{- |+applyConst c x == apply c (repeat x)+-}+{-# INLINE applyConst #-}+applyConst :: T a b -> a -> Sig.T b+applyConst (Cons f s) a =+   Sig.unfoldR (runStateT (f a)) s++{-+Can be easily done by converting the result of applyConst to generic signal+{-# INLINE applyConstGeneric #-}+applyConstGeneric :: SigG.LazySize -> T a b -> a -> sig b+applyConstGeneric size (Cons f s) a =+   SigG.unfoldR size (runStateT (f a)) s+-}+++{-# INLINE apply2 #-}+apply2 :: T (a,b) c -> Sig.T a -> Sig.T b -> Sig.T c+apply2 f x y =+   apply (applyFst f x) y++{-# INLINE apply3 #-}+apply3 :: T (a,b,c) d -> Sig.T a -> Sig.T b -> Sig.T c -> Sig.T d+apply3 f x y z =+   apply2 (applyFst ((\(a,(b,c)) -> (a,b,c)) ^>> f) x) y z+++{-# INLINE feed #-}+feed :: Sig.T a -> T () a+feed = fromStateMaybe (const getNext)++{-# INLINE feedFst #-}+feedFst :: Sig.T a -> T b (a,b)+feedFst = fromStateMaybe (\b -> fmap (flip (,) b) getNext)++{-# INLINE feedSnd #-}+feedSnd :: Sig.T a -> T b (b,a)+feedSnd = fromStateMaybe (\b -> fmap ((,) b) getNext)++{-# INLINE feedConstFst #-}+feedConstFst :: a -> T b (a,b)+feedConstFst a = map (\b -> (a,b))++{-# INLINE feedConstSnd #-}+feedConstSnd :: a -> T b (b,a)+feedConstSnd a = map (\b -> (b,a))++{-# INLINE feedGenericFst #-}+feedGenericFst :: (SigG.Read sig a) =>+   sig a -> T b (a,b)+feedGenericFst =+   feedFst . SigG.toState++{-# INLINE feedGenericSnd #-}+feedGenericSnd :: (SigG.Read sig a) =>+   sig a -> T b (b,a)+feedGenericSnd =+   feedSnd . SigG.toState++++-- * list like functions++{-# INLINE crochetL #-}+crochetL :: (x -> acc -> Maybe (y, acc)) -> acc -> T x y+crochetL f s = fromStateMaybe (StateT . f) s++{-# INLINE scanL #-}+scanL :: (acc -> x -> acc) -> acc -> T x acc+scanL f start =+   fromState (\x -> state $ \acc -> (acc, f acc x)) start++{-# INLINE scanL1 #-}+scanL1 :: (x -> x -> x) -> T x x+scanL1 f =+   crochetL (\x acc -> Just (x, Just $ maybe x (flip f x) acc)) Nothing++{-# INLINE zipWith #-}+zipWith :: (a -> b -> c) -> Sig.T a -> T b c+zipWith f = applyFst (map (uncurry f))++{- |+Prepend an element to a signal,+but keep the signal length,+i.e. drop the last element.+-}+{-# INLINE consInit #-}+consInit :: x -> T x x+consInit =+   crochetL (\x acc -> Just (acc, x))++++{-# INLINE chainControlled #-}+chainControlled :: [T (c,x) x] -> T (c,x) x+chainControlled =+   foldr+      (\p rest -> map fst &&& p  >>>  rest)+      (map snd)++{- |+If @T@ would be the function type @->@+then @replicateControlled 3 f@ computes+@\(c,x) -> f(c, f(c, f(c, x)))@.+-}+{-# INLINE replicateControlled #-}+replicateControlled :: Int -> T (c,x) x -> T (c,x) x+replicateControlled n p =+   nest n+      (map fst &&& p  >>> )+      (map snd)+++{-# INLINE feedback #-}+feedback :: T (a,c) b -> T b c -> T a b+feedback forth back =+   loop (forth >>>  id &&& back)++{-# INLINE feedbackControlled #-}+feedbackControlled :: T ((ctrl,a),c) b -> T (ctrl,b) c -> T (ctrl,a) b+feedbackControlled forth back =+   loop (map (fst.fst) &&& forth  >>>  map snd &&& back)++{-+{-# INLINE feedbackControlled #-}+feedbackControlled :: T (ctrl, (a,c)) b -> T (ctrl,b) c -> T (ctrl,a) b+feedbackControlled forth back =+   loop ((\((ctrl,a),c) -> (ctrl, (a,c)))  ^>>+         map fst &&& forth  >>>+         map snd &&& back)+-}
+ src-4/Synthesizer/Inference/DesignStudy/Applicative.hs view
@@ -0,0 +1,42 @@+{- |+  A design study about how to design signal processors+  that adapt to a common sample rate.+  I simplified "Synthesizer.Inference.DesignStudy.Arrow" to this module+  which uses only Applicative functors.+-}+module Synthesizer.Inference.DesignStudy.Applicative where++import Data.List (intersect)+import Control.Applicative (Applicative(..), liftA3, )++data Rates = Rates [Int] | Any deriving Show+-- it is a Reader monad with context processing+data Processor a = P Rates (Rates -> a)++intersectRates :: Rates -> Rates -> Rates+intersectRates Any y = y+intersectRates x Any = x+intersectRates (Rates xs) (Rates ys) = Rates $ intersect xs ys++instance Functor Processor where+   fmap f (P r f0) = P r (f . f0)++instance Applicative Processor where+   pure x = P Any (const x)+   (P r0 f0) <*> (P r1 f1)  =+      P (intersectRates r0 r1) (\r -> f0 r (f1 r))++runProcessor :: Processor a -> a+runProcessor (P r f) = f r++-- test processors+processor1, processor2, processor3 :: Processor Rates+processor1 = P (Rates [44100, 48000]) id+processor2 = P Any                    id+processor3 = P (Rates [48000])        id++process :: Processor (Rates, Rates, Rates)+process = liftA3 (,,) processor1 processor2 processor3++test :: (Rates, Rates, Rates)+test = runProcessor process
+ src-4/Synthesizer/Inference/DesignStudy/Arrow.hs view
@@ -0,0 +1,50 @@+module Synthesizer.Inference.DesignStudy.Arrow where++{-+  A hint from Haskell cafe about how to design signal processors+  that adapt to a common sample rate.+-}++{-+Date: Fri, 12 Nov 2004 02:59:31 +0900+From: Koji Nakahara <yu-@div.club.ne.jp>+To: haskell-cafe@haskell.org+-}++import Control.Category+import Control.Arrow+import Data.List (intersect)+data Rates = Rates [Int] | Any deriving Show+data Processor b c = P Rates (Rates -> b -> c)++-- test Stream+type Stream = String++intersectRates :: Rates -> Rates -> Rates+intersectRates Any y = y+intersectRates x Any = x+intersectRates (Rates xs) (Rates ys) = Rates $ intersect xs ys++instance Category Processor where+  id = P Any (const Prelude.id)+  (P r1 f1) . (P r0 f0) =+	  P (intersectRates r0 r1) (\r -> f1 r Prelude.. f0 r)++instance Arrow Processor where+  arr f = P Any (const f)+  first (P r0 f) = P r0 (\r (x, s) -> (f r x, s))+++runProcessor :: Processor b c -> b -> c+runProcessor (P r f) s = f r s++-- test processors+process, processor1, processor2, processor3 :: Processor String String+processor1 = P (Rates [44100, 48000]) (\r -> ( ++ show r))+processor2 = P Any                    (\r -> ( ++ show r))+processor3 = P (Rates [48000])        (\r -> ( ++ show r))++process = processor1 >>> processor2 >>> processor3++test :: String+test = runProcessor process "bla"
+ src-4/Synthesizer/Inference/DesignStudy/Monad.hs view
@@ -0,0 +1,44 @@+{- |+  A design study about how to design signal processors+  that adapt to a common sample rate.+  I tried to simplify "Synthesizer.Inference.DesignStudy.Arrow" to this module which uses only Monads.+  However the module is now very weird and does not really represent,+  what I intended to do.+-}+module Synthesizer.Inference.DesignStudy.Monad where++import Control.Monad.Trans.Writer (Writer, execWriter, tell)+import Data.List (intersect)++data Rates = Rates [Int] | Any deriving Show+-- it is a combination of Reader and Writer monad with context processing+data Processor a = P Rates (Rates -> Writer Stream a)++-- test Stream+type Stream = String++intersectRates :: Rates -> Rates -> Rates+intersectRates Any y = y+intersectRates x Any = x+intersectRates (Rates xs) (Rates ys) = Rates $ intersect xs ys++instance Monad Processor where+   return x = P Any (\_ -> return x)+   -- maybe we should turn this into an Applicative instance+   (P r0 f0) >> (P r1 f1)  =+       P (intersectRates r0 r1) (\r -> f0 r >> f1 r)+   (P _ _) >>= _ = error "Is it possible to implement that?"++runProcessor :: Processor a -> Stream+runProcessor (P r f) = execWriter (f r)++-- test processors+process, processor1, processor2, processor3 :: Processor ()+processor1 = P (Rates [44100, 48000]) (tell . show)+processor2 = P Any                    (tell . show)+processor3 = P (Rates [47000])        (tell . show)++process = processor1 >> processor2 >> processor3++test :: Stream+test = runProcessor process
+ src/Synthesizer/ApplicativeUtility.hs view
@@ -0,0 +1,111 @@+-- this is also used by synthesizer-dimensional and synthesizer-inference+module Synthesizer.ApplicativeUtility where++import Control.Applicative (Applicative, pure, (<*>), (<$>), liftA2, )+import Data.Traversable (Traversable, sequenceA, )++import Control.Monad.Fix (fix, )+++{-# INLINE liftA4 #-}+liftA4 :: Applicative f =>+   (a -> b -> c -> d -> e) -> f a -> f b -> f c -> f d -> f e+liftA4 f a b c d = f <$> a <*> b <*> c <*> d++{-# INLINE liftA5 #-}+liftA5 :: Applicative f =>+   (a -> b -> c -> d -> e -> g) -> f a -> f b -> f c -> f d -> f e -> f g+liftA5 f a b c d e = f <$> a <*> b <*> c <*> d <*> e++{-# INLINE liftA6 #-}+liftA6 :: Applicative f =>+   (a -> b -> c -> d -> e -> g -> h) -> f a -> f b -> f c -> f d -> f e -> f g -> f h+liftA6 f a b c d e g = f <$> a <*> b <*> c <*> d <*> e <*> g+++{- |+Create a loop (feedback) from one node to another one.+That is, compute the fix point of a process iteration.+-}+{-# INLINE loop #-}+loop :: (Functor f) =>+      f (a -> a)  {-^ process chain that shall be looped -}+   -> f a+loop = fmap fix+++infixl 0 $:, $::, $^, $#+infixr 9 .:, .^++{- |+This corresponds to 'Control.Applicative.<*>'+-}+{-# INLINE ($:) #-}+($:) :: (Applicative f) => f (a -> b) -> f a -> f b+($:) = (<*>)++{- |+Instead of @mixMulti $:: map f xs@+the caller should write @mixMulti $: mapM f xs@+in order to save the user from learning another infix operator.+-}+{-# INLINE ($::) #-}+($::) :: (Applicative f, Traversable t) =>+   f (t a -> b) -> t (f a) -> f b+($::) f arg = f $: sequenceA arg+-- ($::) f arg sr = f sr (map ($sr) arg)++{-# INLINE (.:) #-}+(.:) :: (Applicative f) => f (b -> c) -> f (a -> b) -> f (a -> c)+(.:) = liftA2 (.)+-- (.:) f g sr x = f sr (g sr x)+-- (.:) f g sr x = ($:) f (flip g x) sr++{-# INLINE ($^) #-}+($^) :: (Functor f) => (a -> b) -> f a -> f b+($^) = fmap+-- ($^) = (.)+-- ($^) f x = pure f $: x++{-# INLINE (.^) #-}+(.^) :: (Functor f) => (b -> c) -> f (a -> b) -> f (a -> c)+(.^) f = fmap (f.)+-- (.^) f = (.:) (pure f)++{-# INLINE ($#) #-}+($#) :: (Applicative f) => f (a -> b) -> a -> f b+($#) f x = f $: pure x+-- ($#) = flip+++{- |+Our signal processors have types like @f (a -> b -> c)@.+They could also have the type @a -> b -> f c@+or @f a -> f b -> f c@.+We did not choose the last variant for reduction of redundancy in type signatures,+and we did not choose the second variant for easy composition of processors.+However the forms are freely convertible,+and if you prefer the last one because you do not want to sprinkle '($:)' in your code,+then you may want to convert the processors using the following functions,+that can be defined purely in the 'Control.Applicative.Applicative' class.+-}++{-# INLINE liftP #-}+liftP :: (Applicative f) =>+   f (a -> b) -> f a -> f b+liftP = ($:)++{-# INLINE liftP2 #-}+liftP2 :: (Applicative f) =>+   f (a -> b -> c) -> f a -> f b -> f c+liftP2 f a b = f $: a $: b++{-# INLINE liftP3 #-}+liftP3 :: (Applicative f) =>+   f (a -> b -> c -> d) -> f a -> f b -> f c -> f d+liftP3 f a b c = f $: a $: b $: c++{-# INLINE liftP4 #-}+liftP4 :: (Applicative f) =>+   f (a -> b -> c -> d -> e) -> f a -> f b -> f c -> f d -> f e+liftP4 f a b c d = f $: a $: b $: c $: d
+ src/Synthesizer/Basic/Binary.hs view
@@ -0,0 +1,141 @@+{-# LANGUAGE NoImplicitPrelude #-}+module Synthesizer.Basic.Binary+   (C(..), toCanonical, fromCanonicalWith,+    numberOfSignalChannels,+    int16ToCanonical, int16FromCanonical,+    int16FromFloat, int16FromDouble,+    ) where++import qualified Synthesizer.Frame.Stereo as Stereo++import Data.Monoid (Monoid, mappend, )++import qualified Algebra.ToInteger as ToInteger+import qualified Algebra.RealField as RealField+import qualified Algebra.Real      as Real+import qualified Algebra.Field     as Field+import qualified Algebra.Ring      as Ring++import Data.Ord.HT (limit, )++import Data.Int (Int16, )+import GHC.Float (float2Int, double2Int, )++import qualified Prelude as P98++import PreludeBase+import NumericPrelude+++++class C a where+   outputFromCanonical ::+      (Bounded int, ToInteger.C int, Monoid out) =>+      (int -> out) -> a -> out+   numberOfChannels :: a -> Int++instance C Float where+   outputFromCanonical pack =+      pack .+      fromCanonicalWith+         (fromIntegral . truncToRound float2Int)+   numberOfChannels _ = 1++instance C Double where+   outputFromCanonical pack =+      pack .+      fromCanonicalWith+         (fromIntegral . truncToRound double2Int)+   numberOfChannels _ = 1++instance (C a, C b) => C (a,b) where+   outputFromCanonical pack x =+      outputFromCanonical pack (fst x) `mappend`+      outputFromCanonical pack (snd x)+   numberOfChannels x =+      numberOfChannels (fst x) ++      numberOfChannels (snd x)++instance (C a) => C (Stereo.T a) where+   outputFromCanonical pack x =+      outputFromCanonical pack (Stereo.left x) `mappend`+      outputFromCanonical pack (Stereo.right x)+   numberOfChannels x =+      numberOfChannels (Stereo.left x) ++      numberOfChannels (Stereo.right x)++++{-# INLINE numberOfSignalChannels #-}+numberOfSignalChannels ::+   C yv => sig yv -> Int+numberOfSignalChannels sig =+   let aux :: C yv => sig yv -> yv -> Int+       aux _ dummy = numberOfChannels dummy+   in  aux sig undefined++{-# INLINE fromCanonicalWith #-}+fromCanonicalWith ::+   (Real.C real, Bounded int, ToInteger.C int) =>+   (real -> int) -> (real -> int)+fromCanonicalWith rnd r =+   let s = fromIntegral (maxBound `asTypeOf` i)+       i = rnd (s * limit (-1, 1) r)+   in  i++{-# INLINE truncToRound #-}+truncToRound ::+   (RealField.C real) =>+   (real -> int) -> (real -> int)+truncToRound trunc x =+   trunc $+   if x<0+     then x - 0.5+     else x + 0.5++{-# INLINE scale16 #-}+scale16 :: (Ring.C a, Ord a) => a -> a+scale16 x = 32767 * limit (-1, 1) x++{-# INLINE int16FromCanonical #-}+int16FromCanonical :: (RealField.C a) => a -> Int16+int16FromCanonical = (P98.fromIntegral :: Int -> Int16) . round . scale16+{- in GHC-6.4 inefficient, since 'round' for target Int16 is not optimized+int16FromCanonical = round . scale16+-}++{-# INLINE int16FromFloat #-}+int16FromFloat :: Float -> Int16+int16FromFloat = P98.fromIntegral . float2Int . scale16+++{-+{-# INLINE scale16Double #-}+scale16Double :: (Ring.C a, Ord a) => a -> a+scale16Double x = 32767 * clip (-1) 1 x+-}++{-# INLINE int16FromDouble #-}+int16FromDouble :: Double -> Int16+{- Why is scale16 not inlined here? See FusionTest.mixTest3+int16FromDouble = P98.fromIntegral . double2Int . scale16+-}+-- int16FromDouble = P98.fromIntegral . double2Int . scale16Double+-- int16FromDouble x = P98.fromIntegral (double2Int (scale16 x))+int16FromDouble = P98.fromIntegral . double2Int . (32767*) . limit (-1, 1)+++++{-# INLINE toCanonical #-}+toCanonical ::+   (Field.C real, Bounded int, ToInteger.C int) =>+   (int -> real)+toCanonical i =+   let s = fromIntegral (maxBound `asTypeOf` i)+   in  fromIntegral i / s++{-# INLINE int16ToCanonical #-}+int16ToCanonical :: (Field.C a) => Int16 -> a+int16ToCanonical x = fromIntegral x / 32767
+ src/Synthesizer/Basic/Distortion.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE NoImplicitPrelude #-}+module Synthesizer.Basic.Distortion (+   clip, logit,+   zigZag, sine,+   quantize,+   ) where++import qualified Algebra.Transcendental        as Trans+import qualified Algebra.RealField             as RealField+import qualified Algebra.Field                 as Field+import qualified Algebra.Real                  as Real+import qualified Algebra.Ring                  as Ring+import qualified Algebra.Additive              as Additive++import Data.Ord.HT (limit, )++-- import qualified Prelude as P+-- import PreludeBase+import NumericPrelude+++{- * Clipping -}++{- |+limit, fuzz booster+-}+clip :: (Real.C a) => a -> a+clip = limit (negate one, one)++{- |+logit, tanh+-}+logit :: (Trans.C a) => a -> a+logit = tanh++{-+probit, error function+-}++++{- * Wrapping -}++{- |+zig-zag+-}+zigZag :: (RealField.C a) => a -> a+zigZag x =+   let (n,y) = splitFraction ((x+1)/2)+   in  if even (n::Int)+         then 2*y - 1+         else 1 - 2*y++{- |+sine+-}+sine :: (Trans.C a) => a -> a+sine = sin+++++{- * Quantization -}++quantize :: (RealField.C a) => a -> a+quantize x = fromIntegral (round x :: Int)
+ src/Synthesizer/Basic/DistortionControlled.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE NoImplicitPrelude #-}+module Synthesizer.Basic.DistortionControlled (+   clip, logit,+   zigZag, sine,+   quantize,+   ) where++import qualified Synthesizer.Basic.Distortion  as Dist++import qualified Algebra.Transcendental        as Trans+import qualified Algebra.RealField             as RealField+import qualified Algebra.Field                 as Field+import qualified Algebra.Real                  as Real+import qualified Algebra.Ring                  as Ring+import qualified Algebra.Additive              as Additive++import Data.Ord.HT (limit, )++-- import qualified Prelude as P+-- import PreludeBase+import NumericPrelude++{- * Clipping -}++{- |+limit, fuzz booster+-}+clip :: (Real.C a) => a -> a -> a+clip c = limit (negate c, c)++{- |+logit, tanh+-}+logit :: (Trans.C a) => a -> a -> a+logit k = rescale k Dist.logit++{-+probit, error function+-}++++{- * Wrapping -}++{- |+zig-zag+-}+zigZag :: (RealField.C a) => a -> a -> a+zigZag k = rescale k Dist.zigZag++{- |+sine+-}+sine :: (Trans.C a) => a -> a -> a+sine k = rescale k Dist.sine+++++{- * Quantization -}++quantize :: (RealField.C a) => a -> a -> a+quantize k = rescale k Dist.quantize++++{- Auxilary function -}++rescale :: (Field.C a) => a -> (a -> a) -> a -> a+rescale k f x = k * f (x/k)++{-+*Synthesizer.Basic.Distortion> GNUPlot.plotFuncs [] (GNUPlot.linearScale 1000 (-3,3::Double)) (map logit [0,0.1..1])+-}
+ src/Synthesizer/Basic/Phase.hs view
@@ -0,0 +1,90 @@+module Synthesizer.Basic.Phase+   (T,+    fromRepresentative,+    toRepresentative,+    increment,+    decrement,+    multiply,+   ) where++import qualified Algebra.RealField             as RealField+import qualified Algebra.Ring                  as Ring+import qualified Algebra.Additive              as Additive++import qualified Algebra.ToInteger             as ToInteger++import System.Random (Random(..))+import Test.QuickCheck (Arbitrary(..), choose)++import Foreign.Storable (Storable(..), )+import Foreign.Ptr (castPtr, )++import Data.Tuple.HT (mapFst, )+import qualified NumericPrelude as NP+++newtype T a = Cons {decons :: a}+   deriving Eq+++instance Show a => Show (T a) where+   showsPrec p x =+      showParen (p >= 10)+         (showString "Phase.fromRepresentative " . showsPrec 11 (toRepresentative x))++instance Storable a => Storable (T a) where+   {-# INLINE sizeOf #-}+   sizeOf = sizeOf . toRepresentative+   {-# INLINE alignment #-}+   alignment = alignment . toRepresentative+   {-# INLINE peek #-}+   peek ptr = fmap Cons $ peek (castPtr ptr)+   {-# INLINE poke #-}+   poke ptr = poke (castPtr ptr) . toRepresentative+++instance (Ring.C a, Random a) => Random (T a) where+   randomR = error "Phase.randomR makes no sense"+   random = mapFst Cons . randomR (NP.zero, NP.one)++instance (Ring.C a, Random a) => Arbitrary (T a) where+   arbitrary = fmap Cons $ choose (NP.zero, NP.one)+   coarbitrary = error "Phase.coarbitrary not implemented"++++{-# INLINE fromRepresentative #-}+fromRepresentative :: RealField.C a => a -> T a+fromRepresentative = Cons . RealField.fraction++{-# INLINE toRepresentative #-}+toRepresentative :: T a -> a+toRepresentative = decons++{-# INLINE increment #-}+increment :: RealField.C a => a -> T a -> T a+increment d = lift (d Additive.+)++{-# INLINE decrement #-}+decrement :: RealField.C a => a -> T a -> T a+decrement d = lift (Additive.subtract d)++{-# INLINE multiply #-}+multiply :: (RealField.C a, ToInteger.C b) => b -> T a -> T a+multiply n x = fromRepresentative (toRepresentative x Ring.* NP.fromIntegral n)+++instance RealField.C a => Additive.C (T a) where+   {-# INLINE zero #-}+   {-# INLINE (+) #-}+   {-# INLINE (-) #-}+   {-# INLINE negate #-}+   zero = Cons Additive.zero+   x + y = fromRepresentative (toRepresentative x Additive.+ toRepresentative y)+   x - y = fromRepresentative (toRepresentative x Additive.- toRepresentative y)+   negate = lift Additive.negate++{-# INLINE lift #-}+lift :: RealField.C a => (a -> a) -> T a -> T a+lift f =+   fromRepresentative . f . toRepresentative
+ src/Synthesizer/Basic/ToneModulation.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE NoImplicitPrelude #-}+module Synthesizer.Basic.ToneModulation where++import qualified Synthesizer.Basic.Phase as Phase++import Synthesizer.Interpolation (Margin, marginOffset, marginNumber, )++-- import qualified Algebra.Transcendental        as Trans+import qualified Algebra.RealField             as RealField+import qualified Algebra.Field                 as Field+-- import qualified Algebra.Real                  as Real+import qualified Algebra.Ring                  as Ring+import qualified Algebra.Additive              as Additive++import NumericPrelude++-- import qualified Prelude as P+import PreludeBase+++{- |+Convert from the (shape,phase) parameter pair+to the index within a wave (step) and the index of a wave (leap)+in the sampled prototype tone.++For this routine it would be simpler,+if @shape@ would measure in multiples of @period@+(we would only need a Ring instance),+but for 'shapeLimit' it is better the way it is.+-}+untangleShapePhase :: (Field.C a) =>+   Int -> a -> (a, a) -> (a, a)+untangleShapePhase periodInt period (shape,phase) =+   let leap = shape/period - phase+       step = shape - leap * fromIntegral periodInt+   in  (leap, step)++untangleShapePhaseAnalytic :: (Field.C a) =>+   Int -> a -> (a, a) -> (a, a)+untangleShapePhaseAnalytic periodInt period (shape,phase) =+   let periodRound = fromIntegral periodInt+       vLeap = (periodRound, periodRound-period)+       vStep = (1,1)+   in  solveSLE2 (vLeap,vStep) (shape,period*phase)++{-+Cramer's rule++see HTam/Numerics/ZeroFinder/Root, however the matrix is transposed+-}+solveSLE2 :: Field.C a => ((a,a), (a,a)) -> (a,a) -> (a,a)+solveSLE2 a@(a0,a1) b =+   let det = det2 a+   in  (det2 (b, a1) / det,+        det2 (a0, b) / det)++det2 :: Ring.C a => ((a,a), (a,a)) -> a+det2 ((a00,a10),(a01,a11)) =+   a00*a11 - a10*a01++{-+transpose :: ((a,a), (a,a)) -> ((a,a), (a,a))+transpose ((a00,a10),(a01,a11)) = ((a00,a01),(a10,a11))+-}+++flattenShapePhase, flattenShapePhaseAnalytic :: RealField.C a =>+      Int+   -> a+   -> (a, Phase.T a)+   -> (Int, (a, a))+flattenShapePhase periodInt period (shape,phase) =+   let xLeap = shape/period - Phase.toRepresentative phase+       qLeap = fraction xLeap+       xStep = shape - qLeap * fromIntegral periodInt+       (n,qStep) = splitFraction xStep+   in  (n,(qLeap,qStep))++flattenShapePhaseAnalytic periodInt period (shape,phase) =+   let (xLeap,xStep) =+          untangleShapePhase periodInt period (shape, Phase.toRepresentative phase)+       (nLeap,qLeap) = splitFraction xLeap+       (nStep,qStep) = splitFraction xStep+       {- reverse solveSLE2 for the shape parameter+          with respect to the rounded (wave,shape) coordinates -}+       n = nStep + nLeap * periodInt+   in  (n,(qLeap,qStep))+++shapeLimits :: Ring.C t =>+   Margin ->+   Margin ->+   Int ->+   t ->+   (t, t)+shapeLimits marginLeap marginStep periodInt len =+   let minShape =+          fromIntegral $+          interpolationOffset marginLeap marginStep periodInt ++          periodInt+       maxShape =+          minShape + len -+          fromIntegral (interpolationNumber marginLeap marginStep periodInt)+   in  (minShape, maxShape)++interpolationOffset ::+   Margin ->+   Margin ->+   Int ->+   Int+interpolationOffset marginLeap marginStep periodInt =+   marginOffset marginStep ++   marginOffset marginLeap * periodInt++interpolationNumber ::+   Margin ->+   Margin ->+   Int ->+   Int+interpolationNumber marginLeap marginStep periodInt =+   marginNumber marginStep ++   marginNumber marginLeap * periodInt++++type Coords t = (Int,(Int,(t,t)))+type Skip   t = (Int, (t, Phase.T t))
+ src/Synthesizer/Basic/Wave.hs view
@@ -0,0 +1,773 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{- |+Copyright   :  (c) Henning Thielemann 2006+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes++Basic waveforms++If you want to use parametrized waves with two parameters+then zip your parameter signals and apply 'uncurry' to the wave function.+-}+module Synthesizer.Basic.Wave where++import qualified Synthesizer.Basic.Phase as Phase++import qualified Algebra.RealTranscendental    as RealTrans+import qualified Algebra.Transcendental        as Trans+import qualified Algebra.RealField             as RealField+import qualified Algebra.Algebraic             as Algebraic+import qualified Algebra.Module                as Module+import qualified Algebra.Field                 as Field+import qualified Algebra.Real                  as Real+import qualified Algebra.Ring                  as Ring+import qualified Algebra.Additive              as Additive+import qualified Algebra.ToInteger             as ToInteger++import qualified MathObj.Polynomial as Poly+import qualified Number.Complex     as Complex++import Data.Bool.HT (select, if', )+import NumericPrelude++-- import qualified Prelude as P+import PreludeBase+++{- * Definition and construction -}++newtype T t y = Cons {decons :: Phase.T t -> y}+++{-# INLINE fromFunction #-}+fromFunction :: (t -> y) -> (T t y)+fromFunction wave = Cons (wave . Phase.toRepresentative)+++{- * Operations on waves -}++{-# INLINE raise #-}+raise :: (Additive.C y) => y -> T t y -> T t y+raise y = distort (y+)++{-# INLINE amplify #-}+amplify :: (Ring.C y) => y -> T t y -> T t y+amplify k = distort (k*)++{-# INLINE distort #-}+distort :: (y -> z) -> T t y -> T t z+distort g (Cons f) = Cons (g . f)++{-# INLINE overtone #-}+overtone :: (RealField.C t, ToInteger.C n) => n -> T t y -> T t y+overtone n (Cons f) = Cons (f . Phase.multiply n)++{-# INLINE apply #-}+apply :: T t y -> (Phase.T t -> y)+apply = decons++++instance Additive.C y => Additive.C (T t y) where+   {-# INLINE zero #-}+   {-# INLINE (+) #-}+   {-# INLINE (-) #-}+   {-# INLINE negate #-}+   zero = Cons (const zero)+   (+) (Cons f) (Cons g) = Cons (\t -> f t + g t)+   (-) (Cons f) (Cons g) = Cons (\t -> f t - g t)+   negate = distort negate+++instance Module.C a y => Module.C a (T t y) where+   {-# INLINE (*>) #-}+   s *> w = distort (s*>) w+++{- |+Turn an unparametrized waveform into a parametrized one,+where the parameter is a phase offset.+This way you express a phase modulated oscillator+using a shape modulated oscillator.+-}+{-# SPECULATE phaseOffset :: (T Double b) -> (Double -> T Double b) #-}+{-# INLINE phaseOffset #-}+phaseOffset :: (RealField.C a) => T a b -> (a -> T a b)+phaseOffset (Cons wave) offset =+   Cons (wave . Phase.increment offset)+++++{- * Examples -}++{- ** unparameterized -}++{- | map a phase to value of a sine wave -}+{-# SPECULATE sine :: Double -> Double #-}+{-# INLINE sine #-}+sine :: Trans.C a => T a a+sine = fromFunction $ \x -> sin (2*pi*x)++{-# INLINE cosine #-}+cosine :: Trans.C a => T a a+cosine = fromFunction $ \x -> cos (2*pi*x)++{-# INLINE helix #-}+helix :: Trans.C a => T a (Complex.T a)+helix = fromFunction $ \x -> Complex.cis (2*pi*x)++{- |+Approximation of sine by parabolas.+Surprisingly not really faster than 'sine'.+-}+{-# INLINE fastSine2 #-}+fastSine2 :: (Ord a, Ring.C a) => T a a+fastSine2 = fromFunction $ \x ->+   if 2*x<1+     then 1 - sqr (4*x-1)+     else sqr (4*x-3) - 1++{- |+Approximation of sine by fourth order polynomials.+-}+{-# INLINE fastSine4 #-}+fastSine4 :: (Ord a, Trans.C a) => T a a+fastSine4 = fromFunction $ \x ->+   -- minimal least squares fit+   let pi2 = pi*pi+       pi3 = pi2*pi+       c = 3*((10080/pi2 - 1050) / pi3 + 1) -- 0.2248391014+       {-# INLINE bow #-}+       bow y = let y2 = y*y in 1-y2*(1+c*(1-y2))+   in  if 2*x<1+         then   bow (4*x-1)+         else - bow (4*x-3)+{-+add a residue to fastSine2 and choose 'c' which minimizes the squared error+   in  if 2*x<1+         then let y = (4*x-1)^2 in 1-y-c*y*(1-y)+         else let y = (4*x-3)^2 in y-1+c*y*(1-y)+-}++{-+GNUPlot.plotFuncs [] (GNUPlot.linearScale 1000 (0,1::Double)) [sine, fastSine2, fastSine4]+-}+++{- | saw tooth,+it's a ramp down in order to have a positive coefficient for the first partial sine+-}+{-# SPECULATE saw :: Double -> Double #-}+{-# INLINE saw #-}+saw :: Ring.C a => T a a+saw = fromFunction $ \x -> 1-2*x++{- |+This wave has the same absolute Fourier coefficients as 'saw'+but the partial waves are shifted by 90 degree.+That is, it is the Hilbert transform of the saw wave.+The formula is derived from 'sawComplex'.+-}+{-# INLINE sawCos #-}+sawCos :: (Real.C a, Trans.C a) => T a a+sawCos = fromFunction $ \x -> log (2 * sin (pi*x)) * (-2/pi)++{- |+@sawCos + i*saw@++This is an analytic function and thus it may be used for frequency shifting.++The formula can be derived from the power series of the logarithm function.+-}+{-# INLINE sawComplex #-}+sawComplex ::+   (Complex.Power a, RealTrans.C a) =>+   T a (Complex.T a)+sawComplex = fromFunction $ \x -> log (1 + Complex.cis (-pi*(1-2*x))) * (-2/pi)+{-+GNUPlot.plotFuncs [] (GNUPlot.linearScale 100 (0,1::Double)) [Complex.real . sawComplex, sawCos]++GNUPlot.plotFuncs [] (GNUPlot.linearScale 100 (0,1::Double)) [sawCos, composedHarmonics (take 20 $ harmonic 0 0 : map (\n -> harmonic 0.25 ((2/pi) / fromInteger n)) [1..])]+-}++{-+Matching implementation that do not match 'saw' exactly.++sawCos :: (Real.C a, Trans.C a) => T a a+sawCos = fromFunction $ \x -> log (2 * abs (cos (pi*x)))++sawComplex ::+   (Complex.Power a, Trans.C a) =>+   T a (Complex.T a)+sawComplex = fromFunction $ \x -> log (1 + Complex.cis (2*pi*x))+-}+++{- | square -}+{-# SPECULATE square :: Double -> Double #-}+{-# INLINE square #-}+square :: (Ord a, Ring.C a) => T a a+square = fromFunction $ \x -> if 2*x<1 then 1 else -1++{- |+This wave has the same absolute Fourier coefficients as 'square'+but the partial waves are shifted by 90 degree.+That is, it is the Hilbert transform of the saw wave.+-}+{-# INLINE squareCos #-}+squareCos :: (RealField.C a, Trans.C a) => T a a+squareCos = fromFunction $ \x ->+   log (abs (tan (pi*x))) * (-2/pi)+   -- sawCos x - sawCos (fraction (0.5-x))++{- |+@squareCos + i*square@++This is an analytic function and thus it may be used for frequency shifting.++The formula can be derived from the power series of the area tangens function.+-}+{-# INLINE squareComplex #-}+squareComplex ::+   (Complex.Power a, RealTrans.C a) =>+   T a (Complex.T a)+squareComplex = fromFunction $ \x ->+{- these formulas are equivalent but wrong++   log (0 +: 2 * sine x) * (2/pi)++   log ((1 - Complex.cis (-2*pi*x)) *+        (1 + Complex.cis ( 2*pi*x))) * (2/pi)++   sawComplex x + sawComplex (0.5-x)+-}++{-+The Fourier series is equal to the power series of 'atanh'.+-}+   atanh (Complex.cis (2*pi*x)) * (4/pi)+{-+GNUPlot.plotFuncs [] (GNUPlot.linearScale 100 (0,1::Double)) [squareCos, composedHarmonics (take 20 $ zipWith (\b n -> harmonic 0.25 (if b then (4/pi) / fromInteger n else 0)) (cycle [False,True]) [0..])]+-}+++{- | triangle -}+{-# SPECULATE triangle :: Double -> Double #-}+{-# INLINE triangle #-}+triangle :: (Ord a, Ring.C a) => T a a+triangle = fromFunction $ \x ->+   let x4 = 4*x+   in  select (2-x4)+          [(x4<1, x4),+           (x4>3, x4-4)]++{-++int(arctan(x)/x,x);++- polylog(2, x*I)*1/2*I + polylog(2, x*(-I))*1/2*I+++series(int(arctan(x)/x,x),x,10);++x - 1/9*x^3 + 1/25*x^5 - 1/49*x^7 + 1/81*x^9 + O(x^11)++++int(arctan(I*x)/(I*x),x);+int(arctanh(x)/(x),x);++1/2*polylog(2, x) - 1/2*polylog(2, -x)+int(1/x*arctanh(x), x)++polylog(2,x) = dilog(1-x);    -- dilog is implemented in GSL for complex arguments+polylog(2,x) = hypergeom([1,1,1],[2,2],x) * x;+++series(int(arctan(I*x)/(I*x),x),x,10);++x + 1/9*x^3 + 1/25*x^5 + 1/49*x^7 + 1/81*x^9 + O(x^11)+-}+++{- ** discretely parameterized -}++{- |+A truncated cosine. This has rich overtones.+-}+truncOddCosine :: Trans.C a =>+   Int -> T a a+truncOddCosine k =+   let f = pi * fromIntegral (2*k+1)+   in  fromFunction $ \ x -> cos (f*x)++{- |+For parameter zero this is 'saw'.+-}+truncOddTriangle :: (RealField.C a) =>+   Int -> T a a+truncOddTriangle k =+   let s = fromIntegral (2*k+1)+   in  fromFunction $ \ x ->+          let (n,frac) = splitFraction (s*x)+          in  if even (n::Int)+                then 1-2*frac+                else 2*frac-1+++{- ** continuously parameterized -}++{- |+A truncated cosine plus a ramp that guarantees a bump of high 2 at the boundaries.++It is @truncCosine (2 * fromIntegral n + 0.5) == truncOddCosine (2*n)@+-}+truncCosine :: Trans.C a =>+   a -> T a a+truncCosine k =+   let f = 2 * pi * k+       s = 2 * (sin (f*0.5) - 1)+   in  fromFunction $ \ x0 ->+          let x = x0-0.5+          in  - sin (f*x) + s*x+{-+GNUPlot.plotFuncs [] (GNUPlot.linearScale 1000 (0,1::Double)) (map truncCosine [0.5,0.7..2.5])+-}++truncTriangle :: (RealField.C a) =>+   a -> T a a+truncTriangle k =+   let tr x =+          let (n,frac) = splitFraction (2*k*x+0.5)+          in  if even (n::Int)+                then 1-2*frac+                else 2*frac-1+       s = 2 * (1 + tr 0.5)+   in  fromFunction $ \ x0 ->+          let x = x0-0.5+          in  tr x - s*x+{-+GNUPlot.plotFuncs [] (GNUPlot.linearScale 1000 (0,1::Double)) (map truncTriangle [0,0.25..2.5])+-}+++{- |+Power function.+-}+++{- |+Roughly the map @\x p -> x**p@+but retains the sign of @x@ and+normalizes the mapping over @[-1,1]@ to L2 norm of 1.+-}+{-# INLINE powerNormed #-}+powerNormed :: (Real.C a, Trans.C a) => a -> T a a+powerNormed p = fromFunction $ \x -> power01Normed p (2*x-1)++-- | auxiliary+{-# INLINE power01Normed #-}+power01Normed :: (Real.C a, Trans.C a) => a -> a -> a+power01Normed p x = (p+0.5) * powerSigned p x++-- | auxiliary+{-# INLINE powerSigned #-}+powerSigned :: (Real.C a, Trans.C a) => a -> a -> a+powerSigned p x = signum x * abs x ** p+++{- |+Tangens hyperbolicus allows interpolation+between some kind of saw tooth and square wave.+In principle it is not necessary+because you can distort a saw tooth oscillation by @map tanh@.+-}+logitSaw :: (Trans.C a) => a -> T a a+logitSaw c = distort tanh $ amplify c saw+++{- |+Tangens hyperbolicus of a sine allows interpolation+between some kind of sine and square wave.+In principle it is not necessary+because you can distort a square oscillation by @map tanh@.+-}+logitSine :: (Trans.C a) => a -> T a a+logitSine c = distort tanh $ amplify c sine+++{- |+Interpolation between 'sine' and 'square'.+-}+{-# INLINE sineSquare #-}+sineSquare :: (Real.C a, Trans.C a) =>+      a {- ^ 0 for 'sine', 1 for 'square' -}+   -> T a a+sineSquare c =+   distort (powerSigned (1-c)) sine++++{- |+Interpolation between 'fastSine2' and 'saw'.+We just shrink the parabola towards the borders+and insert a linear curve such that its slope matches the one of the parabola.+-}+{-# INLINE piecewiseParabolaSaw #-}+piecewiseParabolaSaw :: (Algebraic.C a, Ord a) =>+      a {- ^ 0 for 'fastSine2', 1 for 'saw' -}+   -> T a a+piecewiseParabolaSaw c =+   let xb  = (1 - sqrt c) / 2+       y x = 1 - ((4*x - (1-c))/(1-c))^2+   in  fromFunction $ \ x ->+       select+          ((2*x - 1)/(2*xb - 1) * y xb)+          [(x <   xb,   y x),+           (x > 1-xb, - y (1-x))]++{-+equ0 c x =+   let y  = 1 - ((4*x - (3+c))/(1-c))^2+       secant  = y/(x-1/2)+       tangent = - 8 * (4*x - (3+c))/(1-c)^2+   in  (tangent, secant)++equ1 c x =+   let secant  = (1 - ((4*x - (3+c))/(1-c))^2)/(x-1/2)+       tangent = - 8 * (4*x - (3+c))/(1-c)^2+   in  (tangent, secant)++equ2 c x =+   (1, ((4*x - (3+c))/(1-c))^2+              - 8 * (x-1/2) * (4*x - (3+c))/(1-c)^2)++equ3 c x =+   ((1-c)^2,+        (4*x - (3+c) - 4 * (2*x-1)) * (4*x - (3+c)))++equ4 c x =+   (4*x - (1-c)) * (4*x - (3+c)) + (1-c)^2++equ5 c x =+   (4*x - 2) ^ 2 - (1+c)^2 + (1-c)^2++equ6 c x =+   (4*x - 2) ^ 2 - 4*c+-}+++{- |+Interpolation between 'sine' and 'saw'.+We just shrink the sine towards the borders+and insert a linear curve such that its slope matches the one of the sine.+-}+{-# INLINE piecewiseSineSaw #-}+piecewiseSineSaw :: (Trans.C a, Ord a) =>+      a {- ^ 0 for 'sine', 1 for 'saw' -}+   -> T a a+piecewiseSineSaw c =+   let {- This simple fix point iteration converges very slow for small 'c',+          maybe we should use a Newton iteration. -}+       iter z = iterate (\zi -> pi + atan (zi - pi / (1-c))) z !! 10+       xb = (1-c)/(2*pi) * iter 0+       -- iter (xInit * (2*pi) / (1-c))+       -- xb  = (1 - sqrt c) / 2+       -- y x = sine (x/(1-c))+       y x = sin (2*pi*x/(1-c))+   in  fromFunction $ \ x -> select+          ((2*x - 1)/(2*xb - 1) * y xb)+          [(x <   xb,   y x),+           (x > 1-xb, - y (1-x))]++{-+equ0 c x =+   let secant  = 2 * sin (2*pi*x/(1-c)) / (2*x - 1)+       tangent = 2*pi/(1-c) * cos (2*pi*x/(1-c))+   in  (tangent, secant)++iter0 c x =+   -- secant / tangent+   -- (x - 1/2) = tan (2*pi*x/(1-c)) * (1-c) / (2*pi)+   tan (2*pi*x/(1-c)) * (1-c) / (2*pi) + 1/2++iter1 c x =+   (1-c)/(2*pi) * (pi + atan ((x - 1/2) * (2*pi) / (1-c)))++iter2 c x =+   let iter z = iterate (\zi -> pi + atan (zi - pi / (1-c))) z !! 10+   in  (1-c)/(2*pi) * iter (x * (2*pi) / (1-c))+-}+++{- |+Interpolation between 'sine' and 'saw'+with smooth intermediate shapes but no perfect saw.+-}+{-# INLINE sineSawSmooth #-}+sineSawSmooth :: (Trans.C a) =>+      a {- ^ 0 for 'sine', 1 for 'saw' -}+   -> T a a+sineSawSmooth c =+   distort (\x -> sin (affineComb c (pi * x, asin x * 2))) saw++{- |+Interpolation between 'sine' and 'saw'+with perfect saw, but sharp intermediate shapes.+-}+{-# INLINE sineSawSharp #-}+sineSawSharp :: (Trans.C a) =>+      a {- ^ 0 for 'sine', 1 for 'saw' -}+   -> T a a+sineSawSharp c =+   distort (\x -> sin (affineComb c (pi * x, asin x))) saw+++affineComb :: Ring.C a => a -> (a,a) -> a+affineComb phase (x0,x1) = (1-phase)*x0 + phase*x1+++{-+{- |+Smooth saw generated by a quintic polynomial function.+Unfortunately if 'c' approaches the right border,+the function will overshoot the 'y' range (-1,1).+-}+quinticSaw :: Field.C a =>+      a  {- ^ position of the right minimum -}+   -> a+   -> a+quinticSaw c x =+   let (s,t) = ToneMod.solveSLE2 ((c^2-1, 3*c^2-1), (c^4-1, 5*c^4-1)) (-1/c,0)+       r = - s - t+       x2 = x^2+   in  x * (r + x2 * (s + x2*t))+{-+       r*x + s*  x^3 + t*  x^5+   0 = r   + s       + t+  -1 = r*c + s*  c^3 + t*  c^5+   0 = r   + s*3*c^2 + t*5*c^4++-1/c = r   + s*  c^2 + t*  c^4++-1/c = s*(c^2-1)   + t*(c^4-1)+   0 = s*(3*c^2-1) + t*(5*c^4-1)+-}+-}+++{- |+saw with space+-}+{-# SPECULATE sawPike :: Double -> Double -> Double #-}+{-# INLINE sawPike #-}+sawPike :: (Ord a, Field.C a) =>+      a {- ^ pike width ranging from 0 to 1, 1 yields 'saw' -}+   -> T a a+sawPike r = fromFunction $ \x ->+   if x<r+     then 1-2/r*x+     else 0++{- |+triangle with space+-}+{-# SPECULATE trianglePike :: Double -> Double -> Double #-}+{-# INLINE trianglePike #-}+trianglePike :: (Real.C a, Field.C a) =>+      a  {- ^ pike width ranging from 0 to 1, 1 yields 'triangle' -}+   -> T a a+trianglePike r = fromFunction $ \x ->+   if x < 1/2+     then max 0 (1 - abs (4*x-1) / r)+     else min 0 (abs (4*x-3) / r - 1)++{- |+triangle with space and shift+-}+{-# SPECULATE trianglePikeShift :: Double -> Double -> Double -> Double #-}+{-# INLINE trianglePikeShift #-}+trianglePikeShift :: (Real.C a, Field.C a) =>+      a  {- ^ pike width ranging from 0 to 1 -}+   -> a  {- ^ shift ranges from -1 to 1; 0 yields 'trianglePike' -}+   -> T a a+trianglePikeShift r s = fromFunction $ \x ->+   if x < 1/2+     then max 0 (1 - abs (4*x-1+s*(r-1)) / r)+     else min 0 (abs (4*x-3+s*(1-r)) / r - 1)++{- |+square with space,+can also be generated by mixing square waves with different phases+-}+{-# SPECULATE squarePike :: Double -> Double -> Double #-}+{-# INLINE squarePike #-}+squarePike :: (Real.C a) =>+      a  {- ^ pike width ranging from 0 to 1, 1 yields 'square' -}+   -> T a a+squarePike r = fromFunction $ \x ->+   if 2*x < 1+     then if abs(4*x-1)<r then  1 else 0+     else if abs(4*x-3)<r then -1 else 0++{- |+square with space and shift+-}+{-# SPECULATE squarePikeShift :: Double -> Double -> Double -> Double #-}+{-# INLINE squarePikeShift #-}+squarePikeShift :: (Real.C a) =>+      a  {- ^ pike width ranging from 0 to 1 -}+   -> a  {- ^ shift ranges from -1 to 1; 0 yields 'squarePike' -}+   -> T a a+squarePikeShift r s = fromFunction $ \x ->+   if 2*x < 1+     then if abs(4*x-1+s*(r-1))<r then  1 else 0+     else if abs(4*x-3+s*(1-r))<r then -1 else 0+++{- |+square with different times for high and low+-}+{-# SPECULATE squareAsymmetric :: Double -> Double -> Double #-}+{-# INLINE squareAsymmetric #-}+squareAsymmetric :: (Ord a, Ring.C a) =>+      a  {- ^ value between -1 and 1 controlling the ratio of high and low time:+              -1 turns the high time to zero,+               1 makes the low time zero,+               0 yields 'square' -}+   -> T a a+squareAsymmetric r = fromFunction $ \x ->+   if 2*x < r+1 then 1 else -1++{- | Like 'squareAsymmetric' but with zero average.+It could be simulated by adding two saw oscillations+with 180 degree phase difference and opposite sign.+-}+{-# SPECULATE squareBalanced :: Double -> Double -> Double #-}+{-# INLINE squareBalanced #-}+squareBalanced :: (Ord a, Ring.C a) => a -> T a a+squareBalanced r =+   raise (-r) $ squareAsymmetric r++{- |+triangle+-}+{-# SPECULATE sawPike :: Double -> Double -> Double #-}+{-# INLINE triangleAsymmetric #-}+triangleAsymmetric :: (Ord a, Field.C a) =>+      a  {- ^ asymmetry parameter ranging from -1 to 1:+              For 0 you obtain the usual triangle.+              For -1 you obtain a falling saw tooth starting with its maximum.+              For 1 you obtain a rising saw tooth starting with a zero. -}+   -> T a a+triangleAsymmetric r = fromFunction $ \x ->+   select ((2-4*x)/(1-r))+      [(4*x < 1+r, 4/(1+r)*x),+       (4*x > 3-r, 4/(1+r)*(x-1))]++{- |+Mixing 'trapezoid' and 'trianglePike' you can get back a triangle wave form+-}+{-# SPECULATE trapezoid :: Double -> Double -> Double #-}+{-# INLINE trapezoid #-}+trapezoid :: (Real.C a, Field.C a) =>+      a  {- ^ width of the plateau ranging from 0 to 1:+              0 yields 'triangle', 1 yields 'square' -}+   -> T a a+trapezoid w = fromFunction $ \x ->+   if x < 1/2+     then min   1  ((1 - abs (4*x-1)) / (1-w))+     else max (-1) ((abs (4*x-3) - 1) / (1-w))++{- |+Trapezoid with distinct high and low time.+That is the high and low trapezoids are symmetric itself,+but the whole waveform is not symmetric.+-}+{-# SPECULATE trapezoidAsymmetric :: Double -> Double -> Double -> Double #-}+{-# INLINE trapezoidAsymmetric #-}+trapezoidAsymmetric :: (Real.C a, Field.C a) =>+      a  {- ^ sum of the plateau widths ranging from 0 to 1:+              0 yields 'triangleAsymmetric',+              1 yields 'squareAsymmetric' -}+   -> a  {- ^ asymmetry of the plateau widths ranging from -1 to 1 -}+   -> T a a+trapezoidAsymmetric w r = fromFunction $ \x ->+   let c0 = 1+w*r+       c1 = 1-w*r+   in  if 2*x < c0+         then min   1  ((c0 - abs (4*x-c0)) / (1-w))+         else max (-1) ((abs (4*(1-x)-c1) - c1) / (1-w))+{-+   let c = w*r+1+   in  if 2*x < c+         then min   1  ((1 - abs (4*x/c-1))*c/(1-w))+         else max (-1) ((abs (4*(1-x)/(2-c)-1) - 1)*(2-c)/(1-w))+-}+{-+   let c = (w*r+1)/2+   in  if x < c+         then min   1  ((1 - abs (2*x/c-1))*2*c/(1-w))+         else max (-1) ((abs (2*(1-x)/(1-c)-1) - 1)*2*(1-c)/(1-w))+-}++{- |+trapezoid with distinct high and low time and zero direct current offset+-}+{-# SPECULATE trapezoidBalanced :: Double -> Double -> Double -> Double #-}+{-# INLINE trapezoidBalanced #-}+trapezoidBalanced :: (Real.C a, Field.C a) => a -> a -> T a a+trapezoidBalanced w r =+   raise (-w*r) $ trapezoidAsymmetric w r+++-- could also be generated by amplifying and clipping a saw ramp+{- |+parametrized trapezoid that can range from a saw ramp to a square waveform.+-}+trapezoidSkew :: (Ord a, Field.C a) =>+      a   {- ^ width of the ramp,+               that is 1 yields a downwards saw ramp+               and 0 yields a square wave. -}+   -> T a a+trapezoidSkew w =+   fromFunction $ \t ->+   if' (2*t<=1-w)   1  $+   if' (2*t>=1+w) (-1) $+   (1-2*t)/w++{- |+This is similar to Polar coordinates,+but the range of the phase is from @0@ to @1@, @0@ to @2*pi@.+-}+data Harmonic a =+   Harmonic {harmonicPhase :: Phase.T a, harmonicAmplitude :: a}++{-# INLINE harmonic #-}+harmonic :: Phase.T a -> a -> Harmonic a+harmonic = Harmonic++{- |+Specify the wave by its harmonics.++The function is implemented quite efficiently+by applying the Horner scheme to a polynomial with complex coefficients+(the harmonic parameters)+using a complex exponential as argument.+-}+{-# INLINE composedHarmonics #-}+composedHarmonics :: Trans.C a => [Harmonic a] -> T a a+composedHarmonics hs =+   let p = Poly.fromCoeffs $+              map (\h -> Complex.fromPolar (harmonicAmplitude h)+                      (2*pi * Phase.toRepresentative (harmonicPhase h))) hs+   in  distort (Complex.imag . Poly.evaluate p) helix+{-+GNUPlot.plotFunc [] (GNUPlot.linearScale 1000 (0,1::Double)) (composedHarmonics [harmonic 0 0, harmonic 0 0, harmonic 0 0, harmonic 0.25 1])+-}
+ src/Synthesizer/Basic/WaveSmoothed.hs view
@@ -0,0 +1,195 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{- |+Copyright   :  (c) Henning Thielemann 2006+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes++Waveforms which are smoothed according to the oscillator frequency+in order to suppress aliasing effects.+-}+module Synthesizer.Basic.WaveSmoothed (+   T,+   fromFunction,+   fromWave,+   fromControlledWave,++   raise,+   amplify,+   distort,+   apply,++   sine,+   cosine,+   saw,+   square,+   triangle,++   Wave.Harmonic,+   Wave.harmonic,+   composedHarmonics,+   ) where+++import qualified Synthesizer.Basic.Wave  as Wave+import qualified Synthesizer.Basic.Phase as Phase++-- import qualified Algebra.RealTranscendental    as RealTrans+import qualified Algebra.Transcendental        as Trans+-- import qualified Algebra.RealField             as RealField+import qualified Algebra.Module                as Module+import qualified Algebra.Field                 as Field+import qualified Algebra.Real                  as Real+import qualified Algebra.Ring                  as Ring+import qualified Algebra.Additive              as Additive++import qualified MathObj.Polynomial as Poly+import qualified Number.Complex     as Complex++import NumericPrelude++-- import qualified Prelude as P+import PreludeBase+++{- * Definition and construction -}++newtype T t y = Cons {decons :: t -> Phase.T t -> y}+++{-# INLINE fromFunction #-}+fromFunction :: (t -> t -> y) -> (T t y)+fromFunction wave =+   Cons (\f p -> wave f (Phase.toRepresentative p))++{- |+Use this function for waves which are sufficiently smooth.+If the Nyquist frequency is exceeded the wave is simply replaced+by a constant zero wave.+-}+{-# INLINE fromWave #-}+fromWave ::+   (Field.C t, Real.C t, Additive.C y) =>+   Wave.T t y -> (T t y)+fromWave wave =+   fromControlledWaveAux (\f -> if abs f >= 1/2 then zero else wave)++{-# INLINE fromControlledWave #-}+fromControlledWave ::+   (Field.C t, Real.C t, Additive.C y) =>+   (t -> Wave.T t y) -> (T t y)+fromControlledWave wave =+   fromControlledWaveAux (\f0 ->+      let f = abs f0+      in  if f >= 1/2+            then zero+            else wave f)++{-# INLINE fromControlledWaveAux #-}+fromControlledWaveAux :: (t -> Wave.T t y) -> (T t y)+fromControlledWaveAux wave =+   Cons (\f p -> Wave.apply (wave f) p)+++{- * Operations on waves -}++{-# INLINE raise #-}+raise :: (Additive.C y) => y -> T t y -> T t y+raise y = distort (y+)++{-# INLINE amplify #-}+amplify :: (Ring.C y) => y -> T t y -> T t y+amplify k = distort (k*)++{-# INLINE distort #-}+distort :: (y -> z) -> T t y -> T t z+distort g (Cons w) = Cons (\f p -> g (w f p))++{-# INLINE apply #-}+apply :: T t y -> (t -> Phase.T t -> y)+apply = decons++++instance Additive.C y => Additive.C (T t y) where+   {-# INLINE zero #-}+   {-# INLINE (+) #-}+   {-# INLINE (-) #-}+   {-# INLINE negate #-}+   zero = Cons (const zero)+   (+) (Cons w) (Cons v) = Cons (\f p -> w f p + v f p)+   (-) (Cons w) (Cons v) = Cons (\f p -> w f p - v f p)+   negate = distort negate+++instance Module.C a y => Module.C a (T t y) where+   {-# INLINE (*>) #-}+   s *> w = distort (s*>) w+++++{- * Examples -}++{- ** unparameterized -}++{- | map a phase to value of a sine wave -}+{-# INLINE sine #-}+sine :: (Trans.C a, Real.C a) => T a a+sine = fromWave Wave.sine++{-# INLINE cosine #-}+cosine :: (Trans.C a, Real.C a) => T a a+cosine = fromWave Wave.cosine+++{- | saw tooth,+it's a ramp down in order to have a positive coefficient for the first partial sine+-}+{-# INLINE saw #-}+saw :: (Real.C a, Field.C a) => T a a+saw =+   fromControlledWave (\f -> Wave.triangleAsymmetric (2*f-1))+++{- | square -}+{-# INLINE square #-}+square :: (Real.C a, Field.C a) => T a a+square =+   fromControlledWave (\f -> Wave.trapezoid (1-2*f))+++{- | triangle -}+{-# INLINE triangle #-}+triangle :: (Real.C a, Field.C a) => T a a+triangle = fromWave Wave.triangle++++{- |+Specify the wave by its harmonics.++The function is implemented quite efficiently+by applying the Horner scheme to a polynomial with complex coefficients+(the harmonic parameters)+using a complex exponential as argument.+-}+{-# INLINE composedHarmonics #-}+composedHarmonics :: (Trans.C a, Real.C a) => [Wave.Harmonic a] -> T a a+composedHarmonics hs =+   let c = map (\h -> Complex.fromPolar (Wave.harmonicAmplitude h)+                   (2*pi * Phase.toRepresentative (Wave.harmonicPhase h))) hs+       -- @take (ceiling (1/(2*f)))@ would fail for small @f@ especially @f==zero@+       trunc f =+          map snd . takeWhile ((<1/2) . fst) . zip (iterate (abs f +) zero)+   in  fromControlledWaveAux $ \f ->+          Wave.distort+             (Complex.imag . Poly.evaluate (Poly.fromCoeffs (trunc f c)))+             Wave.helix+{-+GNUPlot.plotFunc [] (GNUPlot.linearScale 1000 (0,1::Double)) (composedHarmonics [harmonic 0 0, harmonic 0 0, harmonic 0 0, harmonic 0.25 1])+-}
+ src/Synthesizer/Causal/Displacement.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE NoImplicitPrelude #-}+module Synthesizer.Causal.Displacement where++import qualified Synthesizer.Causal.Process as Causal++import qualified Algebra.Additive              as Additive++import qualified Prelude as P+import PreludeBase+import NumericPrelude+++{- * Mixing -}++{-|+Mix two signals.+Unfortunately we have to use 'zipWith' semantic here,+that is the result is as long as the shorter of both inputs.+-}+{-# INLINE mix #-}+mix :: (Additive.C v) => Causal.T (v,v) v+mix = Causal.map (uncurry (+))+++{-|+Add a number to all of the signal values.+This is useful for adjusting the center of a modulation.+-}+{-# INLINE raise #-}+raise :: (Additive.C v) => v -> Causal.T v v+raise x = Causal.map (x+)+++{- * Distortion -}+{-|+In "Synthesizer.Basic.Distortion" you find a collection+of appropriate distortion functions.+-}+{-# INLINE distort #-}+distort :: (c -> a -> a) -> Causal.T (c,a) a+distort f = Causal.map (uncurry f)
+ src/Synthesizer/Causal/Interpolation.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE NoImplicitPrelude #-}+module Synthesizer.Causal.Interpolation (+   Interpolation.T,++   relative,+   relativeZeroPad,+   relativeConstantPad,+   relativeCyclicPad,+   relativeExtrapolationPad,+   relativeZeroPadConstant,+   relativeZeroPadLinear,+   relativeZeroPadCubic,+   ) where++import qualified Synthesizer.Interpolation.Module as IpExample+import qualified Synthesizer.Interpolation as Interpolation+import qualified Synthesizer.State.Interpolation as InterpolationS++import qualified Synthesizer.Causal.Process as Causal+import qualified Synthesizer.State.Signal   as Sig++import qualified Algebra.Module    as Module+import qualified Algebra.RealField as RealField+import qualified Algebra.Additive  as Additive++import Algebra.Additive(zero)+++import PreludeBase+import NumericPrelude+++{-* Interpolation at multiple nodes with various padding methods -}++{- | All values of frequency control must be non-negative. -}+{-# INLINE relative #-}+relative :: (RealField.C t) =>+   Interpolation.T t y -> t -> Sig.T y -> Causal.T t y+relative ip phase0 x0 =+   Causal.crochetL+      (\freq pos ->+          let (phase,x) = InterpolationS.skip ip pos+          in  Just (Interpolation.func ip phase x, (phase+freq,x)))+      (phase0,x0)+++{-# INLINE relativeZeroPad #-}+relativeZeroPad :: (RealField.C t) =>+   y -> Interpolation.T t y -> t -> Sig.T y -> Causal.T t y+relativeZeroPad z ip phase x =+   InterpolationS.zeroPad relative z ip phase x++{-# INLINE relativeConstantPad #-}+relativeConstantPad :: (RealField.C t) =>+   Interpolation.T t y -> t -> Sig.T y -> Causal.T t y+relativeConstantPad ip phase x =+   InterpolationS.constantPad relative ip phase x++{-# INLINE relativeCyclicPad #-}+relativeCyclicPad :: (RealField.C t) =>+   Interpolation.T t y -> t -> Sig.T y -> Causal.T t y+relativeCyclicPad ip phase x =+   InterpolationS.cyclicPad relative ip phase x++{- |+The extrapolation may miss some of the first and some of the last points+-}+{-# INLINE relativeExtrapolationPad #-}+relativeExtrapolationPad :: (RealField.C t) =>+   Interpolation.T t y -> t -> Sig.T y -> Causal.T t y+relativeExtrapolationPad ip phase x =+   InterpolationS.extrapolationPad relative ip phase x+{-+  This example shows pikes, although there shouldn't be any:+   plotList (take 100 $ interpolate (Zero (0::Double)) ipCubic (-0.9::Double) (repeat 0.03) [1,0,1,0.8])+-}++{-* All-in-one interpolation functions -}++{-# INLINE relativeZeroPadConstant #-}+relativeZeroPadConstant ::+   (RealField.C t, Additive.C y) =>+   t -> Sig.T y -> Causal.T t y+relativeZeroPadConstant =+   relativeZeroPad zero IpExample.constant++{-# INLINE relativeZeroPadLinear #-}+relativeZeroPadLinear ::+   (RealField.C t, Module.C t y) =>+   t -> Sig.T y -> Causal.T t y+relativeZeroPadLinear =+   relativeZeroPad zero IpExample.linear++{-# INLINE relativeZeroPadCubic #-}+relativeZeroPadCubic ::+   (RealField.C t, Module.C t y) =>+   t -> Sig.T y -> Causal.T t y+relativeZeroPadCubic =+   relativeZeroPad zero IpExample.cubic+
+ src/Synthesizer/Causal/Oscillator.hs view
@@ -0,0 +1,220 @@+{-# LANGUAGE NoImplicitPrelude #-}+{- |+Copyright   :  (c) Henning Thielemann 2006+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes++Tone generators+-}+module Synthesizer.Causal.Oscillator where++import qualified Synthesizer.Basic.WaveSmoothed as WaveSmooth+import qualified Synthesizer.Basic.Wave         as Wave+import qualified Synthesizer.Basic.Phase        as Phase++import qualified Synthesizer.Causal.Process as Causal+import qualified Synthesizer.State.Signal as Sig++import qualified Synthesizer.Causal.Interpolation as InterpolationC+import qualified Synthesizer.Causal.ToneModulation as ToneMod+import qualified Synthesizer.Interpolation as Interpolation++import qualified Synthesizer.Generic.Signal as SigG++import Synthesizer.State.ToneModulation (freqsToPhases, )++{-+import qualified Algebra.RealTranscendental    as RealTrans+import qualified Algebra.Field                 as Field+import qualified Algebra.Module                as Module+import qualified Algebra.VectorSpace           as VectorSpace++import Algebra.Module((*>))+-}+import qualified Algebra.Transcendental        as Trans+import qualified Algebra.RealField             as RealField+import qualified Algebra.Ring                  as Ring+import qualified Algebra.Additive              as Additive++import Control.Arrow ((^<<), (<<^), (<<<), (&&&), (***), second, returnA, )++import NumericPrelude++import qualified Prelude as P+import PreludeBase++++{- * Oscillators with arbitrary but constant waveforms -}++{-# INLINE freqToPhases #-}+freqToPhases :: RealField.C a =>+   Phase.T a -> a -> Sig.T (Phase.T a)+freqToPhases phase freq =+   Sig.iterate (Phase.increment freq) phase+++{-+{-# INLINE static #-}+{- | oscillator with constant frequency -}+static :: (RealField.C a) =>+    Wave.T a b -> (Phase.T a -> a -> Sig.T b)+static wave phase freq =+    Sig.map (Wave.apply wave) (freqToPhases phase freq)+-}+++{-# INLINE phaseMod #-}+{- | oscillator with modulated phase -}+phaseMod :: (RealField.C a) =>+    Wave.T a b -> a -> Causal.T a b+phaseMod wave = shapeMod (Wave.phaseOffset wave) zero++{-# INLINE shapeMod #-}+{- | oscillator with modulated shape -}+shapeMod :: (RealField.C a) =>+    (c -> Wave.T a b) -> Phase.T a -> a -> Causal.T c b+shapeMod wave phase freq =+    Causal.applySnd+       (Causal.map (uncurry (Wave.apply . wave)))+       (freqToPhases phase freq)+++{-# INLINE freqMod #-}+{- | oscillator with modulated frequency -}+freqMod :: (RealField.C a) =>+    Wave.T a b -> Phase.T a -> Causal.T a b+freqMod wave phase =+    Causal.map (Wave.apply wave) <<< freqsToPhases phase++{-# INLINE freqModAntiAlias #-}+{- | oscillator with modulated frequency -}+freqModAntiAlias :: (RealField.C a) =>+    WaveSmooth.T a b -> Phase.T a -> Causal.T a b+freqModAntiAlias wave phase =+    Causal.map (uncurry (WaveSmooth.apply wave)) <<<+    returnA &&& freqsToPhases phase++{-# INLINE phaseFreqMod #-}+{- | oscillator with both phase and frequency modulation -}+phaseFreqMod :: (RealField.C a) =>+    Wave.T a b -> Causal.T (a,a) b+phaseFreqMod wave = shapeFreqMod (Wave.phaseOffset wave) zero++{-# INLINE shapeFreqMod #-}+{- | oscillator with both shape and frequency modulation -}+shapeFreqMod :: (RealField.C a) =>+    (c -> Wave.T a b) -> Phase.T a -> Causal.T (c,a) b+shapeFreqMod wave phase =+    Causal.map (uncurry (Wave.apply . wave)) <<<+    second (freqsToPhases phase)+++{-+{- | oscillator with a sampled waveform with constant frequency+     This essentially an interpolation with cyclic padding. -}+{-# INLINE staticSample #-}+staticSample :: RealField.C a =>+    Interpolation.T a b -> Sig.T b -> Phase.T a -> a -> Sig.T b+staticSample ip wave phase freq =+    Causal.apply (freqModSample ip wave phase) (Sig.repeat freq)+-}++{- | oscillator with a sampled waveform with modulated frequency+     Should behave homogenously for different types of interpolation. -}+{-# INLINE freqModSample #-}+freqModSample :: RealField.C a =>+    Interpolation.T a b -> Sig.T b -> Phase.T a -> Causal.T a b+freqModSample ip wave phase =+    let len = Sig.length wave+        pr  = fromIntegral len * Phase.toRepresentative phase+    in  InterpolationC.relativeCyclicPad ip pr wave+          <<< Causal.map (fromIntegral len *)+++{-# INLINE shapeFreqModSample #-}+shapeFreqModSample :: (RealField.C c, RealField.C b) =>+    Interpolation.T c (Wave.T b a) -> Sig.T (Wave.T b a) ->+    c -> Phase.T b ->+    Causal.T (c, b) a+shapeFreqModSample ip waves shape0 phase =+    uncurry Wave.apply ^<<+       (InterpolationC.relativeConstantPad ip shape0 waves ***+        freqsToPhases phase)++{-# INLINE shapeFreqModFromSampledTone #-}+shapeFreqModFromSampledTone ::+    (RealField.C t, SigG.Transform sig y) =>+    Interpolation.T t y ->+    Interpolation.T t y ->+    t -> sig y ->+    t -> Phase.T t ->+    Causal.T (t,t) y+shapeFreqModFromSampledTone+      ipLeap ipStep period sampledTone shape0 phase =+   uncurry (ToneMod.interpolateCell ipLeap ipStep) ^<<+   ToneMod.oscillatorCells+      (Interpolation.margin ipLeap) (Interpolation.margin ipStep)+      (round period) period sampledTone+      (shape0, phase)++{-# INLINE shapePhaseFreqModFromSampledTone #-}+shapePhaseFreqModFromSampledTone ::+    (RealField.C t, SigG.Transform sig y) =>+    Interpolation.T t y ->+    Interpolation.T t y ->+    t -> sig y ->+    t -> Phase.T t ->+    Causal.T (t,t,t) y+shapePhaseFreqModFromSampledTone+      ipLeap ipStep period sampledTone shape0 phase =+   let periodInt = round period+       marginLeap = Interpolation.margin ipLeap+       marginStep = Interpolation.margin ipStep+   in  (\(dp, ((s,p), suffix)) ->+          uncurry (ToneMod.interpolateCell ipLeap ipStep) $+          ToneMod.seekCell periodInt period $+          ((s, Phase.increment dp p), suffix))+       ^<<+       Causal.second+          (ToneMod.oscillatorSuffixes+             marginLeap marginStep+             periodInt period sampledTone+             (shape0, phase))+       <<^+       (\(s,p,f) -> (p,(s,f)))+++{- * Oscillators with specific waveforms -}++{-+{-# INLINE staticSine #-}+{- | sine oscillator with static frequency -}+staticSine :: (Trans.C a, RealField.C a) => Phase.T a -> a -> Sig.T a+staticSine = static Wave.sine+-}++{-# INLINE freqModSine #-}+{- | sine oscillator with modulated frequency -}+freqModSine :: (Trans.C a, RealField.C a) => Phase.T a -> Causal.T a a+freqModSine = freqMod Wave.sine++{-# INLINE phaseModSine #-}+{- | sine oscillator with modulated phase, useful for FM synthesis -}+phaseModSine :: (Trans.C a, RealField.C a) => a -> Causal.T a a+phaseModSine = phaseMod Wave.sine++{-+{-# INLINE staticSaw #-}+{- | saw tooth oscillator with modulated frequency -}+staticSaw :: RealField.C a => Phase.T a -> a -> Sig.T a+staticSaw = static Wave.saw+-}++{-# INLINE freqModSaw #-}+{- | saw tooth oscillator with modulated frequency -}+freqModSaw :: RealField.C a => Phase.T a -> Causal.T a a+freqModSaw = freqMod Wave.saw
+ src/Synthesizer/Causal/ToneModulation.hs view
@@ -0,0 +1,235 @@+module Synthesizer.Causal.ToneModulation (+   ToneModS.interpolateCell,+   seekCell,+   oscillatorCells,+   oscillatorSuffixes,+   integrateFractional,+   integrateFractionalClip,+   -- for testing+   limitRelativeShapes,+   limitMinRelativeValues,+   ) where++import qualified Synthesizer.Basic.ToneModulation as ToneMod+import qualified Synthesizer.State.ToneModulation as ToneModS+import qualified Synthesizer.Interpolation as Interpolation++import Synthesizer.State.ToneModulation (freqsToPhases, freqsToPhasesSync, )++{- for testing in GHCi+import qualified Synthesizer.Plain.ToneModulation as ToneModL+import qualified Synthesizer.State.Signal as SigS+import Data.Tuple.HT (mapFst, mapSnd, swap, )+-}+import Data.Tuple.HT (mapFst, )++import qualified Synthesizer.Causal.Process as Causal++import qualified Synthesizer.Generic.Signal as SigG++import qualified Synthesizer.Basic.Phase as Phase++-- import qualified Algebra.Transcendental        as Trans+import qualified Algebra.RealField             as RealField+-- import qualified Algebra.Field                 as Field+-- import qualified Algebra.Real                  as Real+import qualified Algebra.Ring                  as Ring+import qualified Algebra.Additive              as Additive++import Control.Arrow (first, (<<<), (<<^), (^<<), (&&&), (***), )+import Control.Monad.Trans.State (state, )++import NumericPrelude+-- import qualified Prelude as P+import PreludeBase+import Prelude ()++++oscillatorCells :: (RealField.C t, SigG.Transform sig y) =>+    Interpolation.Margin ->+    Interpolation.Margin ->+    Int -> t -> sig y -> (t, Phase.T t) ->+    Causal.T (t,t) ((t,t), ToneModS.Cell sig y)+oscillatorCells+       marginLeap marginStep periodInt period sampledTone (shape0, phase) =+    seekCell periodInt period+     ^<< oscillatorSuffixes marginLeap marginStep+            periodInt period sampledTone (shape0, phase)+{-+*Synthesizer.Causal.ToneModulation> let shapes = [0.3,2.4,0.2,2.1,1.2,1.5::Double]; phases = [0.43,0.72,0.91,0.37,0.42,0.22::Double]+*Synthesizer.Causal.ToneModulation> let marginLeap = Interpolation.Margin 3 1; marginStep = Interpolation.Margin 2 0+*Synthesizer.Causal.ToneModulation> mapM_ (print . mapSnd List.transpose) $ ToneModL.oscillatorCells marginLeap marginStep 5 5.3 ['a'..'z'] (2.3,shapes) (Phase.fromRepresentative 0.6, phases)+*Synthesizer.Causal.ToneModulation> mapM_ print $ SigS.toList $ oscillatorCells marginLeap marginStep 5 5.3 ['a'..'z'] (2.3, Phase.fromRepresentative 0.6) `Causal.apply` (SigS.fromList $ List.zip shapes phases)+-}+++seekCell :: (RealField.C t, SigG.Transform sig y) =>+    Int -> t ->+    ((t, Phase.T t), sig y) ->+    ((t,t), ToneModS.Cell sig y)+seekCell periodInt period =+    {-+    n will be zero within the data body.+    It's only needed for extrapolation at the end.+    Is it really needed?+    -}+    (\(sp,ptr) ->+       let (k,q) = ToneMod.flattenShapePhase periodInt period sp+       in  (q, ToneModS.makeCell periodInt $+               SigG.drop (ToneModS.checkNonNeg $ periodInt+k) ptr))+++{- |+In contrast to the counterpart of this function for plain lists,+it does not use sophisticated list transposition tricks,+but seeks through the prototype signal using 'drop'.+Since 'drop' is used in an inner loop, it must be fast.+This is true for StorableVectors.+-}+oscillatorSuffixes :: (RealField.C t, SigG.Transform sig y) =>+    Interpolation.Margin ->+    Interpolation.Margin ->+    Int -> t ->+    sig y -> (t, Phase.T t) ->+    Causal.T (t,t) ((t, Phase.T t), sig y)+oscillatorSuffixes+       marginLeap marginStep periodInt period sampledTone (shape0, phase) =+    let margin =+           ToneMod.interpolationNumber marginLeap marginStep periodInt+        ipOffset =+           periodInt ++           ToneMod.interpolationOffset marginLeap marginStep periodInt+        (shape0min, shapeLimiter) =+           limitMinRelativeValues (fromIntegral ipOffset) shape0+        ((skip0,coord0), coordinator) =+           integrateFractional period (shape0min, phase)+    in  (\(((b,n),ptr), sp@(_,p)) ->+           (if b+              then (zero, Phase.increment (fromIntegral n / period) p)+              else sp,+            ptr))+        ^<<+        (Causal.scanL+           (\ ((_,n),ptr) d -> dropMargin margin (n+d) ptr)+           (dropMargin margin (skip0 - ipOffset) sampledTone)+         ***+         Causal.consInit coord0)+        <<<+        coordinator+        <<<+        Causal.first shapeLimiter+{-+*Synthesizer.Causal.ToneModulation> let shapes = replicate 10 (2.6::Double); phases = cycle [0.43,0.72,0.91,0.37,0.42,0.22::Double]+*Synthesizer.Causal.ToneModulation> let marginLeap = Interpolation.Margin 3 1; marginStep = Interpolation.Margin 2 0+*Synthesizer.Causal.ToneModulation> mapM_ (print . swap . mapSnd (mapSnd (map head))) $ ToneModL.oscillatorSuffixes marginLeap marginStep 5 5.3 ['a'..'z'] (2.3,shapes) (Phase.fromRepresentative 0.6, phases)+*Synthesizer.Causal.ToneModulation> mapM_ print $ SigS.toList $ oscillatorSuffixes marginLeap marginStep 5 5.3 ['a'..'z'] (2.3, Phase.fromRepresentative 0.6) `Causal.apply` (SigS.fromList $ List.zip shapes phases)+-}++{- ToDo:+Both lengthAtMost and dropMarginRem seek through the list.+Maybe an improved version of dropMargin could avoid this.+E.g. dropMarginRem :: dropMarginRem :: Int -> Int -> sig y -> (Maybe Int, sig y),+where return value (Just 0) means,+that drop could actually drop the requested number of elements,+but that we reached the end of the list.+-}+dropMargin :: (SigG.Transform sig y) =>+   Int -> Int -> sig y -> ((Bool, Int), sig y)+dropMargin margin n xs =+   mapFst ((,) (SigG.lengthAtMost (margin+n) xs)) $+   SigG.dropMarginRem margin+      (ToneModS.checkNonNeg n) xs++regroup :: (Int,t) -> Phase.T t -> ToneMod.Skip t+regroup (d,s) p = (d, (s,p))++integrateFractional :: (RealField.C t) =>+    t ->+    (t, Phase.T t) ->+    (ToneMod.Skip t, Causal.T (t,t) (ToneMod.Skip t))+integrateFractional period (shape0, phase) =+    let sf0 = splitFraction shape0+        -- shapeOffsets :: RealField.C t => Causal.T t (Int,t)+        shapeOffsets =+           Causal.fromState+              (\c -> state $ \s0 ->+                 let s1 = splitFraction (s0+c)+                 in  (s1, snd s1))+              (snd sf0)+        scale (n,_) = fromIntegral n / period+        -- phases :: RealField.C t => Causal.T ((Int,t), t) (Phase.T t)+        phase0 = Phase.decrement (scale sf0) phase+        phases =+           freqsToPhasesSync phase0+              <<^ (\(s,f) -> f - scale s)+    in  (regroup sf0 phase0,+         uncurry regroup+         ^<<+         (Causal.map fst &&& phases)+         <<<+         first shapeOffsets)++{- |+Delays output by one element and shorten it by one element at the end.+-}+integrateFractionalClip :: (RealField.C t) =>+    t ->+    (t, Phase.T t) ->+    Causal.T (t,t) (ToneMod.Skip t)+integrateFractionalClip period (shape0, phase) =+    let sf0 = splitFraction shape0+        -- shapeOffsets :: RealField.C t => Causal.T t (Int,t)+        shapeOffsets =+           Causal.fromState+              (\c -> state $ \s0 ->+                 let s1 = splitFraction (s0+c)+                 in  (s1, snd s1))+              (snd sf0)+        scale (n,_) = fromIntegral n / period+        -- phases :: RealField.C t => Causal.T ((Int,t), t) (Phase.T t)+        phases =+           freqsToPhases+              (Phase.decrement (scale sf0) phase)+              <<^ (\(s,f) -> f - scale s)+    in  uncurry regroup+        ^<<+        ((Causal.consInit sf0 <<^ fst) &&& phases)+        <<<+        first shapeOffsets+{-+test to automate:+*Synthesizer.Generic.ToneModulation> let shapes = [0.3,0.4,0.2::Double]; phases = [0.43,0.72,0.91::Double]+*Synthesizer.Generic.ToneModulation> ToneMod.oscillatorCoords 9 10 (2.3,shapes) (Phase.fromRepresentative 0.6, phases)+[(2,(-6,(0.63,0.6299999999999999))),(0,(-2,(0.22999999999999998,0.53))),(0,(-4,(0.5500000000000002,4.9999999999998934e-2))),(1,(-6,(0.6600000000000001,0.2599999999999989)))]++*Synthesizer.Generic.ToneModulation> ToneModS.oscillatorCoords 9 10 (2.3, SigS.fromList shapes) (Phase.fromRepresentative 0.6, SigS.fromList phases)+StateSignal.fromList [(2,(-6,(0.63,0.6299999999999999))),(0,(-2,(0.22999999999999998,0.53))),(0,(-4,(0.5500000000000002,4.9999999999998934e-2)))]++*Synthesizer.Generic.ToneModulation> Data.Tuple.HT.mapSnd (flip Causal.apply $ SigS.fromList (zip shapes phases)) $ oscillatorCoords 9 10 (2.3, Phase.fromRepresentative 0.6)+((2,(-6,(0.63,0.6299999999999999))),StateSignal.fromList [(0,(-2,(0.22999999999999998,0.53))),(0,(-4,(0.5500000000000002,4.9999999999998934e-2))),(1,(-6,(0.6600000000000001,0.2599999999999989)))])++*Synthesizer.Generic.ToneModulation> oscillatorCoords' 9 10 (2.3, Phase.fromRepresentative 0.6) `Causal.apply` SigS.fromList (zip shapes phases)+StateSignal.fromList [(2,(-6,(0.63,0.6299999999999999))),(0,(-2,(0.22999999999999998,0.53))),(0,(-4,(0.5500000000000002,4.9999999999998934e-2)))]+-}++limitRelativeShapes :: (Ring.C t, Ord t) =>+    Interpolation.Margin ->+    Interpolation.Margin ->+    Int -> t -> (t, Causal.T t t)+limitRelativeShapes marginLeap marginStep periodInt =+    limitMinRelativeValues $ fromIntegral $+    ToneMod.interpolationOffset marginLeap marginStep periodInt + periodInt++limitMinRelativeValues :: (Additive.C t, Ord t) =>+   t -> t -> (t, Causal.T t t)+limitMinRelativeValues xMin x0 =+   let x1 = xMin-x0+   in  if x1<=zero+         then (x0, Causal.id)+         else (xMin,+               Causal.crochetL+                  (\x lim ->+                     let d = x-lim+                     in  Just $ if d>=zero+                           then (d,zero) else (zero, negate d)) x1)
+ src/Synthesizer/Filter/Basic.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+module Synthesizer.Filter.Basic where++import qualified Algebra.Transcendental as Trans+import qualified Algebra.Module         as Module+import qualified Algebra.RealField      as RealField+import qualified Number.Complex         as Complex++import NumericPrelude+import PreludeBase++{- todo:+    - support of data before time 0+       - the problem is that all past data has to be kept,+         the garbage collector can't flush it :-(+       - this means we will also need functions for plain lists,+         in this case we can't provide initial conditions to recursive filters+       - the question of initial conditions is especially problematic+         since for Graphs we have no explicit feed back+         where initial conditions can be plugged in+       - thus for two-way signal we must request the user+         to insert initial conditions in every loop of a Graph+         using the Past constructor+    - all of the following filter primitives in static and modulated form:+       - mask+       - integer delay+       - fractional delay+          - shall the fractional delay constructor store the interpolation type?+            (this discussion is similar to the one concerning+             initial conditions for recursive filters)+             - yes, because each delay may use a different interpolation type,+                    if no fractional delay is used,+                     no interpolation type needs to be specified+             - no, because the interpolation is only of interest for filter+                   application not for the transfer function+    - Is there a way to avoid the multi-parameter type class?+       - Can we provide a class for lists (OneWay and TwoWay)+         that help implementing filters and filter networks?+       - The 'transferFunction' obviously does not depend on the signal list type.+    - 'transferFunction' should not be restricted to complex numbers.+       - For arguments of type 'Ratio (Polynomial Rational)'+         you could compute the transfer function in terms of a rational function.+-}++screw :: Trans.C a => a -> [Complex.T a]+screw w = iterate (Complex.cis w *) 1+++class Filter list filter | filter -> list where+   {-| Apply a filter to a signal. -}+   apply :: (RealField.C t, Trans.C t,+             Module.C a v, Module.C a (list v)) =>+               filter t a v -> list v -> list v+   {-| Compute the complex amplification factor+       that is applied to the given frequency. -}+   transferFunction :: (Trans.C t, Module.C a t) =>+               filter t a v -> t -> Complex.T t
+ src/Synthesizer/Filter/Composition.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+module Synthesizer.Filter.Composition where++import qualified Synthesizer.Filter.Basic as FilterBasic+import Synthesizer.Filter.Basic (Filter, apply, )++import qualified Algebra.Module         as Module+import qualified Algebra.Transcendental as Trans+import qualified Algebra.RealField      as RealField+import qualified Algebra.Field          as Field+import qualified Algebra.Additive       as Additive+import qualified Number.Complex         as Complex++import Algebra.Additive ((+))++import PreludeBase+import NumericPrelude++{- todo:+    - functions that build a FilterComposition for specific filters+        (1st order, universal, allpass, butterworth, chebyshev)+    - functions that turn physical filter parameters into+        internal ones+    - How can these function be combined?+      A function like+         [ FilterComposition v [m] ] -> FilterComposition v [[m]]+      is not satisfying, since the conversion function cannot rely+      that the structure of all FilterComposition v [m] is equal.+      If the list is empty the structure can't even be reconstructed.+-}++{-|+  This describes a generic filter with one input and one main output+  that consists of non-recursive and recursive parts.+  If you use Feedback, make sure that at least+  one of the filters of a circle includes a delay,+  otherwise the recursion will fail.+  The main output is used to glue different parts together.+  Additionally the functions 'apply' and 'transferFunction'+  provide the signals at every node of the network.+-}+data T filter t a v =+     Prim (filter t a v)+       {-^ a filter primitve -}+   | Serial   [T filter t a v]+       {-^ serial chain of filters -}+   | Parallel [T filter t a v]+       {-^ filters working parallel, there output is mixed together -}+   | Feedback (T filter t a v) (T filter t a v)+       {-^ filter the signal in the forward direction and+           feed back the output signal filtered by the second filter -}++{-|+  This is the data structure is used for the results+  of 'apply' and 'transferFunction'.+  Each constructor corresponds to one of 'Filter.Composition.T'.+  By choosing only some of the outputs+  the lazy evaluation will content+  with applying the necessary filter steps, only.+-}+data Sockets s = Sockets {output :: s, socket :: SocketSpec s}++data SocketSpec s =+     Output+   | Multiplier [Sockets s]+   | Adder [Sockets s]+   | Loop (Sockets s) (Sockets s)++instance (Filter list filter) =>+      Filter (list) (T filter) where+{-+   apply :: (Module.C a v) =>+      FilterComposition a v -> TwoWayList v -> TwoWayList v+-}+   apply f x = output (applyMulti f x)+{-+   transferFunction :: (Trans.C b, Module.C a (Complex.T b)) =>+      T filter a v -> b -> (Complex.T b)+-}+   transferFunction f w = output (transferFunctionMulti f w)+++{-| Apply a filter network to a signal and keep the output of all nodes.+    Generic function that is wrapped by 'apply'. -}+applyMulti :: (RealField.C t, Trans.C t,+      Module.C a v, Module.C a (list v), Filter list filter) =>+   T filter t a v -> list v -> Sockets (list v)+applyMulti (Prim f) x =+   Sockets (apply f x) Output+applyMulti (Serial fs) x =+   let sq = scanl (\(Sockets y _) -> flip applyMulti y) (Sockets x Output) fs+   in  Sockets (output (last sq)) (Multiplier (tail sq))+applyMulti (Parallel fs) x =+   let socks = map (flip applyMulti x) fs+       y = foldr (Additive.+) zero (map output socks)+   in  Sockets y (Adder socks)+{- the distinction between 'feed' and 'back'+   can be dropped in a more general net structure -}+applyMulti (Feedback feed back) x =+   let sockY@(Sockets y _) = applyMulti feed ((Additive.+) x z)+       sockZ@(Sockets z _) = applyMulti back y+   in  Sockets y (Loop sockY sockZ)+++transferFunctionMulti ::+   (Trans.C t, Module.C a t, Filter list filter) =>+      T filter t a v -> t -> Sockets (Complex.T t)+transferFunctionMulti f w = tfAbsolutize 1 (tfRelative w f)++{-| Compute the transitivity for each part of the filter network.+    We must do this in such a relative manner to be able+    to compute feedback. -}+tfRelative ::+   (Trans.C t, Module.C a t, Filter list filter) =>+      t -> T filter t a v -> Sockets (Complex.T t)+tfRelative w (Prim f) =+   Sockets (FilterBasic.transferFunction f w) Output+tfRelative w (Serial fs) =+   let sq = map (tfRelative w) fs+   in  Sockets (product (map output sq)) (Multiplier sq)+tfRelative w (Parallel fs) =+   let sq = map (tfRelative w) fs+   in  Sockets (sum (map output sq)) (Adder sq)+tfRelative w (Feedback feed back) =+   let sockY = tfRelative w feed+       sockZ = tfRelative w back+       q = output sockY / (1 - output sockZ)+   in  Sockets q (Loop sockY sockZ)+++{-| Make the results from 'tfRelative' absolute. -}+tfAbsolutize :: (Field.C a) => a -> Sockets a -> Sockets a+tfAbsolutize x (Sockets y spec) = Sockets (x*y)+   (case spec of+      (Multiplier socks) ->+         let sq = scanl (\(Sockets z _) -> tfAbsolutize z)+                        (Sockets x Output) socks+         in  Multiplier (tail sq)+      (Adder socks) ->+         let sq = map (tfAbsolutize x) socks+         in  Adder sq+      (Loop feed back) ->+         let sockY = tfAbsolutize (x / (1 - output back)) feed+             sockZ = tfAbsolutize (output sockY) back+             -- it should be  x*y == output sockY+         in  Loop sockY sockZ+      Output -> spec)
+ src/Synthesizer/Filter/Example.hs view
@@ -0,0 +1,243 @@+{-# LANGUAGE NoImplicitPrelude #-}+module Synthesizer.Filter.Example where++import qualified Synthesizer.Filter.OneWay as OneWay+import qualified Synthesizer.Filter.TwoWay as TwoWay+import qualified Synthesizer.Filter.Composition as Composition+import qualified Synthesizer.Filter.Graph as Graph+import qualified Synthesizer.Plain.Interpolation as Interpolation++import Synthesizer.Filter.Basic (apply, )+import Synthesizer.Filter.Composition (T(..))++import qualified Synthesizer.Plain.Oscillator as Osci+import qualified Synthesizer.Basic.Wave       as Wave+import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1+import qualified Synthesizer.Plain.Filter.NonRecursive as FiltNR++import qualified Algebra.Module         as Module+import qualified Algebra.Transcendental as Trans+import qualified Algebra.RealField      as RealField+import qualified Algebra.Field          as Field+import qualified Algebra.Real           as Real++import Data.Maybe (fromMaybe)++import PreludeBase+import NumericPrelude++++{-* Reconstruction of the sound of a plucked guitar string -}++guitarInit :: Field.C a => [a]+guitarInit = map (/128) (+      1 :    1 :    1 :    1 :    1 :    1 :    1 :    1 :+      1 :    2 :    2 :    2 :    2 :    2 :    2 :    2 :+      2 :    2 :    2 :    2 :    2 :    2 :    2 :    2 :+      2 :    2 :    2 :    3 :    3 :    3 :    3 :    3 :+      3 :    3 :    3 :    3 :    3 :    3 :    3 :    3 :+      3 :    3 :    3 :    4 :    4 :    4 :    4 :    4 :+      4 :    4 :    4 :    4 :    4 :    4 :    4 :    4 :+      5 :    5 :    5 :    5 :    5 :    5 :    5 :    5 :+      6 :    6 :    6 :    7 :    7 :    8 :    8 :    9 :+     10 :   11 :   12 :   13 :   14 :   15 :   15 :   16 :+     17 :   17 :   17 :   18 :   18 :   18 :   18 :   18 :+     18 :   18 :   18 :   17 :   17 :   16 :   16 :   15 :+     15 :   14 :   14 :   14 :   13 :   13 :   14 :   14 :+     15 :   16 :   17 :   18 :   19 :   20 :   22 :   23 :+     25 :   27 :   30 :   32 :   35 :   37 :   39 :   41 :+     43 :   45 :   47 :   48 :   49 :   49 :   48 :   46 :+     41 :   34 :   24 :   11 :   -6 :  -26 :  -48 :  -72 :+    -96 : -114 : -128 : -128 : -128 : -128 : -128 : -128 :+   -128 : -125 : -110 :  -93 :  -75 :  -57 :  -41 :  -27 :+    -17 :  -10 :   -6 :   -4 :   -2 :   -2 :   -2 :   -2 :+     -2 :   -3 :   -4 :   -4 :   -5 :   -6 :   -7 :   -8 :+     -9 :  -10 :  -11 :  -12 :  -12 :  -12 :  -13 :  -13 :+    -13 :  -13 :  -13 :  -13 :  -12 :  -12 :  -11 :  -10 :+     -9 :   -9 :   -8 :   -8 :   -7 :   -6 :   -6 :   -5 :+     -5 :   -5 :   -5 :   -4 :   -4 :   -4 :   -4 :   -4 :+     -4 :   -4 :   -4 :   -4 :   -4 :   -5 :   -7 :   -8 :+     -8 :   -9 :  -10 :  -11 :  -12 :  -13 :  -13 :  -14 :+    -14 :  -14 :  -13 :  -10 :   -7 :   -2 :    5 :   15 :+     26 :   37 :   49 :   61 :   73 :   83 :   92 :   99 :+    105 :  109 :  111 :  112 :  110 :  105 :   99 :   90 :+     80 :   71 :   63 :   57 :   52 :   49 :   47 :   47 :+     48 :   49 :   51 :   51 :   52 :   52 :   50 :   48 :+     42 :   34 :   22 :    7 :  -12 :  -32 :  -56 :  -78 :+    -96 : -114 : -127 : -128 : -128 : -128 : -128 : -128 :+   -128 : -118 : -102 :  -83 :  -67 :  -50 :  -37 :  -26 :+    -17 :  -12 :   -8 :   -5 :   -3 :   -3 :   -2 :   -2 :+     -2 :   -3 :   -4 :   -4 :   -6 :   -7 :   -8 :  -10 :+    -11 :  -12 :  -12 :  -13 : [])++guitarCompShort, guitarCompLong ::+   Field.C a => [a] -> Composition.T TwoWay.T Double a a+guitarCompShort past = Feedback (Prim (TwoWay.Past past)) (Parallel [+   Serial [Prim (TwoWay.Delay   1),+           Prim (TwoWay.Mask [0.6519177892575342, 0.2331904728998289])],+   Serial [Prim (TwoWay.Delay 126),+           Prim (TwoWay.Mask [0.08253506238277844,+               0.2369601607320473,   0.18367848836060044,+              -0.06422525077173147, -0.31836517142623727])]])+guitarCompLong past = Feedback (Prim (TwoWay.Past past)) (+   Serial [Prim (TwoWay.Delay 122),+           Prim (TwoWay.Mask [+              -0.23742303494466988,+               0.020278040917954415,+               0.12495333789385828,+               0.16125537461091102,+               0.1993410924766678,+               0.24673057006071691,+               0.25438881375430467,+               0.1424676847770117,+               0.03848071949084291,+              -0.016618282409355676,+              -0.04517323927531556,+              -0.0061713683480988475,+               0.11137126130878339+             ])])++{-| Reconstruct the guitar sound from the sampled initial wave+    and the analysed feedback factors.+    This sounds pretty like the sampled sound. -}+guitarRaw :: (Field.C a, Module.C a a) => [a]+guitarRaw =+   let gi = guitarInit  -- assert monomorphism+       y = TwoWay.future+              (TwoWay.delay (length gi)+                 (apply (guitarCompLong (reverse gi))+                        (TwoWay.Signal [] [])))+   in  y++{-| Reconstruct the guitar sound from the sampled initial wave+    but with simple smoothing on feedback.+    This sounds more statically. -}+guitarRawSimple :: (Field.C a, Module.C a a) => [a]+guitarRawSimple =+   let gi = guitarInit  -- assert monomorphism+       y  = gi ++ drop (length gi)+              (FiltNR.delay 128 (Filt1.lowpass+                 (repeat (Filt1.Parameter (0.4  `asTypeOf` head y))) y))+   in  y++{-| Reconstruct the guitar sound with the analysed feedback factors+    but with an synthetic initial wave.+    The sharpness of the initial wave can be controlled.+    This is used to implement various velocities. -}+guitarRawVelo :: (Real.C a, Trans.C a, Module.C a a) => a -> [a]+guitarRawVelo velo =+   let len  = 128::Int+       wave =+          map (Wave.power01Normed velo)+             (take len (iterate (+ 2 / fromIntegral len) (-1)))+       y = TwoWay.future+              (TwoWay.delay len+                 (apply (guitarCompLong wave)+                        (TwoWay.Signal [] [])))+   in  y+++{-| Resample the reconstructed string sound+    so that notes can be played. -}+guitar :: (RealField.C a, Module.C a a) => a -> [a]+guitar freq =+   let srcFreq = 128 * freq+   in  Interpolation.multiRelativeZeroPadLinear 0+          (repeat (srcFreq `asTypeOf` freq)) guitarRawSimple++++{-* Tests for FilterGraphs -}++type CompositionDouble =+        Composition.T TwoWay.T Double Double Double++{-| a simple lowpass used to create an exponential2 -}+--expo :: (RealField.C a, Module.C a a) => TwoWay.Signal a+expo :: TwoWay.Signal Double+expo =+   let _flt1 = Feedback (Serial [Prim (OneWay.Delay ([0] `asTypeOf` past))])+                       (Serial [Prim (OneWay.Mask+                                        ([0.9] `asTypeOf` past))])+       _flt2 = (Prim (TwoWay.Mask ([0.5] `asTypeOf` past)))+                 :: CompositionDouble+       flt3 = (Feedback (Serial [])+                        (Prim (TwoWay.Delay 1)))+                 :: CompositionDouble+       TwoWay.Signal past future = apply flt3 (TwoWay.Signal [] [1])+   in  TwoWay.Signal past (take 10 future)++type GraphDouble f = Graph.T f Int Double Double Double++simpleGraph :: TwoWay.Signal Double+simpleGraph =+   let out =+          Graph.apply+             (Graph.fromList+                [(0, []),+                 (1, [(0, TwoWay.Delay (-1))]),+                 (2, [(1, TwoWay.Mask [0.95])])] ::+                    GraphDouble TwoWay.T)+             (Graph.signalFromList+                [(0, TwoWay.Signal [] [1])])+   in  fromMaybe (error "requested output of non-existing socket")+                 (Graph.lookupSignal out (2::Int))++expoGraphTwoWay :: [Double]+expoGraphTwoWay =+   let out =+          Graph.apply+             (Graph.fromList+                [(0, [(2, TwoWay.Past [1])]),+                 (1, [(0, TwoWay.Delay 1)]),+                 (2, [(1, TwoWay.Mask [0.95])])] ::+                    GraphDouble TwoWay.T)+             (Graph.signalFromList+                [(0, TwoWay.Signal [] [])])+   in  TwoWay.take 20 $ TwoWay.delay 10+          (fromMaybe (error "requested output of non-existing socket")+             (Graph.lookupSignal out (0::Int)))+++expoGraph :: [Double]+expoGraph =+   let out =+          Graph.apply+             (Graph.fromList+                [(0, [(1, OneWay.Delay [0])]),+                 (1, [(0, OneWay.Mask [0.99])])] ::+                    GraphDouble OneWay.T)+             (Graph.signalFromList+                [(0, [1])])+   in  fromMaybe (error "requested output of non-existing socket")+                 (Graph.lookupSignal out (0::Int))++{-| make recursive flanger with help of the two way interpolation -}+flangedSaw :: Double -> [Double]+flangedSaw sampleRate =+   let {- The flanger's principal filter frequency will vary between+          flangeFreq * 2**flangeRange and flangeFreq / 2**flangeRange -}+       flangeFreq  = 1000+       flangeRange = 2+       sawFreq     = 440+       gain = 0.6+       vol  = 0.5++       {- 'control' contains the feedback times -}+       control  = map (\c -> sampleRate/flangeFreq * 2**(-flangeRange*c))+                      (map sin (iterate (pi/(0.5*sampleRate)+) 0))+       sawPast   = Osci.freqModSaw 0 (repeat (-sawFreq/sampleRate))+       sawFuture = Osci.freqModSaw 0 (repeat ( sawFreq/sampleRate))+       --lowNoise = amplify vol noise+       flt = Feedback+                (Prim (TwoWay.Mask [vol]))+                (Serial [Prim (TwoWay.Mask [gain]),+                         Prim (TwoWay.Past []),+                         Prim (TwoWay.ModFracDelay+                                  Interpolation.linear +                                     (TwoWay.Signal [] control))])+                :: CompositionDouble++   in  TwoWay.future+          (apply flt (TwoWay.Signal sawPast sawFuture))
+ src/Synthesizer/Filter/Fix.hs view
@@ -0,0 +1,38 @@+module Synthesizer.Filter.Fix where++import qualified Synthesizer.Filter.Graph as Graph+++{-|+A 'Graph.T' with numbered nodes is not very comfortable.+Better provide a 'Control.Monad.Fix.fix'-like function+which allows to enter a graph this way:++> fix $ \[v,w,y] ->+> [a·(u + d·w),+>  b·(v + e·y),+>  c· w]++-}++type T filter t a v  =+   [Channel filter t a v] -> [[(Channel filter t a v, filter t a v)]]++type ChannelId = Int++data Channel filter t a v =+   Channel {channelId     :: ChannelId,+            channelInputs :: [(ChannelId, filter t a v)]}+++fix :: T filter t a v -> [Channel filter t a v]+fix f =+   let cs = zipWith (\n inputs ->+               Channel n (map (\(c,filt) -> (channelId c, filt)) inputs))+               [0 ..] (f cs)+   in  cs+++toGraph :: T filter t a v -> Graph.T filter Int t a v+toGraph =+   Graph.fromList . map (\(Channel n inputs) -> (n, inputs)) . fix
+ src/Synthesizer/Filter/Graph.hs view
@@ -0,0 +1,183 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FlexibleContexts #-}+module Synthesizer.Filter.Graph where++import qualified Prelude as P+import PreludeBase+import NumericPrelude++import qualified Synthesizer.Filter.Basic as FilterBasic+import Synthesizer.Filter.Basic (Filter, apply, )+import qualified Data.Map as Map+import Data.Map(Map)+import MathObj.DiscreteMap()  {- Module.C instances for Map -}++import qualified Number.Complex         as Complex+import qualified Algebra.RealField      as RealField+import qualified Algebra.Additive       as Additive+import qualified Algebra.Transcendental as Trans+import qualified Algebra.Module         as Module+import Algebra.Module((*>))+import Orthogonals(Scalar,inverse,add_to_diagonal)+++{-|+A filter network is a graph consisting+of nodes (input and output signals)+and edges (filter processes).+Output signals can be taken from every node,+inputs can be injected in some nodes+which means that the signal at this node is superposed with+the injected signal.+The same can be achieved by duplicating the network,+one duplicate per input,+and superposing the corresponding outputs.+It is also sensible to setup a graph without inputs,+e.g. a recursive filter with some initial conditions+that works independent from any input.++In opposition to electric filter networks+digital filter networks must be directed.++Test-case: leap-frog filters like++>     +-----------[d]-----------++>     v                         |+>(u) -+-> [a] (v) -+-> [b] (w) -+-> [c] (y) -+->+>                  ^                         |+>                  +-----------[e]-----------+++@+v = a·(u + d·w)+w = b·(v + e·y)+y = c· w+@++We model the general network by a list of nodes,+where each node is an adder that holds a list of its inputs.+Each input of a node is an output+of another node that has gone through a processor.+Additionally there may be one input from outside.+In principle a processor could be a simple filter network+as defined by the structure 'Filter'.++The network is an applyable filter+whenever each circle contains a delay.+To compute the transfer function+we have to solve a system of linear equations+which we can construct quite straight forward+from the processors' input lists.++The current design can be abstractly seen+as the system of linear equations:++  y = A*y + u++where A is a matrix containing the edges hosting the filters,+y the vector of output signals,+u the vector of input signals.+In this formulation the number of inputs and outputs must match+but since you are free to ignore some of the inputs and outputs+you can use nodes for pure output, pure input or both of them.++-}++newtype T filter i t a v =+   C (Map i+      [(i,          {- index of the processor whose output goes in here -}+        filter t a v  {- description of the filter -}+        )])+++newtype Signal list i v = Signal (Map i (list v))+++fromList :: (Ord i) => [(i, [(i, filter t a v)])] -> T filter i t a v+fromList = C . Map.fromList++toList :: T filter i t a v -> [(i, [(i, filter t a v)])]+toList (C fg) = Map.toList fg++signalFromList :: (Ord i) => [(i, list v)] -> Signal list i v+signalFromList = Signal . Map.fromList++signalToList :: Signal list i v -> [(i, list v)]+signalToList (Signal x) = Map.toList x++lookupSignal :: (Ord i) => Signal list i v -> i -> Maybe (list v)+lookupSignal (Signal x) = flip Map.lookup x+++{-+  These instance may help to include FilterGraphs+  in even bigger structures.+-}+instance (Ord i, Additive.C (list v), Eq (list v))+            => Additive.C (Signal list i v) where+   zero                      = Signal Additive.zero+   (+) (Signal x) (Signal y) = Signal ((Additive.+) x y)+   (-) (Signal x) (Signal y) = Signal ((Additive.-) x y)+   negate (Signal x)         = Signal (Additive.negate x)++instance (Ord i, Eq a, Additive.C a, Additive.C (list v), Eq (list v),+              Module.C a v, Module.C a (list v))+                 => Module.C a (Signal list i v) where+   s *> (Signal x) = Signal (s *> x)+++{-+   It would be interesting to make FilterGraphs+   an instance of Filter.+   To achieve that we had to make GraphSignals an instance of Module.C+   and the transferFunction would no longer return a factor+   but a function that maps input amplitudes+   of a given frequency to output amplitudes.++instance (Ord i, Show i, Filter list filter) =>+      Filter (Signal list i) (T filter i) where+-}++apply :: (Ord i, Show i, Additive.C t, Trans.C t, RealField.C t,+          Module.C a v, Module.C a (list v),+          Filter list filter) =>+   T filter i t a v -> Signal list i v -> Signal list i v+apply (C fg) (Signal inputs) =+   let getInput  i = Map.findWithDefault Additive.zero i inputs+       getOutput i = Map.findWithDefault+                         (error ("Unknown processor: "++show i)) i outputs+       output i edges =+          foldl (Additive.+) (getInput i) (map (\(j,f) ->+                   FilterBasic.apply f (getOutput j)) edges)+       outputs = Map.mapWithKey output fg+   in  Signal outputs++{-| Compute a matrix that tells how an input frequency+    is mapped to the various output nodes.++   According to the formulation given above+   we have to invert the matrix (I-A).++   Currently this is done by a QR decomposition for each frequency.+   It would be probably faster if we decompose+   the matrix containing polynomial elements.+   Then the inverted matrix would consist of some+   polynomial ratios which can be evaluated for each frequency.+-}+transferFunction ::+   (Ord i, Show i, Trans.C t,+    P.Fractional (Complex.T t), Scalar (Complex.T t),+      Module.C a t, Filter list filter) =>+         T filter i t a v -> t -> [[Complex.T t]]+transferFunction (C fg) w =+   let keys = Map.keys fg+       elts = Map.elems fg+       inputsToMap procs =+          Map.mapWithKey (\_ f -> FilterBasic.transferFunction f w)+                         (Map.fromList procs)+       makeRow procs =+          map (flip (Map.findWithDefault 0) (inputsToMap procs)) keys+       matrix = map makeRow elts+   in  inverse (add_to_diagonal (-1) matrix)
+ src/Synthesizer/Filter/Graphic.hs view
@@ -0,0 +1,7 @@+module Synthesizer.Filter.Graphic where++{-|+  This module should be populated with functions+  that create flowchart graphics from the filter networks+  of the 'Composition' module.+-}
+ src/Synthesizer/Filter/MonadFix.hs view
@@ -0,0 +1,44 @@+module Synthesizer.Filter.MonadFix where++import qualified Synthesizer.Filter.Graph as Graph+import qualified Synthesizer.Filter.Fix   as FFix++import Synthesizer.Filter.Fix (Channel(Channel), ChannelId)++import Control.Monad.Trans.State (StateT, evalStateT, get, modify, )+import Control.Monad.Trans.Writer (Writer, execWriter, tell, )+import Control.Monad.Trans (lift, )+++{-|+If you find 'Filter.Fix.T' still inconvenient,+and if you don't care about portability,+you can also use the following monad with the @mdo@ notation.++> mdo+>   v <- a·(u + d·w)+>   w <- b·(v + e·y)+>   y <- c· w++-}+++type T filter t a v x  =  StateT ChannelId (Writer [Channel filter t a v]) x++makeChannel ::+   [(ChannelId, filter t a v)] ->+   T filter t a v ChannelId+makeChannel inputs =+   do n <- get+      modify succ+      lift $ tell [Channel n inputs]+      return n+++run :: T filter t a v x -> [Channel filter t a v]+run m = execWriter (evalStateT m 0)+++toGraph :: T filter t a v x -> Graph.T filter Int t a v+toGraph =+   Graph.fromList . map (\(Channel n inputs) -> (n, inputs)) . run
+ src/Synthesizer/Filter/OneWay.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+module Synthesizer.Filter.OneWay where++import Synthesizer.Filter.Basic++import qualified Synthesizer.Plain.Interpolation as Interpolation+import qualified Synthesizer.Plain.Filter.NonRecursive as FiltNR+import Number.Complex(cis)++import qualified Algebra.Module   as Module+import qualified Algebra.Ring     as Ring+import qualified Algebra.Additive as Additive++import Algebra.Module(linearComb)+import Algebra.Additive(zero)++import PreludeBase+import NumericPrelude++type Signal = []++{-| shift signal in time -}+delay :: (Additive.C v) =>+   Int -> Signal v -> Signal v+delay = FiltNR.delayPad zero++delayOnce :: (Additive.C v) =>+   Signal v -> Signal v+delayOnce = (zero:)+++{-| Unmodulated non-recursive filter -}+nonRecursiveFilter :: Module.C a v =>+      [a] -> [v] -> [v]+nonRecursiveFilter = FiltNR.generic++{-| Modulated non-recursive filter. -}+nonRecursiveFilterMod :: Module.C a v =>+   [[a]] -> [v] -> [v]+nonRecursiveFilterMod ms x =+   zipWith linearComb ms (tail (scanl (flip (:)) [] x))+++{-| Description of a basic filter that can be used in larger networks. -}+data T t a v =+     Mask [a]+        {-^ A static filter described by its mask -}+   | ModMask (Signal [a])+        {-^ A modulated filter described by a list of masks -}+   | FracDelay (Interpolation.T t v) t+        {-^ Delay the signal by a fractional amount of samples.+            This is achieved by interpolation. -}+   | ModFracDelay (Interpolation.T t v) (Signal t)+        {-^ Delay with varying delay times.+            The delay times sequence must monotonically decrease.+            (This includes constant parts!) -}+   | Delay [v]+        {-^ Delay the signal by prepending another one -}++instance Filter [] T where++   apply (Mask         m)     = nonRecursiveFilter m+   apply (ModMask      m)     = nonRecursiveFilterMod m+   apply (FracDelay    ip t)  = Interpolation.multiRelativeZeroPad zero+                                   ip (-t) (repeat 1)+   apply (ModFracDelay ip ts) = Interpolation.multiRelativeZeroPad zero+                                   ip (- head ts) (repeat 1 - FiltNR.differentiate ts)+   apply (Delay        x)     = (x++)++   transferFunction (Mask        m) w = linearComb m (screw (negate w))+   transferFunction (FracDelay _ t) w = cis (negate w * t)+   transferFunction (Delay       x) w = cis (negate w * fromIntegral (length x))+   transferFunction _ _ =+      error "transfer function can't be computed for modulated filters"
+ src/Synthesizer/Filter/TwoWay.hs view
@@ -0,0 +1,247 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+module Synthesizer.Filter.TwoWay where++import Synthesizer.Filter.Basic++import qualified Synthesizer.Plain.Signal as Sig+import qualified Synthesizer.Plain.Interpolation as Ip+import qualified Synthesizer.Plain.Interpolation as Interpolation++import Algebra.Module(linearComb,(*>))++import qualified Algebra.Module    as Module+import qualified Algebra.RealField as RealField+import qualified Algebra.Ring      as Ring+import qualified Algebra.Additive  as Additive++import Number.Complex(cis, )+import Data.Function.HT (nest, )+import qualified Data.List as List++import PreludeBase hiding (take)+import NumericPrelude+++{-| A TwoWay.Signal stores values of the past and the future -}+data Signal v = Signal {past, future :: [v]}+   deriving (Show, Eq)++{-| Take n values starting from time zero.+    If you want clips from elsewhere,+    call 'take' after 'delay'. -}+take :: Int -> Signal v -> [v]+take n (Signal _ x) = List.take n x++zipSignalWith :: (a -> b -> c) -> Signal a -> Signal b -> Signal c+zipSignalWith f (Signal xPast xFuture) (Signal yPast yFuture) =+   (Signal (zipWith f xPast yPast) (zipWith f xFuture yFuture))++{-| Take the value at time zero. -}+origin :: Ring.C a => Signal a -> a+origin (Signal _ (x:_)) = x+origin _ = 0++{-| A signal that consists entirely of ones -}+ones :: Ring.C a => Signal a+ones = Signal (repeat 1) (repeat 1)++{-| shift signal in time,+    keep all values but if required pad with zeros -}+delay :: (Additive.C v) =>+   Int -> Signal v -> Signal v+delay = delayGen delayOnce++delayPad :: v -> Int -> Signal v -> Signal v+delayPad z = delayGen (delayPadOnce z)++{-| shift signal in time,+    zero values at either ends will be flushed -}+delayOpt :: (Eq v, Additive.C v) =>+   Int -> Signal v -> Signal v+delayOpt = delayGen delayOptOnce+++{-| Delay by one sample. -}+delayOnce :: (Additive.C v) =>+   Signal v -> Signal v+--delayOnce (Signal []     []) = ([],[])+delayOnce (Signal []     ys) = Signal [] (zero:ys)+delayOnce (Signal (x:xs) ys) = Signal xs (x:ys)++delayPadOnce :: v -> Signal v -> Signal v+--delayPadOnce _ (Signal []     []) = ([],[])+delayPadOnce z (Signal []     ys) = Signal [] (z:ys)+delayPadOnce _ (Signal (x:xs) ys) = Signal xs (x:ys)++delayOptOnce :: (Eq v, Additive.C v) =>+   Signal v -> Signal v+--delayOptOnce (Signal []     []) = Signal [] []+delayOptOnce (Signal []     ys) = Signal [] (zero:ys)+delayOptOnce (Signal (x:xs) []) = Signal xs (if x==zero then [] else x:[])+delayOptOnce (Signal (x:xs) ys) = Signal xs (x:ys)+++{-| General routine that supports delaying and prefetching+    using a general one-sample delaying routine. -}+delayGen :: (Signal v -> Signal v) ->+               Int -> Signal v -> Signal v+{- Using this optimization applications of recursive filters+   with zero initial conditions represented by an empty list will fail.+   This is because in this case the value of the first item of the future list+   depends on the first item of the input future list,+   whereas normally the first future value depends on no input future value,+   at all.+delayGen _ _ (Signal [] []) = Signal [] []+   cf. the next example -}+delayGen delOnce t =+    if t < 0+    then reverseTwoWay . nest (negate t) delOnce . reverseTwoWay+    else nest t delOnce++reverseTwoWay :: Signal v -> Signal v+reverseTwoWay (Signal x y) = Signal y x+++instance (Additive.C v) => Additive.C (Signal v) where+   zero                                = Signal zero zero+   (+)   (Signal y0 y1) (Signal x0 x1) = Signal (y0 + x0)   (y1 + x1)+   (-)   (Signal y0 y1) (Signal x0 x1) = Signal (y0 - x0)   (y1 - x1)+   negate               (Signal x0 x1) = Signal (negate x0) (negate x1)++instance (Module.C a v) => Module.C a (Signal v) where+   (*>)  s      (Signal x0 x1) = Signal (s *> x0) (s *> x1)+++++{-| for a Signal this means a reversion of the elements -}+flipPair :: (a,b) -> (b,a)+flipPair (x,y) = (y,x)++{- This example simulates what happens if you call+     apply (Feedback (Serial []) (Prim (Delay 1)) []) ([],[1])+   depending on the implementation of delayGen it may work or+   loop infinitely when yFuture is computed.+   It's even before the first element of yFuture is computed.+   Note, that the equivalent+     apply (Feedback (Serial []) (Prim (Delay 1)) [0]) ([],[1])+   works! (i.e. set yPast = [0] -}+testDelayGen :: Signal Double+testDelayGen =+   let yPast = []+       x = Signal [] [1]+       y = Signal yPast yFuture+       Signal _ yFuture = delayOnce (x + y)+       -- Signal _ yFuture = delayOptOnce (add x y)+       -- Signal _ yFuture = delayGen delayOnce 1 (add x y)+   in  Signal yPast (List.take 10 yFuture)++++{-| Unmodulated non-recursive filter -}+nonRecursiveFilter :: Module.C a v =>+      [a] -> Signal v -> Signal v+nonRecursiveFilter m x =+   linearComb m (iterate delayOnce x)++{-| Modulated non-recursive filter.+    The number of values before time 0 (past) or+    the filter mask lengths must be at most finite. -}+nonRecursiveFilterMod :: Module.C a v =>+   Signal [a] -> Signal v -> Signal v+nonRecursiveFilterMod (Signal mpre msuf) x =+   let (pre, suf) = unzip (map (\(Signal a b) -> (a,b)) (iterate delayOnce x))+   in  Signal (zipWith linearComb mpre pre) (zipWith linearComb msuf suf)+++{-| Interpolation allowing negative frequencies,+    but requires storage of all past values. -}+interpolatePaddedZero :: (Ord a, RealField.C a) =>+   b -> Interpolation.T a b+      -> a -> Signal a -> Signal b -> Signal b+interpolatePaddedZero z ip phase fs (Signal xPast xFuture) =+   let (phInt, phFrac) = splitFraction phase+       xPadded = Signal (xPast ++ repeat z) (xFuture ++ repeat z)+   in  interpolateCore ip phFrac fs+          (delayPad z (Ip.offset ip - phInt) xPadded)++interpolatePaddedCyclic :: (Ord a, RealField.C a) =>+   Interpolation.T a b+      -> a -> Signal a -> Signal b -> Signal b+interpolatePaddedCyclic ip phase fs (Signal xPast xFuture) =+   let (phInt, phFrac) = splitFraction phase+       xCyclic = xFuture ++ reverse xPast+   in  interpolateCore ip phFrac fs+          -- mod is for efficiency, only+          (delayPad (error "interpolate: infinite signal needs no zero padding")+                    (mod (Ip.offset ip - phInt) (length xCyclic))+                    (Signal (cycle (reverse xCyclic)) (cycle xCyclic)))++-- note that the extrapolation may miss some of the first and some of the last points+interpolatePaddedExtrapolation :: (Ord a, RealField.C a) =>+   Interpolation.T a b+      -> a -> Signal a -> Signal b -> Signal b+interpolatePaddedExtrapolation ip phase fs x =+   interpolateCore ip (phase - fromIntegral (Ip.offset ip)) fs x++interpolateCore :: (Ord a, Ring.C a) =>+   Interpolation.T a b -> a -> Signal a -> Signal b -> Signal b+interpolateCore ip phase (Signal freqPast freqFuture) x =+   Signal (interpolateHalfWay ip (1-phase) freqPast+             (delayPadOnce (error "interpolateCore: infinite signal needs no zero padding")+                           (reverseTwoWay x)))+          (interpolateHalfWay ip phase freqFuture x)++interpolateHalfWay :: (Ord a, Ring.C a) =>+   Interpolation.T a b -> a -> [a] -> Signal b -> [b]+interpolateHalfWay ip phase freqs (Signal xPast xFuture) =+    if phase >= 1 && Sig.lengthAtLeast (1+Ip.number ip) xFuture+    then interpolateHalfWay ip (phase-1) freqs+            (Signal (head xFuture : xPast) (tail xFuture))+    else if phase < 0 && Sig.lengthAtLeast 1 xPast+         then interpolateHalfWay ip (phase + 1) freqs+                 (Signal (tail xPast) (head xPast : xFuture))+         else Ip.func ip phase xFuture :+              interpolateHalfWay ip (phase + head freqs) (tail freqs)+                 (Signal xPast xFuture)+++{-| Description of a basic filter that can be used in larger networks. -}+data T t a v =+     Mask [a]+        {-^ A static filter described by its mask -}+   | ModMask (Signal [a])+        {-^ A modulated filter described by a list of masks -}+   | FracDelay (Interpolation.T t v) t+        {-^ Delay the signal by a fractional amount of samples.+            This is achieved by interpolation. -}+   | ModFracDelay (Interpolation.T t v) (Signal t)+        {-^ Delay with varying delay times. -}+   | Delay Int+        {-^ Delay the signal by given amount of samples. -}+   | Past [v]+        {-^ Replace the past by the given one.+            This must be present in each recursive filter cycle+            to let the magic work! -}++instance Filter Signal T where++   apply (Mask         m)     = nonRecursiveFilter m+   apply (ModMask      m)     = nonRecursiveFilterMod m+   apply (FracDelay    ip t)  = interpolatePaddedZero zero+                                   ip (-t) ones+   apply (ModFracDelay ip ts) = interpolatePaddedZero zero+                                   ip (- origin ts) (ts - delay (-1) ts + ones)+   apply (Delay        t)     = delay t+   apply (Past         x)     = Signal x . future++   {- This is in principle the same as for one way filters.+      How can one merge them? -}+   transferFunction (Mask        m) w = linearComb m (screw (negate w))+   transferFunction (FracDelay _ t) w = cis (negate w * t)+   transferFunction (Delay       t) w = cis (negate w * fromIntegral t)+   transferFunction (Past        _) _ = 1+   transferFunction _ _ =+      error "transfer function can't be computed for modulated filters"
+ src/Synthesizer/Format.hs view
@@ -0,0 +1,4 @@+module Synthesizer.Format where++class C sig where+   format :: Show x => Int -> sig x -> ShowS
+ src/Synthesizer/Frame/Stereo.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-+This data type can be used as sample type for stereo signals.+-}+module Synthesizer.Frame.Stereo (T, left, right, cons, map, ) where++import qualified Sound.Sox.Frame as Frame++import qualified Synthesizer.Interpolation.Class as Interpol+import qualified Algebra.Module   as Module+import qualified Algebra.Additive as Additive++import Foreign.Storable (Storable (..), )+import qualified Foreign.Storable.Record as Store++import Control.Applicative (liftA2, )++import NumericPrelude+import PreludeBase hiding (map)+import Prelude ()++++-- cf. Sound.Sox.Frame.Stereo+data T a = Cons {left, right :: !a}+++{-# INLINE cons #-}+cons :: a -> a -> T a+cons = Cons++{-# INLINE map #-}+map :: (a -> b) -> T a -> T b+map f (Cons l r) = Cons (f l) (f r)++instance Functor T where+   fmap = map+++store :: Storable a => Store.Dictionary (T a)+store =+   Store.run $+   liftA2 Cons+      (Store.element left)+      (Store.element right)++instance (Storable a) => Storable (T a) where+   sizeOf = Store.sizeOf store+   alignment = Store.alignment store+   peek = Store.peek store+   poke = Store.poke store+++instance (Additive.C a) => Additive.C (T a) where+   {-# INLINE zero #-}+   {-# INLINE negate #-}+   {-# INLINE (+) #-}+   {-# INLINE (-) #-}+   zero                             = Cons zero zero+   (+)    (Cons xl xr) (Cons yl yr) = Cons (xl+yl) (xr+yr)+   (-)    (Cons xl xr) (Cons yl yr) = Cons (xl-yl) (xr-yr)+   negate (Cons xl xr)              = Cons (negate xl) (negate xr)++instance (Module.C a b) => Module.C a (T b) where+   {-# INLINE (*>) #-}+   s *> (Cons l r)   = Cons (s *> l) (s *> r)++instance Interpol.C a b => Interpol.C a (T b) where+   {-# INLINE scaleAndAccumulate #-}+   scaleAndAccumulate =+      Interpol.makeMac2 Cons left right+++instance Frame.C a => Frame.C (T a) where+   numberOfChannels y = 2 * Frame.numberOfChannels (left y)+   format y = Frame.format (left y)
+ src/Synthesizer/FusionList/Control.hs view
@@ -0,0 +1,252 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{- |+Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes+-}+module Synthesizer.FusionList.Control where++import qualified Synthesizer.Plain.Control as Ctrl+import qualified Synthesizer.Piecewise as Piecewise++-- import Synthesizer.FusionList.Displacement (raise)+import qualified Synthesizer.FusionList.Signal as Sig++import qualified Algebra.Module                as Module+import qualified Algebra.Transcendental        as Trans+import qualified Algebra.RealField             as RealField+import qualified Algebra.Field                 as Field+import qualified Algebra.Ring                  as Ring+import qualified Algebra.Additive              as Additive++import Algebra.Module((*>))++-- import Number.Complex (cis,real)+-- import qualified Number.Complex as Complex++import qualified Prelude as P+import PreludeBase+import NumericPrelude+++{- * Control curve generation -}++{-# INLINE constant #-}+constant :: a -> Sig.T a+constant = Sig.repeat++{-# INLINE linear #-}+linear :: Additive.C a =>+      a   {-^ steepness -}+   -> a   {-^ initial value -}+   -> Sig.T a+          {-^ linear progression -}+linear d y0 = Sig.iterate (d+) y0++{- |+As stable as the addition of time values.+-}+{-# INLINE linearMultiscale #-}+linearMultiscale :: Additive.C y =>+      y+   -> y+   -> Sig.T y+linearMultiscale = curveMultiscale (+)++{- |+Linear curve starting at zero.+-}+{-# INLINE linearMultiscaleNeutral #-}+linearMultiscaleNeutral :: Additive.C y =>+      y+   -> Sig.T y+linearMultiscaleNeutral slope =+   curveMultiscaleNeutral (+) slope zero++{-# INLINE exponential #-}+{-# INLINE exponentialMultiscale #-}+exponential, exponentialMultiscale :: Trans.C a =>+      a   {-^ time where the function reaches 1\/e of the initial value -}+   -> a   {-^ initial value -}+   -> Sig.T a+          {-^ exponential decay -}+exponential time =+   Sig.iterate (exp (- recip time) *)++exponentialMultiscale time = curveMultiscale (*) (exp (- recip time))++{-# INLINE exponentialMultiscaleNeutral #-}+exponentialMultiscaleNeutral :: Trans.C y =>+      y   {-^ time where the function reaches 1\/e of the initial value -}+   -> Sig.T y {-^ exponential decay -}+exponentialMultiscaleNeutral time =+   curveMultiscaleNeutral (*) (exp (- recip time)) one+++{-# INLINE exponential2 #-}+{-# INLINE exponential2Multiscale #-}+exponential2, exponential2Multiscale :: Trans.C a =>+      a   {-^ half life -}+   -> a   {-^ initial value -}+   -> Sig.T a+          {-^ exponential decay -}+exponential2 halfLife =+   Sig.iterate (((Ring.one+Ring.one) ** (- recip halfLife)) *)+--   Sig.iterate (((Ring.one/(Ring.one+Ring.one)) ** recip halfLife) *)++exponential2Multiscale halfLife = curveMultiscale (*) (0.5 ** recip halfLife)++{- the 0.5 constant seems to block fusion+   Sig.iterate ((0.5 ** recip halfLife) *)+-}+{- dito fromInteger+   Sig.iterate ((fromInteger 2 ** (- recip halfLife)) *)+-}++{-# INLINE exponential2MultiscaleNeutral #-}+exponential2MultiscaleNeutral :: Trans.C y =>+      y   {-^ half life -}+   -> Sig.T y {-^ exponential decay -}+exponential2MultiscaleNeutral halfLife =+   curveMultiscaleNeutral (*) (0.5 ** recip halfLife) one+++{-# INLINE exponentialFromTo #-}+{-# INLINE exponentialFromToMultiscale #-}+exponentialFromTo, exponentialFromToMultiscale :: Trans.C y =>+      y   {-^ time where the function reaches 1\/e of the initial value -}+   -> y   {-^ initial value -}+   -> y   {-^ value after given time -}+   -> Sig.T y {-^ exponential decay -}+exponentialFromTo time y0 y1 =+   Sig.iterate (*  (y1/y0) ** recip time) y0+exponentialFromToMultiscale time y0 y1 =+   curveMultiscale (*) ((y1/y0) ** recip time) y0+++++{-| This is an extension of 'exponential' to vectors+    which is straight-forward but requires more explicit signatures.+    But since it is needed rarely I setup a separate function. -}+{-# INLINE vectorExponential #-}+vectorExponential :: (Trans.C a, Module.C a v) =>+       a  {-^ time where the function reaches 1\/e of the initial value -}+   ->  v  {-^ initial value -}+   -> Sig.T v+          {-^ exponential decay -}+vectorExponential time y0 =+   Sig.iterate (exp (-1/time) *>) y0++{-# INLINE vectorExponential2 #-}+vectorExponential2 :: (Trans.C a, Module.C a v) =>+       a  {-^ half life -}+   ->  v  {-^ initial value -}+   -> Sig.T v+          {-^ exponential decay -}+vectorExponential2 halfLife y0 =+   Sig.iterate (0.5**(1/halfLife) *>) y0++++{-# INLINE cosine #-}+cosine :: Trans.C a =>+       a  {-^ time t0 where  1 is approached -}+   ->  a  {-^ time t1 where -1 is approached -}+   -> Sig.T a+          {-^ a cosine wave where one half wave is between t0 and t1 -}+cosine = Ctrl.cosineWithSlope $+   \d x -> Sig.map cos (linear d x)++++{-# INLINE cubicHermite #-}+cubicHermite :: Field.C a => (a, (a,a)) -> (a, (a,a)) -> Sig.T a+cubicHermite node0 node1 =+   Sig.map (Ctrl.cubicFunc node0 node1) (linear 1 0)++++-- * piecewise curves+++splitDurations :: (RealField.C t) =>+   [t] -> [(Int, t)]+splitDurations ts0 =+   let (ds,ts) =+           unzip $ scanl+              (\(_,fr) d -> splitFraction (fr+d))+              (0,1) ts0+   in  zip (tail ds) (map (subtract 1) ts)++{-# INLINE piecewise #-}+piecewise :: (RealField.C a) =>+   Piecewise.T a a (a -> Sig.T a) -> Sig.T a+piecewise xs =+   Sig.concat $ zipWith+      (\(n, t) (Piecewise.PieceData c yi0 yi1 d) ->+           Sig.take n $ Piecewise.computePiece c yi0 yi1 d t)+      (splitDurations $ map Piecewise.pieceDur xs)+      xs+++type Piece a =+   Piecewise.Piece a a+      (a {- fractional start time -} -> Sig.T a)+++{-# INLINE stepPiece #-}+stepPiece :: Piece a+stepPiece =+   Piecewise.pieceFromFunction $ \ y0 _y1 _d _t0 ->+      constant y0++{-# INLINE linearPiece #-}+linearPiece :: (Field.C a) => Piece a+linearPiece =+   Piecewise.pieceFromFunction $ \ y0 y1 d t0 ->+      let s = (y1-y0)/d in linear s (y0-t0*s)++{-# INLINE exponentialPiece #-}+exponentialPiece :: (Trans.C a) => a -> Piece a+exponentialPiece saturation =+   Piecewise.pieceFromFunction $ \ y0 y1 d t0 ->+      let y0' = y0-saturation+          y1' = y1-saturation+          yd  = y0'/y1'+      in  raise saturation+             (exponential (d / log yd) (y0' * yd**(t0/d)))++{-# INLINE cosinePiece #-}+cosinePiece :: (Trans.C a) => Piece a+cosinePiece =+   Piecewise.pieceFromFunction $ \ y0 y1 d t0 ->+      Sig.map+         (\y -> (1+y)*(y0/2)+(1-y)*(y1/2))+         (cosine t0 (t0+d))++{-# INLINE cubicPiece #-}+cubicPiece :: (Field.C a) => a -> a -> Piece a+cubicPiece yd0 yd1 =+   Piecewise.pieceFromFunction $ \ y0 y1 d t0 ->+      cubicHermite (t0,(y0,yd0)) (t0+d,(y1,yd1))++raise :: Additive.C a => a -> Sig.T a -> Sig.T a+raise = Sig.map . (+)++-- * auxiliary functions++{-# INLINE curveMultiscale #-}+curveMultiscale :: (y -> y -> y) -> y -> y -> Sig.T y+curveMultiscale op d y0 =+   Sig.cons y0 (Sig.map (op y0) (Sig.iterateAssociative op d))++{-# INLINE curveMultiscaleNeutral #-}+curveMultiscaleNeutral :: (y -> y -> y) -> y -> y -> Sig.T y+curveMultiscaleNeutral op d neutral =+   Sig.cons neutral (Sig.iterateAssociative op d)
+ src/Synthesizer/FusionList/Filter/NonRecursive.hs view
@@ -0,0 +1,314 @@+{-# LANGUAGE NoImplicitPrelude #-}+{- |+Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes+-}+module Synthesizer.FusionList.Filter.NonRecursive where++import qualified Synthesizer.FusionList.Control as Ctrl+import qualified Synthesizer.FusionList.Signal as Sig++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 qualified Algebra.Ring           as Ring+import qualified Algebra.Additive       as Additive++import Algebra.Module( {- linearComb, -} (*>), )++import Data.Function.HT (nest, )++import PreludeBase+import NumericPrelude++++{- * Envelope application -}++{-# INLINE amplify #-}+amplify :: (Ring.C a) => a -> Sig.T a -> Sig.T a+amplify v = Sig.map (v*)++{-# INLINE amplifyVector #-}+amplifyVector :: (Module.C a v) => a -> Sig.T v -> Sig.T v+amplifyVector v = Sig.map (v*>)+++{-# INLINE envelope #-}+envelope :: (Ring.C a) =>+      Sig.T a  {-^ the envelope -}+   -> Sig.T a  {-^ the signal to be enveloped -}+   -> Sig.T a+envelope = Sig.zipWith (*)++{-# INLINE envelopeVector #-}+envelopeVector :: (Module.C a v) =>+      Sig.T a  {-^ the envelope -}+   -> Sig.T v  {-^ the signal to be enveloped -}+   -> Sig.T v+envelopeVector = Sig.zipWith (*>)++++{-# INLINE fadeInOut #-}+fadeInOut :: (Field.C a) =>+   Int -> Int -> Int -> Sig.T a -> Sig.T a+fadeInOut tIn tHold tOut =+   let leadIn  = Sig.take tIn  $ Ctrl.linear (  recip (fromIntegral tIn))  zero+       leadOut = Sig.take tOut $ Ctrl.linear (- recip (fromIntegral tOut)) one+       hold    = Sig.replicate tHold one+   in  envelope (leadIn `Sig.append` hold `Sig.append` leadOut)++{-# INLINE fadeInOutStored #-}+fadeInOutStored :: (Field.C a) =>+   Int -> Int -> Int -> Sig.T a -> Sig.T a+fadeInOutStored tIn tHold tOut xs =+   let leadIn  = Sig.take tIn  $ Ctrl.linear (  recip (fromIntegral tIn))  0+       leadOut = Sig.take tOut $ Ctrl.linear (- recip (fromIntegral tOut)) 1+       (partIn, partHoldOut) = Sig.splitAt tIn xs+       (partHold, partOut) = Sig.splitAt tHold partHoldOut+   in  envelope leadIn partIn `Sig.append`+       partHold `Sig.append`+       envelope leadOut partOut+++{- * Shift -}++{-# INLINE delay #-}+delay :: Additive.C y => Int -> Sig.T y -> Sig.T y+delay = delayPad zero++{-# INLINE delayPad #-}+delayPad :: y -> Int -> Sig.T y -> Sig.T y+delayPad z n =+   if n<0+     then Sig.drop (negate n)+     else Sig.append (Sig.replicate n z)+++{- * Smoothing -}+++{-| Unmodulated non-recursive filter -}+{-# INLINE generic #-}+generic :: (Module.C a v) =>+   Sig.T a -> Sig.T v -> Sig.T v+generic m x =+   let mr = Sig.reverse m+       xp = delay (pred (Sig.length m)) x+   in  Sig.mapTails (Sig.linearComb mr) xp++{-+genericSlow :: Module.C a v =>+   Sig.T a -> Sig.T v -> Sig.T v+genericSlow m x =+   let mr = Sig.reverse m+       xp = delay (pred (Sig.length m)) x+   in  Sig.fromList (map (Sig.linearComb mr) (init (Sig.tails xp)))+-}++{-+{- |+@eps@ is the threshold relatively to the maximum.+That is, if the gaussian falls below @eps * gaussian 0@,+then the function truncated.+-}+gaussian ::+   (Trans.C a, RealField.C a, Module.C a v) =>+   a -> a -> a -> Sig.T v -> Sig.T v+gaussian eps ratio freq =+   let var    = ratioFreqToVariance ratio freq+       area   = var * sqrt (2*pi)+       gau t  = exp (-(t/var)^2/2) / area+       width  = ceiling (var * sqrt (-2 * log eps))  -- inverse gau+       gauSmp = map (gau . fromIntegral) [-width .. width]+   in  drop width . generic gauSmp+-}++{-+GNUPlot.plotList [] (take 1000 $ gaussian 0.001 0.5 0.04 (Filter.Test.chirp 5000) :: [Double])++The filtered chirp must have amplitude 0.5 at 400 (0.04*10000).+-}++{-+  We want to approximate a Gaussian by a binomial filter.+  The latter one can be implemented by a convolutional power.+  However we still require a number of operations per sample+  which is proportional to the variance.+-}+{-# INLINE binomial #-}+binomial ::+   (Trans.C a, RealField.C a, Module.C a v) =>+   a -> a -> Sig.T v -> Sig.T v+binomial ratio freq =+   let width = ceiling (2 * ratioFreqToVariance ratio freq ^ 2)+   in  Sig.drop width . nest (2*width) ((asTypeOf 0.5 freq *>) . binomial1)++{-+exp (-(t/var)^2/2) / area *> cis (2*pi*f*t)+  == exp (-(t/var)^2/2 +: 2*pi*f*t) / area+  == exp ((-t^2 +: 2*var^2*2*pi*f*t) / (2*var^2)) / area+  == exp ((t^2 - i*2*var^2*2*pi*f*t) / (-2*var^2)) / area+  == exp (((t^2 - i*var^2*2*pi*f)^2 + (var^2*2*pi*f)^2) / (-2*var^2)) / area+  == exp (((t^2 - i*var^2*2*pi*f)^2 / (-2*var^2) - (var*2*pi*f)^2/2)) / area++sumMap (\t -> exp (-(t/var)^2/2) / area *> cis (2*pi*f*t))+       [-infinity..infinity]+  ~ sumMap (\t -> exp (-(t/var)^2/2)) [-infinity..infinity]+       * exp (-(var*2*pi*f)^2/2) / area+  = exp (-(var*2*pi*f)^2/2)+-}+{- |+  Compute the variance of the Gaussian+  such that its Fourier transform has value @ratio@ at frequency @freq@.+-}+{-# INLINE ratioFreqToVariance #-}+ratioFreqToVariance :: (Trans.C a) => a -> a -> a+ratioFreqToVariance ratio freq =+   sqrt (-2 * log ratio) / (2*pi*freq)+           -- inverse of the fourier transformed gaussian++{-# INLINE binomial1 #-}+binomial1 :: (Additive.C v) => Sig.T v -> Sig.T v+binomial1 = Sig.zapWith (+)++++++{- |+Moving (uniformly weighted) average in the most trivial form.+This is very slow and needs about @n * length x@ operations.+-}+{-# INLINE sums #-}+sums :: (Additive.C v) => Int -> Sig.T v -> Sig.T v+sums n = Sig.mapTails (Sig.sum . Sig.take n)+++{-+sumsDownsample2 :: (Additive.C v) => Sig.T v -> Sig.T v+sumsDownsample2 (x0:x1:xs) = (x0+x1) : sumsDownsample2 xs+sumsDownsample2 xs         = xs++downsample2 :: Sig.T a -> Sig.T a+downsample2 (x0:_:xs) = x0 : downsample2 xs+downsample2 xs        = xs+++{- |+Given a list of numbers+and a list of sums of (2*k) of successive summands,+compute a list of the sums of (2*k+1) or (2*k+2) summands.++Eample for 2*k+1++@+ [0+1+2+3, 2+3+4+5, 4+5+6+7, ...] ->+    [0+1+2+3+4, 1+2+3+4+5, 2+3+4+5+6, 3+4+5+6+7, 4+5+6+7+8, ...]+@++Example for 2*k+2++@+ [0+1+2+3, 2+3+4+5, 4+5+6+7, ...] ->+    [0+1+2+3+4+5, 1+2+3+4+5+6, 2+3+4+5+6+7, 3+4+5+6+7+8, 4+5+6+7+8+9, ...]+@+-}+sumsUpsampleOdd :: (Additive.C v) => Int -> Sig.T v -> Sig.T v -> Sig.T v+sumsUpsampleOdd n {- 2*k -} xs ss =+   let xs2k = drop n xs+   in  (head ss + head xs2k) :+          concat (zipWith3 (\s x0 x2k -> [x0+s, s+x2k])+                           (tail ss)+                           (downsample2 (tail xs))+                           (tail (downsample2 xs2k)))++sumsUpsampleEven :: (Additive.C v) => Int -> Sig.T v -> Sig.T v -> Sig.T v+sumsUpsampleEven n {- 2*k -} xs ss =+   sumsUpsampleOdd (n+1) xs (zipWith (+) ss (downsample2 (drop n xs)))++sumsPyramid :: (Additive.C v) => Int -> Sig.T v -> Sig.T v+sumsPyramid n xs =+   let aux 1 ys = ys+       aux 2 ys = ys + tail ys+       aux m ys =+          let ysd = sumsDownsample2 ys+          in  if even m+                then sumsUpsampleEven (m-2) ys (aux (div (m-2) 2) ysd)+                else sumsUpsampleOdd  (m-1) ys (aux (div (m-1) 2) ysd)+   in  aux n xs+++propSums :: Bool+propSums =+   let n  = 1000+       xs = [0::Double ..]+       naive   =              sums        n xs+       rec     = drop (n-1) $ sumsRec     n xs+       pyramid =              sumsPyramid n xs+   in  and $ take 1000 $+         zipWith3 (\x y z -> x==y && y==z) naive rec pyramid++-}++++{- * Filter operators from calculus -}++{- |+Forward difference quotient.+Shortens the signal by one.+Inverts 'Synthesizer.Plain.Filter.Recursive.Integration.run' in the sense that+@differentiate (zero : integrate x) == x@.+The signal is shifted by a half time unit.+-}+{-# INLINE differentiate #-}+differentiate :: Additive.C v => Sig.T v -> Sig.T v+differentiate x = Sig.zapWith subtract x++{- |+Central difference quotient.+Shortens the signal by two elements,+and shifts the signal by one element.+(Which can be fixed by prepending an appropriate value.)+For linear functions this will yield+essentially the same result as 'differentiate'.+You obtain the result of 'differentiateCenter'+if you smooth the one of 'differentiate'+by averaging pairs of adjacent values.++ToDo: Vector variant+-}+{-# INLINE differentiateCenter #-}+differentiateCenter :: Field.C v => Sig.T v -> Sig.T v+differentiateCenter =+   Sig.zapWith (\(x0,_) (_,x1) -> (x1 - x0) * (1/2)) .+   Sig.zapWith (,)+{-+differentiateCenter :: Field.C v => Sig.T v -> Sig.T v+differentiateCenter x =+   Sig.map ((1/2)*) $+   Sig.zipWith subtract x (Sig.tail (Sig.tail x))+-}++{- |+Second derivative.+It is @differentiate2 == differentiate . differentiate@+but 'differentiate2' should be faster.+-}+{-# INLINE differentiate2 #-}+differentiate2 :: Additive.C v => Sig.T v -> Sig.T v+differentiate2 = differentiate . differentiate+{-+differentiate2 :: Additive.C v => Sig.T v -> Sig.T v+differentiate2 xs0 =+   let xs1 = Sig.tail xs0+       xs2 = Sig.tail xs1+   in  Sig.zipWith3 (\x0 x1 x2 -> x0+x2-(x1+x1)) xs0 xs1 xs2+-}
+ src/Synthesizer/FusionList/Oscillator.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE NoImplicitPrelude #-}+{- |+Copyright   :  (c) Henning Thielemann 2006+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes++Tone generators+-}+module Synthesizer.FusionList.Oscillator where++import qualified Synthesizer.Basic.Wave       as Wave+import qualified Synthesizer.Basic.Phase      as Phase++import qualified Synthesizer.FusionList.Signal as Sig++-- import qualified Synthesizer.FusionList.Interpolation as Interpolation++{-+import qualified Algebra.RealTranscendental    as RealTrans+import qualified Algebra.Module                as Module+import qualified Algebra.VectorSpace           as VectorSpace++import Algebra.Module((*>))+-}+import qualified Algebra.Transcendental        as Trans+import qualified Algebra.RealField             as RealField+-- import qualified Algebra.Field                 as Field+-- import qualified Algebra.Ring                  as Ring+import qualified Algebra.Additive              as Additive++import NumericPrelude++import qualified Prelude as P+import PreludeBase++++{- * Oscillators with arbitrary but constant waveforms -}++{-# INLINE freqToPhase #-}+{- | Convert a list of phase steps into a list of momentum phases+     phase is a number in the interval [0,1)+     freq contains the phase steps -}+freqToPhase :: RealField.C a => Phase.T a -> Sig.T a -> Sig.T (Phase.T a)+freqToPhase phase freq = Sig.scanL (flip Phase.increment) phase freq+++{- Inlining blocks fusion of map and iterate - on the other hand it enables fusion in the main program -}+{-# INLINE static #-}+{- | oscillator with constant frequency -}+static :: (RealField.C a) => Wave.T a b -> (Phase.T a -> a -> Sig.T b)+static wave phase freq =+    Sig.map (Wave.apply wave) (Sig.iterate (Phase.increment freq) phase)++{-# INLINE phaseMod #-}+{- | oscillator with modulated phase -}+phaseMod :: (RealField.C a) => Wave.T a b -> a -> Sig.T a -> Sig.T b+phaseMod wave = shapeMod (Wave.phaseOffset wave) zero++{-# INLINE shapeMod #-}+{- | oscillator with modulated shape -}+shapeMod :: (RealField.C a) =>+    (c -> Wave.T a b) -> Phase.T a -> a -> Sig.T c -> Sig.T b+shapeMod wave phase freq parameters =+    Sig.zipWith (Wave.apply . wave) parameters (Sig.iterate (Phase.increment freq) phase)++{-# INLINE freqMod #-}+{- | oscillator with modulated frequency -}+freqMod :: (RealField.C a) => Wave.T a b -> Phase.T a -> Sig.T a -> Sig.T b+freqMod wave phase freqs =+    Sig.map (Wave.apply wave) (freqToPhase phase freqs)++{-# INLINE phaseFreqMod #-}+{- | oscillator with both phase and frequency modulation -}+phaseFreqMod :: (RealField.C a) =>+    Wave.T a b -> Sig.T a -> Sig.T a -> Sig.T b+phaseFreqMod wave = shapeFreqMod (Wave.phaseOffset wave) zero++{-# INLINE shapeFreqMod #-}+{- | oscillator with both shape and frequency modulation -}+shapeFreqMod :: (RealField.C a) =>+    (c -> Wave.T a b) -> Phase.T a -> Sig.T c -> Sig.T a -> Sig.T b+shapeFreqMod wave phase parameters freqs =+    Sig.zipWith (Wave.apply . wave) parameters (freqToPhase phase freqs)++{-+{- | oscillator with a sampled waveform with constant frequency+     This essentially an interpolation with cyclic padding. -}+{-# INLINE staticSample #-}+staticSample :: RealField.C a =>+    Interpolation.T a b -> Sig.T b -> Phase.T a -> a -> Sig.T b+staticSample ip wave phase freq =+    freqModSample ip wave phase (Sig.repeat freq)++{- | oscillator with a sampled waveform with modulated frequency+     Should behave homogenously for different types of interpolation. -}+{-# INLINE freqModSample #-}+freqModSample :: RealField.C a =>+    Interpolation.T a b -> Sig.T b -> Phase.T a -> Sig.T a -> Sig.T b+freqModSample ip wave phase freqs =+    let len = Sig.length wave+    in  Interpolation.multiRelativeCyclicPad+           ip (fromIntegral len * Phase.toRepresentative phase)+           (Sig.map (* fromIntegral len) freqs) wave+-}++++{- * Oscillators with specific waveforms -}++{-# INLINE staticSine #-}+{- | sine oscillator with static frequency -}+staticSine :: (Trans.C a, RealField.C a) => Phase.T a -> a -> Sig.T a+staticSine = static Wave.sine++{-# INLINE freqModSine #-}+{- | sine oscillator with modulated frequency -}+freqModSine :: (Trans.C a, RealField.C a) => Phase.T a -> Sig.T a -> Sig.T a+freqModSine = freqMod Wave.sine++{-# INLINE phaseModSine #-}+{- | sine oscillator with modulated phase, useful for FM synthesis -}+phaseModSine :: (Trans.C a, RealField.C a) => a -> Sig.T a -> Sig.T a+phaseModSine = phaseMod Wave.sine++{-# INLINE staticSaw #-}+{- | saw tooth oscillator with modulated frequency -}+staticSaw :: RealField.C a => Phase.T a -> a -> Sig.T a+staticSaw = static Wave.saw++{-# INLINE freqModSaw #-}+{- | saw tooth oscillator with modulated frequency -}+freqModSaw :: RealField.C a => Phase.T a -> Sig.T a -> Sig.T a+freqModSaw = freqMod Wave.saw
+ src/Synthesizer/FusionList/Signal.hs view
@@ -0,0 +1,716 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_GHC -fglasgow-exts #-}+{- glasgow-exts are for the rules -}+module Synthesizer.FusionList.Signal where++import qualified Synthesizer.Plain.Signal   as Sig+import qualified Synthesizer.Plain.Modifier as Modifier+import qualified Data.List as List++import qualified Data.StorableVector.Lazy as Vector+import Data.StorableVector.Lazy (ChunkSize, Vector)+import Foreign.Storable (Storable, )++import qualified Algebra.Module   as Module+import qualified Algebra.Additive as Additive+import Algebra.Additive (zero)++import Algebra.Module ((*>))++import qualified Synthesizer.Format as Format++import Control.Monad.Trans.State (runState, )++import Data.Monoid (Monoid, mempty, mappend, )++import qualified Data.List.HT    as ListHT+import Data.Tuple.HT (mapFst, mapSnd, mapPair, fst3, snd3, thd3, )++import Data.Maybe.HT (toMaybe)+import NumericPrelude (fromInteger, )++import Text.Show (Show(showsPrec), showParen, showString, )+import Data.Maybe (Maybe(Just, Nothing), maybe)+import Prelude+   ((.), ($), id, const, flip, curry, uncurry, fst, snd, error,+    (>), (>=), max, Ord,+    succ, pred, Bool, not, Int, Functor, fmap,+    (>>), (>>=), fail, return, (=<<),+--    fromInteger,+    )+-- import qualified Prelude as P+{-+import Prelude hiding+   ((++), iterate, foldl, map, repeat, replicate,+    zipWith, zipWith3, take, takeWhile)+-}+++newtype T y = Cons {decons :: [y]}++instance (Show y) => Show (T y) where+   showsPrec p x =+      showParen (p >= 10)+         (showString "FusionList.fromList " . showsPrec 11 (toList x))++instance Format.C T where+   format = showsPrec++instance Functor T where+   fmap = map++instance Monoid (T y) where+   mempty = empty+   mappend = append+++{- * functions based on 'generate' -}++{-# NOINLINE [0] generate #-}+generate :: (acc -> Maybe (y, acc)) -> acc -> T y+generate f = Cons . snd . Sig.unfoldR f++{-# INLINE unfoldR #-}+unfoldR :: (acc -> Maybe (y, acc)) -> acc -> T y+unfoldR = generate++{-# INLINE generateInfinite #-}+generateInfinite :: (acc -> (y, acc)) -> acc -> T y+generateInfinite f = generate (Just . f)++{-# INLINE fromList #-}+fromList :: [y] -> T y+fromList = generate ListHT.viewL++{-# INLINE toList #-}+toList :: T y -> [y]+toList = decons+++toStorableSignal :: Storable y => ChunkSize -> T y -> Vector y+toStorableSignal size  =  Vector.pack size . decons++fromStorableSignal :: Storable y => Vector y -> T y+fromStorableSignal  =  Cons . Vector.unpack+++{-# INLINE iterate #-}+iterate :: (a -> a) -> a -> T a+iterate f = generateInfinite (\x -> (x, f x))++{-# INLINE iterateAssociative #-}+iterateAssociative :: (a -> a -> a) -> a -> T a+iterateAssociative op x = iterate (op x) x -- should be optimized++{-# INLINE repeat #-}+repeat :: a -> T a+repeat = iterate id+++{- * functions based on 'crochetL' -}++{-# NOINLINE [0] crochetL #-}+crochetL :: (x -> acc -> Maybe (y, acc)) -> acc -> T x -> T y+crochetL f a = Cons . Sig.crochetL f a . decons++{-# INLINE scanL #-}+scanL :: (acc -> x -> acc) -> acc -> T x -> T acc+{-+scanL f start xs =+   cons start+     (crochetL (\x acc -> let y = f acc x in Just (y, y)) start xs)+-}+scanL f start =+   cons start .+   crochetL (\x acc -> let y = f acc x in Just (y, y)) start++-- | input and output have equal length, that's better for fusion+scanLClip :: (acc -> x -> acc) -> acc -> T x -> T acc+scanLClip f start =+   crochetL (\x acc -> Just (acc, f acc x)) start++{-# INLINE map #-}+map :: (a -> b) -> (T a -> T b)+map f = crochetL (\x _ -> Just (f x, ())) ()++{-# RULEZ+  "FusionList.map-crochetL" forall f.+     map f = crochetL (\x _ -> Just (f x, ())) () ;++  "FusionList.repeat-iterate"+     repeat = iterate id ;++  "FusionList.iterate-generate" forall f.+     iterate f = generate (\x -> Just (x, f x)) ;++  "FusionList.take-crochetL"+     take = crochetL (\x n -> toMaybe (n>zero) (x, pred n)) ;++  "FusionList.unfold-dollar" forall f x.+     f $ x = f x ;++  "FusionList.unfold-dot" forall f g.+     f . g  =  \x -> f (g x) ;+  #-}++{-# INLINE unzip #-}+unzip :: T (a,b) -> (T a, T b)+unzip x = (map fst x, map snd x)++{-# INLINE unzip3 #-}+unzip3 :: T (a,b,c) -> (T a, T b, T c)+unzip3 xs = (map fst3 xs, map snd3 xs, map thd3 xs)+++{-# INLINE delay1 #-}+{- |+This is a fusion friendly implementation of delay.+However, in order to be a 'crochetL'+the output has the same length as the input,+that is, the last element is removed - at least for finite input.+-}+delay1 :: a -> T a -> T a+delay1 = crochetL (flip (curry Just))++{-# INLINE delay #-}+delay :: y -> Int -> T y -> T y+delay z n = append (replicate n z)+++{-# INLINE take #-}+take :: Int -> T a -> T a+take = crochetL (\x n -> toMaybe (n>zero) (x, pred n))++{-# INLINE takeWhile #-}+takeWhile :: (a -> Bool) -> T a -> T a+takeWhile p = crochetL (\x _ -> toMaybe (p x) (x, ())) ()++{-# INLINE replicate #-}+replicate :: Int -> a -> T a+replicate n = take n . repeat++{-# RULES+  "FusionList.map/repeat" forall f x.+     map f (repeat x) = repeat (f x) ;++  "FusionList.map/replicate" forall f n x.+     map f (replicate n x) = replicate n (f x) ;++  "FusionList.map/cons" forall f x xs.+      map f (cons x xs) = cons (f x) (map f xs) ;++  "FusionList.map/append" forall f xs ys.+      map f (append xs ys) = append (map f xs) (map f ys) ;++  {- should be subsumed by the map/cons rule,+       but it doesn't fire sometimes+  "FusionList.map/cons/compose" forall f g x xs.+      map f ((cons x . g) xs) = cons (f x) (map f (g xs)) ;+  -}++  {- this does not fire, since 'map' is inlined, crochetL/cons should fire instead -}+  "FusionList.map/scanL" forall f g x0 xs.+      map g (scanL f x0 xs) =+         cons (g x0)+            (crochetL (\x acc -> let y = f acc x in Just (g y, y)) x0 xs) ;++  "FusionList.map/zipWith" forall f g x y.+     map f (zipWith g x y) =+        zipWith (\xi yi -> f (g xi yi)) x y ;++  "FusionList.zipWith/map,*" forall f g x y.+     zipWith g (map f x) y =+        zipWith (\xi yi -> g (f xi) yi) x y ;++  "FusionList.zipWith/*,map" forall f g x y.+     zipWith g x (map f y) =+        zipWith (\xi yi -> g xi (f yi)) x y ;+  #-}++{- * functions consuming multiple lists -}++{-# NOINLINE [0] zipWith #-}+zipWith :: (a -> b -> c) -> (T a -> T b -> T c)+zipWith f s0 s1 =+   Cons $ List.zipWith f (decons s0) (decons s1)++{-# INLINE zipWith3 #-}+zipWith3 :: (a -> b -> c -> d) -> (T a -> T b -> T c -> T d)+zipWith3 f s0 s1 =+   zipWith (uncurry f) (zip s0 s1)++{-# INLINE zipWith4 #-}+zipWith4 :: (a -> b -> c -> d -> e) -> (T a -> T b -> T c -> T d -> T e)+zipWith4 f s0 s1 =+   zipWith3 (uncurry f) (zip s0 s1)+++{-# INLINE zip #-}+zip :: T a -> T b -> T (a,b)+zip = zipWith (,)++{-# INLINE zip3 #-}+zip3 :: T a -> T b -> T c -> T (a,b,c)+zip3 = zipWith3 (,,)++{-# INLINE zip4 #-}+zip4 :: T a -> T b -> T c -> T d -> T (a,b,c,d)+zip4 = zipWith4 (,,,)+++{- * functions based on 'reduceL' -}++reduceL :: (x -> acc -> Maybe acc) -> acc -> T x -> acc+reduceL f x = Sig.reduceL f x . decons++{-# INLINE foldL' #-}+foldL' :: (x -> acc -> acc) -> acc -> T x -> acc+foldL' f = reduceL (\x -> Just . f x)++{-# INLINE foldL #-}+foldL :: (acc -> x -> acc) -> acc -> T x -> acc+foldL f = foldL' (flip f)++{-# INLINE lengthSlow #-}+{- | can be used to check against native length implementation -}+lengthSlow :: T a -> Int+lengthSlow = foldL' (const succ) zero+++{-+Do we still need rules for fusion of+  map f (repeat x)+  zipWith f (repeat x) ys+?+-}++{- * Fusion helpers -}++{-# INLINE zipWithGenerate #-}+zipWithGenerate ::+      (a -> b -> c)+   -> (acc -> Maybe (a, acc))+   -> acc+   -> T b -> T c+zipWithGenerate h f a y =+   crochetL (\y0 a0 ->+       do (x0,a1) <- f a0+          Just (h x0 y0, a1)) a y++{-# INLINE zipWithCrochetL #-}+zipWithCrochetL ::+      (a -> b -> c)+   -> (x -> acc -> Maybe (a, acc))+   -> acc+   -> T x -> T b -> T c+zipWithCrochetL h f a x y =+   crochetL (\(x0,y0) a0 ->+       do (z0,a1) <- f x0 a0+          Just (h z0 y0, a1))+      a (zip x y)++{-# INLINE mixGenerate #-}+mixGenerate :: (Additive.C a) =>+      (a -> a -> a)+   -> (acc -> Maybe (a, acc))+   -> acc+   -> T a -> T a+mixGenerate plus f a =+   crochetL+      (\y0 a0 ->+         Just (maybe+            (y0, Nothing)+            (\(x0,a1) -> (plus x0 y0, Just a1))+            (f =<< a0)))+      (Just a)++{-# INLINE crochetLCons #-}+crochetLCons ::+      (a -> acc -> Maybe (b, acc))+   -> acc+   -> a -> T a -> T b+crochetLCons f a0 x xs =+   maybe+      empty+      (\(y,a1) -> cons y (crochetL f a1 xs))+      (f x a0)++{-+{-# INLINE crochetLAppend #-}+crochetLAppend ::+      (a -> acc -> Maybe (b, acc))+   -> acc+   -> a -> T a -> T a -> T b+crochetLAppend f a0 x xs ys =+   maybe+      empty+      (\(y,a1) -> cons y (crochetL f a1 xs))+      (f x a0)+-}++{-# INLINE reduceLCons #-}+reduceLCons ::+      (a -> acc -> Maybe acc)+   -> acc+   -> a -> T a -> acc+reduceLCons f a0 x xs =+   maybe a0 (flip (reduceL f) xs) (f x a0)+++{-+applyThroughCons ::+   (a -> Maybe (b,acc)) -> (T a -> acc -> T b) -> T a -> T b+applyThroughCons f g =+   maybe empty+      (\(x,xs) -> cons (f x) (g xs)) . viewL+-}++{-# INLINE zipWithCons #-}+zipWithCons ::+      (a -> b -> c)+   -> a -> T a -> T b -> T c+zipWithCons f x xs =+   maybe+      empty+      (\(y,ys) -> cons (f x y) (zipWith f xs ys))+    . viewL+++{-# RULES+  "FusionList.crochetL/generate" forall f g a b.+     crochetL g b (generate f a) =+        generate (\(a0,b0) ->+            do (y0,a1) <- f a0+               (z0,b1) <- g y0 b0+               Just (z0, (a1,b1))) (a,b) ;++  "FusionList.crochetL/crochetL" forall f g a b x.+     crochetL g b (crochetL f a x) =+        crochetL (\x0 (a0,b0) ->+            do (y0,a1) <- f x0 a0+               (z0,b1) <- g y0 b0+               Just (z0, (a1,b1))) (a,b) x ;++  "FusionList.crochetL/cons" forall g b x xs.+     crochetL g b (cons x xs) =+        crochetLCons g b x xs ;+++  "FusionList.tail/generate" forall f a.+     tail (generate f a) =+        maybe (error "FusionList.tail: empty list")+           (generate f . snd) (f a) ;++  "FusionList.tail/cons" forall x xs.+     tail (cons x xs) = xs ;++  "FusionList.zipWith/generate,*" forall f h a y.+     zipWith h (generate f a) y =+        zipWithGenerate h f a y ;++  "FusionList.zipWith/crochetL,*" forall f h a x y.+     zipWith h (crochetL f a x) y =+        zipWithCrochetL h f a x y ;++  "FusionList.zipWith/*,generate" forall f h a y.+     zipWith h y (generate f a) =+        zipWithGenerate (flip h) f a y ;++  "FusionList.zipWith/*,crochetL" forall f h a x y.+     zipWith h y (crochetL f a x) =+        zipWithCrochetL (flip h) f a x y ;++  "FusionList.mix/generate,*" forall f a y.+     mix (generate f a) y =+        mixGenerate (Additive.+) f a y ;++  "FusionList.mix/*,generate" forall f a y.+     mix y (generate f a) =+        mixGenerate (flip (Additive.+)) f a y ;+++{- this blocks further fusion and+   is not necessary if the non-cons operand is a 'generate'+  "FusionList.zipWith/cons,*" forall h x xs ys.+     zipWith h (cons x xs) ys =+        zipWithCons h x xs ys ;++  "FusionList.zipWith/*,cons" forall h x xs ys.+     zipWith h ys (cons x xs) =+        zipWithCons (flip h) x xs ys ;+-}++  "FusionList.zipWith/cons,cons" forall h x xs y ys.+     zipWith h (cons x xs) (cons y ys) =+        cons (h x y) (zipWith h xs ys) ;++  "FusionList.zipWith/share" forall (h :: a->a->b) (x :: T a).+     zipWith h x x = map (\xi -> h xi xi) x ;++++  "FusionList.reduceL/generate" forall f g a b.+     reduceL g b (generate f a) =+        snd+          (recourse (\(a0,b0) ->+              do (y,a1) <- f a0+                 b1 <- g y b0+                 Just (a1, b1)) (a,b)) ;++  "FusionList.reduceL/crochetL" forall f g a b x.+     reduceL g b (crochetL f a x) =+        snd+          (reduceL (\x0 (a0,b0) ->+              do (y,a1) <- f x0 a0+                 b1 <- g y b0+                 Just (a1, b1)) (a,b) x) ;++  "FusionList.reduceL/cons" forall g b x xs.+     reduceL g b (cons x xs) =+        reduceLCons g b x xs ;+++  "FusionList.viewL/cons" forall x xs.+     viewL (cons x xs) = Just (x,xs) ;++  "FusionList.viewL/generateInfinite" forall f x.+     viewL (generateInfinite f x) =+        Just (mapSnd (generateInfinite f) (f x)) ;++  "FusionList.viewL/generate" forall f x.+     viewL (generate f x) =+        fmap (mapSnd (generate f)) (f x) ;++  "FusionList.viewL/crochetL" forall f a xt.+     viewL (crochetL f a xt) =+        do (x,xs) <- viewL xt+           (y,a') <- f x a+           return (y, crochetL f a' xs) ;+  #-}+++{- * Other functions -}++null :: T a -> Bool+null = List.null . decons++empty :: T a+empty = Cons []++singleton :: a -> T a+singleton = Cons . (: [])++{-# NOINLINE [0] cons #-}+cons :: a -> T a -> T a+cons x = Cons . (x :) . decons++length :: T a -> Int+length = List.length . decons++viewL :: T a -> Maybe (a, T a)+viewL =+   fmap (mapSnd Cons) . ListHT.viewL . decons++viewR :: T a -> Maybe (T a, a)+viewR =+   fmap (mapFst Cons) . ListHT.viewR . decons++extendConstant :: T a -> T a+extendConstant xt =+   maybe empty (append xt . repeat . snd) $+   viewR xt++{-# NOINLINE [0] tail #-}+tail :: T a -> T a+tail = Cons . List.tail . decons++head :: T a -> a+head = List.head . decons++drop :: Int -> T a -> T a+drop n = Cons . List.drop n . decons++dropMarginRem :: Int -> Int -> T a -> (Int, T a)+dropMarginRem n m = mapSnd Cons . Sig.dropMarginRem n m . decons++{-+This implementation does only walk once through the dropped prefix.+It is maximally lazy and minimally space consuming.+-}+dropMargin :: Int -> Int -> T a -> T a+dropMargin n m = Cons . Sig.dropMargin n m . decons+++index :: Int -> T a -> a+index n = (List.!! n) . decons+++splitAt :: Int -> T a -> (T a, T a)+splitAt n = mapPair (Cons, Cons) . List.splitAt n . decons++dropWhile :: (a -> Bool) -> T a -> T a+dropWhile p = Cons . List.dropWhile p . decons++span :: (a -> Bool) -> T a -> (T a, T a)+span p = mapPair (Cons, Cons) . List.span p . decons++mapAccumL :: (acc -> x -> (acc, y)) -> acc -> T x -> (acc, T y)+mapAccumL f acc = mapSnd Cons . List.mapAccumL f acc . decons++mapAccumR :: (acc -> x -> (acc, y)) -> acc -> T x -> (acc, T y)+mapAccumR f acc = mapSnd Cons . List.mapAccumR f acc . decons+++cycle :: T a -> T a+cycle = Cons . List.cycle . decons++{-# NOINLINE [0] mix #-}+mix :: Additive.C a => T a -> T a -> T a+mix (Cons xs) (Cons ys)  =  Cons (xs Additive.+ ys)++{-# NOINLINE [0] sub #-}+sub :: Additive.C a => T a -> T a -> T a+sub (Cons xs) (Cons ys)  =  Cons (xs Additive.- ys)++{-# NOINLINE [0] neg #-}+neg :: Additive.C a => T a -> T a+neg (Cons xs)  =  Cons (Additive.negate xs)++instance Additive.C y => Additive.C (T y) where+   zero = empty+   (+) = mix+   (-) = sub+   negate = neg++instance Module.C y yv => Module.C y (T yv) where+   (*>) x y = map (x*>) y+++infixr 5 `append`++{-# NOINLINE [0] append #-}+append :: T a -> T a -> T a+append (Cons xs) (Cons ys)  =  Cons (xs List.++ ys)++concat :: [T a] -> T a+concat  =  Cons . List.concat . List.map decons++reverse :: T a -> T a+reverse = Cons . List.reverse . decons++++sum :: (Additive.C a) => T a -> a+sum = foldL' (Additive.+) Additive.zero++maximum :: (Ord a) => T a -> a+maximum =+   maybe+      (error "FusionList.maximum: empty list")+      (uncurry (foldL' max))+    . viewL++tails :: T y -> [T y]+tails = List.map Cons . List.tails . decons++init :: T y -> T y+init = Cons . List.init . decons++sliceVert :: Int -> T y -> [T y]+sliceVert n =+   List.map (take n) . List.takeWhile (not . null) . List.iterate (drop n)+++zapWith :: (a -> a -> b) -> T a -> T b+zapWith f xs0 =+   let xs1 = maybe empty snd (viewL xs0)+   in  zipWith f xs0 xs1++modifyStatic :: Modifier.Simple s ctrl a b -> ctrl -> T a -> T b+modifyStatic modif control x =+   crochetL+      (\a acc ->+         Just (runState (Modifier.step modif control a) acc))+      (Modifier.init modif) x++{-| Here the control may vary over the time. -}+modifyModulated :: Modifier.Simple s ctrl a b -> T ctrl -> T a -> T b+modifyModulated modif control x =+   crochetL+      (\ca acc ->+         Just (runState (uncurry (Modifier.step modif) ca) acc))+      (Modifier.init modif)+      (zip control x)+++-- cf. Module.linearComb+linearComb ::+   (Module.C t y) =>+   T t -> T y -> y+linearComb ts ys =+   sum $ zipWith (*>) ts ys+++-- comonadic 'bind'+-- only non-empty suffixes are processed+mapTails ::+   (T y0 -> y1) -> T y0 -> T y1+mapTails f =+   generate (\xs ->+      do (_,ys) <- viewL xs+         return (f xs, ys))++-- only non-empty suffixes are processed+zipWithTails ::+   (y0 -> T y1 -> y2) -> T y0 -> T y1 -> T y2+zipWithTails f =+   curry $ generate (\(xs0,ys0) ->+      do (x,xs) <- viewL xs0+         (_,ys) <- viewL ys0+         return (f x ys0, (xs,ys)))++zipWithRest ::+   (y0 -> y0 -> y1) ->+   T y0 -> T y0 ->+   (T y1, (Bool, T y0))+zipWithRest f xs ys =+   mapPair (fromList, mapSnd fromList) $+   Sig.zipWithRest f+      (toList xs) (toList ys)++zipWithAppend ::+   (y -> y -> y) ->+   T y -> T y -> T y+zipWithAppend f xs ys =+   uncurry append $ mapSnd snd $ zipWithRest f xs ys++delayLoop ::+      (T y -> T y)+            -- ^ processor that shall be run in a feedback loop+   -> T y   -- ^ prefix of the output, its length determines the delay+   -> T y+delayLoop proc prefix =+   let ys = append prefix (proc ys)+   in  ys++delayLoopOverlap ::+   (Additive.C y) =>+      Int+   -> (T y -> T y)+            -- ^ processor that shall be run in a feedback loop+   -> T y   -- ^ input+   -> T y   -- ^ output has the same length as the input+delayLoopOverlap time proc xs =+   let ys = zipWith (Additive.+) xs (delay zero time (proc ys))+   in  ys+++-- maybe candidate for Utility++recourse :: (acc -> Maybe acc) -> acc -> acc+recourse f =+   let aux x = maybe x aux (f x)+   in  aux+
+ src/Synthesizer/Generic/Analysis.hs view
@@ -0,0 +1,326 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts #-}+module Synthesizer.Generic.Analysis where++import qualified Synthesizer.State.Analysis as Ana++import qualified Synthesizer.Generic.Signal as SigG+import qualified Synthesizer.Generic.Signal2 as SigG2++-- import qualified Synthesizer.Plain.Control as Ctrl++-- import qualified Algebra.Module                as Module+-- import qualified Algebra.Transcendental        as Trans+import qualified Algebra.Algebraic             as Algebraic+-- import qualified Algebra.RealField             as RealField+import qualified Algebra.Field                 as Field+import qualified Algebra.Real                  as Real+import qualified Algebra.Ring                  as Ring+import qualified Algebra.Additive              as Additive++import qualified Algebra.NormedSpace.Maximum   as NormedMax+import qualified Algebra.NormedSpace.Euclidean as NormedEuc+import qualified Algebra.NormedSpace.Sum       as NormedSum++-- import qualified Data.Array as Array++-- import qualified Data.IntMap as IntMap++-- import Algebra.Module((*>))++-- import Data.Array (accumArray)++import qualified Prelude as P+import PreludeBase+import NumericPrelude+++{- * Notions of volume -}++{- |+Volume based on Manhattan norm.+-}+volumeMaximum :: (Real.C y, SigG.Read sig y) => sig y -> y+volumeMaximum =+   Ana.volumeMaximum . SigG.toState++{- |+Volume based on Energy norm.+-}+volumeEuclidean :: (Algebraic.C y, SigG.Read sig y) => sig y -> y+volumeEuclidean =+   Ana.volumeEuclidean . SigG.toState++volumeEuclideanSqr :: (Field.C y, SigG.Read sig y) => sig y -> y+volumeEuclideanSqr =+   Ana.volumeEuclideanSqr . SigG.toState++{- |+Volume based on Sum norm.+-}+volumeSum :: (Field.C y, Real.C y, SigG.Read sig y) => sig y -> y+volumeSum =+   Ana.volumeSum . SigG.toState++++{- |+Volume based on Manhattan norm.+-}+volumeVectorMaximum ::+   (NormedMax.C y yv, Ord y, SigG.Read sig yv) =>+   sig yv -> y+volumeVectorMaximum =+   Ana.volumeVectorMaximum . SigG.toState++{- |+Volume based on Energy norm.+-}+volumeVectorEuclidean ::+   (Algebraic.C y, NormedEuc.C y yv, SigG.Read sig yv) =>+   sig yv -> y+volumeVectorEuclidean =+   Ana.volumeVectorEuclidean . SigG.toState++volumeVectorEuclideanSqr ::+   (Field.C y, NormedEuc.Sqr y yv, SigG.Read sig yv) =>+   sig yv -> y+volumeVectorEuclideanSqr =+   Ana.volumeVectorEuclideanSqr . SigG.toState++{- |+Volume based on Sum norm.+-}+volumeVectorSum ::+   (NormedSum.C y yv, Field.C y, SigG.Read sig yv) =>+   sig yv -> y+volumeVectorSum =+   Ana.volumeVectorSum . SigG.toState+++++{- |+Compute minimum and maximum value of the stream the efficient way.+Input list must be non-empty and finite.+-}+bounds :: (Ord y, SigG.Read sig y) => sig y -> (y,y)+bounds =+   Ana.bounds . SigG.toState+++++{- * Miscellaneous -}++{-+histogram:+    length x = sum (histogramDiscrete x)++    units:+    1) histogram (amplify k x) = timestretch k (amplify (1/k) (histogram x))+    2) histogram (timestretch k x) = amplify k (histogram x)+    timestretch: k -> (s -> V) -> (k*s -> V)+    amplify:     k -> (s -> V) -> (s -> k*V)+    histogram:   (a -> b) -> (a^ia*b^ib -> a^ja*b^jb)+    x:           (s -> V)+    1) => (s^ia*(k*V)^ib -> s^ja*(k*V)^jb)+              = (s^ia*V^ib*k -> s^ja*V^jb/k)+       => ib=1, jb=-1+    2) => ((k*s)^ia*V^ib -> (k*s)^ja*V^jb)+              = (s^ia*V^ib -> s^ja*V^jb*k)+       => ia=0, ja=1+    histogram:   (s -> V) -> (V -> s/V)+histogram':+    integral (histogram' x) = integral x+    histogram' (amplify k x) = timestretch k (histogram' x)+    histogram' (timestretch k x) = amplify k (histogram' x)+     -> this does only apply if we slice the area horizontally+        and sum the slice up at each level,+        we must also restrict to the positive values,+        this is not quite the usual histogram+-}++{-+{- |+Input list must be finite.+List is scanned twice, but counting may be faster.+-}+histogramDiscreteArray :: sig Int -> (Int, sig Int)+histogramDiscreteArray [] =+   (error "histogramDiscreteArray: no bounds found", [])+histogramDiscreteArray x =+   let hist =+          accumArray (+) zero+             (bounds x) (attachOne x)+   in  (fst (Array.bounds hist), Array.elems hist)+++{- |+Input list must be finite.+If the input signal is empty, the offset is @undefined@.+List is scanned twice, but counting may be faster.+The sum of all histogram values is one less than the length of the signal.+-}+histogramLinearArray :: RealField.C y => sig y -> (Int, sig y)+histogramLinearArray [] =+   (error "histogramLinearArray: no bounds found", [])+histogramLinearArray [x] = (floor x, [])+histogramLinearArray x =+   let (xMin,xMax) = bounds x+       hist =+          accumArray (+) zero+             (floor xMin, floor xMax)+             (meanValues x)+   in  (fst (Array.bounds hist), Array.elems hist)++{- |+Input list must be finite.+If the input signal is empty, the offset is @undefined@.+List is scanned once, counting may be slower.+-}+histogramDiscreteIntMap :: sig Int -> (Int, sig Int)+histogramDiscreteIntMap [] =+   (error "histogramDiscreteIntMap: no bounds found", [])+histogramDiscreteIntMap x =+   let hist = IntMap.fromListWith (+) (attachOne x)+   in  case IntMap.toAscList hist of+          [] -> error "histogramDiscreteIntMap: the list was non-empty before processing ..."+          fAll@((fIndex,fHead):fs) -> (fIndex, fHead :+              concat (zipWith+                 (\(i0,_) (i1,f1) -> replicate (i1-i0-1) zero ++ [f1])+                 fAll fs))++histogramLinearIntMap :: RealField.C y => sig y -> (Int, sig y)+histogramLinearIntMap [] =+   (error "histogramLinearIntMap: no bounds found", [])+histogramLinearIntMap [x] = (floor x, [])+histogramLinearIntMap x =+   let hist = IntMap.fromListWith (+) (meanValues x)+   -- we can rely on the fact that the keys are contiguous+       (startKey:_, elems) = unzip (IntMap.toAscList hist)+   in  (startKey, elems)+   -- This doesn't work, due to a bug in IntMap of GHC-6.4.1+   -- in  (head (IntMap.keys hist), IntMap.elems hist)+-}++{-+The bug in IntMap GHC-6.4.1 is:++*Synthesizer.Plain.Analysis> IntMap.keys $ IntMap.fromList $ [(0,0),(-1,-1::Int)]+[0,-1]+*Synthesizer.Plain.Analysis> IntMap.elems $ IntMap.fromList $ [(0,0),(-1,-1::Int)]+[0,-1]+*Synthesizer.Plain.Analysis> IntMap.assocs $ IntMap.fromList $ [(0,0),(-1,-1::Int)]+[(0,0),(-1,-1)]++The bug has gone in IntMap as shipped with GHC-6.6.+-}++{-+histogramIntMap :: (RealField.C y, SigG.Read sig y) =>+   y -> sig y -> (Int, sig Int)+histogramIntMap binsPerUnit =+   histogramDiscreteIntMap . quantize binsPerUnit++quantize :: (RealField.C y, SigG.Transform sig y) =>+   y -> sig y -> sig Int+quantize binsPerUnit = SigG.map (floor . (binsPerUnit*))++attachOne :: (Sample.C i) => sig i -> sig (i,Int)+attachOne = SigG.map (\i -> (i,one))++meanValues ::+   (RealField.C y, SigG.Read sig y) => sig y -> [(Int,y)]+meanValues x = concatMap spread (zip x (tail x))++spread ::+   (RealField.C y, SigG.Read sig y) => (y,y) -> [(Int,y)]+spread (l0,r0) =+   let (l,r) = if l0<=r0 then (l0,r0) else (r0,l0)+       (li,lf) = splitFraction l+       (ri,rf) = splitFraction r+       k = recip (r-l)+       nodes =+          (li,k*(1-lf)) :+          zip [li+1 ..] (replicate (ri-li-1) k) +++          (ri, k*rf) :+          []+   in  if li==ri+         then [(li,one)]+         else nodes+-}++{- |+Requires finite length.+This is identical to the arithmetic mean.+-}+directCurrentOffset ::+   (Field.C y, SigG.Read sig y) => sig y -> y+directCurrentOffset = average+++scalarProduct ::+   (Ring.C y, SigG.Read sig y) => sig y -> sig y -> y+scalarProduct xs ys =+   Ana.scalarProduct (SigG.toState xs) (SigG.toState ys)++{- |+'directCurrentOffset' must be non-zero.+-}+centroid :: (Field.C y, SigG.Read sig y) => sig y -> y+centroid =+   Ana.centroid . SigG.toState++average :: (Field.C y, SigG.Read sig y) => sig y -> y+average =+   Ana.average . SigG.toState++rectify :: (Real.C y, SigG.Transform sig y) => sig y -> sig y+rectify = SigG.map abs++{- |+Detects zeros (sign changes) in a signal.+This can be used as a simple measure of the portion+of high frequencies or noise in the signal.+It ca be used as voiced\/unvoiced detector in a vocoder.++@zeros x !! n@ is @True@ if and only if+@(x !! n >= 0) \/= (x !! (n+1) >= 0)@.+The result will be one value shorter than the input.+-}+zeros :: (Ord y, Ring.C y, SigG2.Transform sig y Bool) =>+   sig y -> sig Bool+zeros =+   SigG.mapAdjacent (/=) . SigG2.map (>=zero)++++{- |+Detect thresholds with a hysteresis.+-}+flipFlopHysteresis :: (Ord y, SigG2.Transform sig y Bool) =>+   (y,y) -> Bool -> sig y -> sig Bool+flipFlopHysteresis (lower,upper) =+   SigG2.scanL+      (\state x ->+          if state+            then not(x<lower)+            else x>upper)++{-+{- |+Almost naive implementation of the chirp transform,+a generalization of the Fourier transform.++More sophisticated algorithms like Rader, Cooley-Tukey, Winograd, Prime-Factor may follow.+-}+chirpTransform :: Ring.C y =>+   y -> sig y -> sig y+chirpTransform z xs =+   let powers = Ctrl.curveMultiscaleNeutral (*) z one+       powerPowers =+          SigG.map (\zn -> Ctrl.curveMultiscaleNeutral (*) zn one) powers+   in  SigG.map (scalarProduct xs) powerPowers+-}
+ src/Synthesizer/Generic/Control.hs view
@@ -0,0 +1,352 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts #-}+module Synthesizer.Generic.Control where++import qualified Synthesizer.Generic.Signal as SigG+import qualified Synthesizer.Generic.Signal2 as SigG2++import Synthesizer.Generic.Displacement (raise)++import qualified Algebra.Module                as Module+import qualified Algebra.Transcendental        as Trans+import qualified Algebra.RealField             as RealField+import qualified Algebra.Field                 as Field+import qualified Algebra.Ring                  as Ring+import qualified Algebra.Additive              as Additive++import Algebra.Module((*>))++import Number.Complex (cis,real)+import qualified Number.Complex as Complex++-- import Control.Applicative ((<$>), )++import qualified Prelude as P+import PreludeBase+import NumericPrelude+++{- * Control curve generation -}++constant :: (SigG.Write sig y) =>+   SigG.LazySize -> y -> sig y+constant = SigG.repeat+++linear :: (Additive.C y, SigG.Write sig y) =>+      SigG.LazySize+   -> y   {-^ steepness -}+   -> y   {-^ initial value -}+   -> sig y+          {-^ linear progression -}+linear size d y0 = SigG.iterate size (d+) y0++{- |+Minimize rounding errors by reducing number of operations per element+to a logarithmuc number.+-}+linearMultiscale ::+   (Additive.C y, SigG.Write sig y) =>+      SigG.LazySize+   -> y+   -> y+   -> sig y+linearMultiscale size =+   curveMultiscale size (+)++{- |+Linear curve starting at zero.+-}+linearMultiscaleNeutral :: (Additive.C y, SigG.Write sig y) =>+      SigG.LazySize+   -> y+   -> sig y+linearMultiscaleNeutral size slope =+   curveMultiscaleNeutral size (+) slope zero++{- |+Linear curve of a fixed length.+The final value is not actually reached,+instead we stop one step before.+This way we can concatenate several lines+without duplicate adjacent values.+-}+line :: (Field.C y, SigG.Write sig y) =>+      SigG.LazySize+   -> Int   {-^ length -}+   -> (y,y) {-^ initial and final value -}+   -> sig y+            {-^ linear progression -}+line size n (y0,y1) =+   SigG.take n $ linear size ((y1-y0) / fromIntegral n) y0+++exponential, exponentialMultiscale ::+   (Trans.C y, SigG.Write sig y) =>+      SigG.LazySize+   -> y   {-^ time where the function reaches 1\/e of the initial value -}+   -> y   {-^ initial value -}+   -> sig y+          {-^ exponential decay -}+exponential size time =+   SigG.iterate size (* exp (- recip time))+exponentialMultiscale size time =+   curveMultiscale size (*) (exp (- recip time))++exponentialMultiscaleNeutral :: (Trans.C y, SigG.Write sig y) =>+      SigG.LazySize+   -> y   {-^ time where the function reaches 1\/e of the initial value -}+   -> sig y+          {-^ exponential decay -}+exponentialMultiscaleNeutral size time =+   curveMultiscaleNeutral size (*) (exp (- recip time)) one++exponential2, exponential2Multiscale :: (Trans.C y, SigG.Write sig y) =>+      SigG.LazySize+   -> y   {-^ half life -}+   -> y   {-^ initial value -}+   -> sig y+          {-^ exponential decay -}+exponential2 size halfLife =+   SigG.iterate size (*  0.5 ** recip halfLife)+exponential2Multiscale size halfLife =+   curveMultiscale size (*) (0.5 ** recip halfLife)++exponential2MultiscaleNeutral :: (Trans.C y, SigG.Write sig y) =>+      SigG.LazySize+   -> y   {-^ half life -}+   -> sig y+          {-^ exponential decay -}+exponential2MultiscaleNeutral size halfLife =+   curveMultiscaleNeutral size (*) (0.5 ** recip halfLife) one+++++{-| This is an extension of 'exponential' to vectors+    which is straight-forward but requires more explicit signatures.+    But since it is needed rarely I setup a separate function. -}+vectorExponential ::+   (Trans.C y, Module.C y v, SigG.Write sig v) =>+      SigG.LazySize+   ->  y  {-^ time where the function reaches 1\/e of the initial value -}+   ->  v  {-^ initial value -}+   -> sig v+          {-^ exponential decay -}+vectorExponential size time y0 =+   SigG.iterate size (exp (-1/time) *>) y0++vectorExponential2 ::+   (Trans.C y, Module.C y v, SigG.Write sig v) =>+      SigG.LazySize+   ->  y  {-^ half life -}+   ->  v  {-^ initial value -}+   -> sig v+          {-^ exponential decay -}+vectorExponential2 size halfLife y0 =+   SigG.iterate size (0.5**(1/halfLife) *>) y0++++cosine, cosineMultiscaleLinear :: (Trans.C y, SigG.Write sig y) =>+      SigG.LazySize+   ->  y  {-^ time t0 where  1 is approached -}+   ->  y  {-^ time t1 where -1 is approached -}+   -> sig y+          {-^ a cosine wave where one half wave is between t0 and t1 -}+cosine size = cosineWithSlope $+   \d x -> SigG.map cos (linear size d x)++cosineMultiscaleLinear size = cosineWithSlope $+   \d x -> SigG.map cos (linearMultiscale size d x)++cosineMultiscale ::+   (Trans.C y, SigG.Write sig (Complex.T y),+    SigG2.Transform sig (Complex.T y) y) =>+      SigG.LazySize+   ->  y  {-^ time t0 where  1 is approached -}+   ->  y  {-^ time t1 where -1 is approached -}+   -> sig y+          {-^ a cosine wave where one half wave is between t0 and t1 -}+cosineMultiscale size = cosineWithSlope $+   \d x -> SigG2.map real (curveMultiscale size (*) (cis d) (cis x))+++cosineWithSlope :: (Trans.C y) =>+      (y -> y -> signal)+   ->  y+   ->  y+   -> signal+cosineWithSlope c t0 t1 =+   let inc = pi/(t1-t0)+   in  c inc (-t0*inc)+++cubicHermite :: (Field.C y, SigG.Write sig y) =>+      SigG.LazySize+   -> (y, (y,y)) -> (y, (y,y)) -> sig y+cubicHermite size node0 node1 =+   SigG.map (cubicFunc node0 node1) $ linear size 1 0++{- |+0                                     16+0               8                     16+0       4       8         12          16+0   2   4   6   8   10    12    14    16+0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16+-}+cubicFunc :: (Field.C y) =>+   (y, (y,y)) -> (y, (y,y)) -> y -> y+cubicFunc (t0, (y0,dy0)) (t1, (y1,dy1)) t =+   let dt  = t0-t1+       dt0 = t-t0+       dt1 = t-t1+       x0  = dt1^2+       x1  = dt0^2+   in  ((dy0*dt0 + y0 * (1-2/dt*dt0)) * x0 ++        (dy1*dt1 + y1 * (1+2/dt*dt1)) * x1) / dt^2+{-+cubic t0 (y0,dy0) t1 (y1,dy1) t =+   let x0 = ((t-t1) / (t0-t1))^2+       x1 = ((t-t0) / (t1-t0))^2+   in  y0 * x0 + y1 * x1 ++       (dy0 - y0*2/(t0-t1)) * (t-t0)*x0 ++       (dy1 - y1*2/(t1-t0)) * (t-t1)*x1+-}++++{- |+The curve type of a piece of a piecewise defined control curve.+-}+data Control y =+     CtrlStep+   | CtrlLin+   | CtrlExp {ctrlExpSaturation :: y}+   | CtrlCos+   | CtrlCubic {ctrlCubicGradient0 :: y,+                ctrlCubicGradient1 :: y}+   deriving (Eq, Show)++{- |+The full description of a control curve piece.+-}+data ControlPiece y =+     ControlPiece {pieceType :: Control y,+                   pieceY0 :: y,+                   pieceY1 :: y,+                   pieceDur :: y}+   deriving (Eq, Show)+++newtype PieceRightSingle y = PRS y+newtype PieceRightDouble y = PRD y++type ControlDist y = (y, Control y, y)+++-- precedence and associativity like (:)+infixr 5 -|#, #|-, =|#, #|=, |#, #|++{- |+The 6 operators simplify constructing a list of @ControlPiece a@.+The description consists of nodes (namely the curve values at nodes)+and the connecting curve types.+The naming scheme is as follows:+In the middle there is a bar @|@.+With respect to the bar,+the pad symbol @\#@ is at the side of the curve type,+at the other side there is nothing, a minus sign @-@, or an equality sign @=@.++ (1) Nothing means that here is the start or the end node of a curve.++ (2) Minus means that here is a node where left and right curve meet at the same value.+     The node description is thus one value.++ (3) Equality sign means that here is a split node,+     where left and right curve might have different ending and beginning values, respectively.+     The node description consists of a pair of values.+-}++-- the leading space is necessary for the Haddock parser++( #|-) :: (y, Control y) -> (PieceRightSingle y, [ControlPiece y]) ->+   (ControlDist y, [ControlPiece y])+(d,c) #|- (PRS y1, xs)  =  ((d,c,y1), xs)++(-|#) :: y -> (ControlDist y, [ControlPiece y]) ->+   (PieceRightSingle y, [ControlPiece y])+y0 -|# ((d,c,y1), xs)  =  (PRS y0, ControlPiece c y0 y1 d : xs)++( #|=) :: (y, Control y) -> (PieceRightDouble y, [ControlPiece y]) ->+   (ControlDist y, [ControlPiece y])+(d,c) #|= (PRD y1, xs)  =  ((d,c,y1), xs)++(=|#) :: (y,y) -> (ControlDist y, [ControlPiece y]) ->+   (PieceRightDouble y, [ControlPiece y])+(y01,y10) =|# ((d,c,y11), xs)  =  (PRD y01, ControlPiece c y10 y11 d : xs)++( #|) :: (y, Control y) -> y ->+   (ControlDist y, [ControlPiece y])+(d,c) #| y1  =  ((d,c,y1), [])++(|#) :: y -> (ControlDist y, [ControlPiece y]) ->+   [ControlPiece y]+y0 |# ((d,c,y1), xs)  =  ControlPiece c y0 y1 d : xs+++piecewise :: (Trans.C y, RealField.C y, SigG.Write sig y) =>+   SigG.LazySize -> [ControlPiece y] -> sig y+piecewise size xs =+   let ts = scanl (\(_,fr) d -> splitFraction (fr+d))+                  (0,1) (map pieceDur xs)+   in  SigG.concat (zipWith3+          (\n t (ControlPiece c yi0 yi1 d) ->+               piecewisePart size yi0 yi1 t d n c)+          (map fst (tail ts)) (map (subtract 1 . snd) ts)+          xs)+++piecewisePart :: (Trans.C y, SigG.Write sig y) =>+   SigG.LazySize -> y -> y -> y -> y -> Int -> Control y -> sig y+piecewisePart size y0 y1 t0 d n ctrl =+   SigG.take n+      (case ctrl of+         CtrlStep  -> constant size y0+         CtrlLin   -> let s = (y1-y0)/d in linearMultiscale size s (y0-t0*s)+         CtrlExp s -> let y0' = y0-s; y1' = y1-s; yd = y0'/y1'+                      in  raise s (exponentialMultiscale size (d / log yd)+                                           (y0' * yd**(t0/d)))+         CtrlCos   -> SigG.map+                          (\y -> (1+y)*(y0/2)+(1-y)*(y1/2))+                          (cosineMultiscaleLinear size t0 (t0+d))+         CtrlCubic yd0 yd1 ->+            cubicHermite size (t0,(y0,yd0)) (t0+d,(y1,yd1)))++{-+  exp (-1/time) == yd**(-1/d)+  1/time == log yd / d+  time   == d / log yd+-}++{-+  piecewise (0 |# (10.21, CtrlExp 1.1) #|- 1 -|# (10,CtrlExp 0.49) #|- 0.5 -|# (30, CtrlLin) #|- 0.5 -|# (20, CtrlCos) #| 0)++  piecewise (0 |# (10.21, CtrlExp 1.1) #|- 1 -|# (10,CtrlCubic (-0.1) 0) #|- 0.5 -|# (30, CtrlLin) #|- 0.5 -|# (20, CtrlCos) #| 0)+-}+++{- * Auxiliary functions -}+++curveMultiscale :: (SigG.Write sig y) =>+   SigG.LazySize -> (y -> y -> y) -> y -> y -> sig y+curveMultiscale size op d y0 =+   SigG.cons y0 . SigG.map (op y0) $ SigG.iterateAssociative size op d+++curveMultiscaleNeutral :: (SigG.Write sig y) =>+   SigG.LazySize -> (y -> y -> y) -> y -> y -> sig y+curveMultiscaleNeutral size op d neutral =+   SigG.cons neutral $ SigG.iterateAssociative size op d
+ src/Synthesizer/Generic/Cut.hs view
@@ -0,0 +1,258 @@+{- |+This module allows abstraction of operations+that operate on the time axis+and do also work on signal types without sample values.+The most distinctive instances are certainly+Dirac signals and chunky time values.+-}+module Synthesizer.Generic.Cut where++import qualified Synthesizer.Plain.Signal as Sig+import qualified Synthesizer.State.Signal as SigS+import qualified Synthesizer.FusionList.Signal as SigFL+-- import qualified Synthesizer.Storable.Signal as SigSt+import qualified Data.StorableVector.Lazy as Vector++-- import qualified Algebra.ToInteger as ToInteger+-- import qualified Numeric.NonNegative.Wrapper as NonNegW+import qualified Numeric.NonNegative.Class as NonNeg+import qualified Numeric.NonNegative.Chunky as Chunky++import Foreign.Storable (Storable)++import Data.Function (fix, )+import qualified Data.List as List+import Data.Tuple.HT (mapPair, )+import qualified Data.Monoid as Monoid+import Data.Monoid (Monoid, )++import qualified Prelude as P+import NumericPrelude+import Prelude+   (Bool, Int, String, (++), error,+    pred, (<=), (>=), (<),+    (.), not, (||), (&&), )+++class Read sig where+   null :: sig -> Bool+   length :: sig -> Int++class (Read sig, Monoid sig) => Transform sig where+   {- Monoid functions+   empty :: sig+   cycle :: sig -> sig+   append :: sig -> sig -> sig+   concat :: [sig] -> sig+   -}+   take :: Int -> sig -> sig+   drop :: Int -> sig -> sig+   -- can occur in an inner loop in Interpolation+   dropMarginRem :: Int -> Int -> sig -> (Int, sig)+   splitAt :: Int -> sig -> (sig, sig)+   reverse :: sig -> sig+++-- instance Storable y => Read SigSt.T y where+instance Storable y => Read (Vector.Vector y) where+   {-# INLINE null #-}+   null = Vector.null+   {-# INLINE length #-}+   length = Vector.length++instance Storable y => Transform (Vector.Vector y) where+   {-+   {-# INLINE empty #-}+   empty = Vector.empty+   {-# INLINE cycle #-}+   cycle = Vector.cycle+   {-# INLINE append #-}+   append = Vector.append+   {-# INLINE concat #-}+   concat = Vector.concat+   -}+   {-# INLINE take #-}+   take = Vector.take+   {-# INLINE drop #-}+   drop = Vector.drop+   {-# INLINE splitAt #-}+   splitAt = Vector.splitAt+   {-# INLINE dropMarginRem #-}+   dropMarginRem = Vector.dropMarginRem+   {-# INLINE reverse #-}+   reverse = Vector.reverse+++instance Read ([] y) where+   {-# INLINE null #-}+   null = List.null+   {-# INLINE length #-}+   length = List.length++instance Transform ([] y) where+   {-+   {-# INLINE empty #-}+   empty = []+   {-# INLINE cycle #-}+   cycle = List.cycle+   {-# INLINE append #-}+   append = (List.++)+   {-# INLINE concat #-}+   concat = List.concat+   -}+   {-# INLINE take #-}+   take = List.take+   {-# INLINE drop #-}+   drop = List.drop+   {-# INLINE dropMarginRem #-}+   dropMarginRem = Sig.dropMarginRem+   {-# INLINE splitAt #-}+   splitAt = List.splitAt+   {-# INLINE reverse #-}+   reverse = List.reverse+++instance Read (SigFL.T y) where+   {-# INLINE null #-}+   null = SigFL.null+   {-# INLINE length #-}+   length = SigFL.length++instance Transform (SigFL.T y) where+   {-+   {-# INLINE empty #-}+   empty = SigFL.empty+   {-# INLINE cycle #-}+   cycle = SigFL.cycle+   {-# INLINE append #-}+   append = SigFL.append+   {-# INLINE concat #-}+   concat = SigFL.concat+   -}++   {-# INLINE take #-}+   take = SigFL.take+   {-# INLINE drop #-}+   drop = SigFL.drop+   {-# INLINE dropMarginRem #-}+   dropMarginRem = SigFL.dropMarginRem+   {-# INLINE splitAt #-}+   splitAt = SigFL.splitAt+   {-# INLINE reverse #-}+   reverse = SigFL.reverse+++instance Read (SigS.T y) where+   {-# INLINE null #-}+   null = SigS.null+   {-# INLINE length #-}+   length = SigS.length++instance Transform (SigS.T y) where+   {-+   {-# INLINE empty #-}+   empty = SigS.empty+   {-# INLINE cycle #-}+   cycle = SigS.cycle+   {-# INLINE append #-}+   append = SigS.append+   {-# INLINE concat #-}+   concat = SigS.concat+   -}++   {-# INLINE take #-}+   take = SigS.take+   {-# INLINE drop #-}+   drop = SigS.drop+   {-# INLINE dropMarginRem #-}+   dropMarginRem = SigS.dropMarginRem+   {-# INLINE splitAt #-}+   splitAt n =+      -- This implementation is slow. Better leave it unimplemented?+      mapPair (SigS.fromList, SigS.fromList) .+      List.splitAt n . SigS.toList+   {-# INLINE reverse #-}+   reverse = SigS.reverse+++{-+useful for application of non-negative chunky numbers as gate signals+-}+instance (P.Integral a) => Read (Chunky.T a) where+   {-# INLINE null #-}+   null = List.null . Chunky.toChunks+   {-# INLINE length #-}+   length = sum . List.map (P.fromIntegral . P.toInteger) . Chunky.toChunks+++intToChunky :: (NonNeg.C a) => String -> Int -> Chunky.T a+intToChunky name =+   Chunky.fromNumber .+--   NonNegW.fromNumberMsg ("Generic.Cut."++name) .+   P.fromIntegral .+   (\x ->+      if x<0+        then error ("Generic.Cut.NonNeg.Chunky."++name++": negative argument")+        else x)++instance (P.Integral a, NonNeg.C a) => Transform (Chunky.T a) where+   {-# INLINE take #-}+   take n = P.min (intToChunky "take" n)+   {-# INLINE drop #-}+   drop n x = x NonNeg.-| intToChunky "drop" n+   {-# INLINE dropMarginRem #-}+   dropMarginRem n m x =+      let (z,d,b) =+             Chunky.minMaxDiff+                (intToChunky "dropMargin/n" n)+                (x NonNeg.-| intToChunky "dropMargin/m" m)+      in  (if b then 0 else P.fromIntegral (Chunky.toNumber d),+           x NonNeg.-| z)+   {-# INLINE splitAt #-}+   splitAt n x =+      let (z,d,b) = Chunky.minMaxDiff (intToChunky "splitAt" n) x+      in  (z, if b then d else Chunky.zero)+   {-# INLINE reverse #-}+   reverse = Chunky.fromChunks . P.reverse . Chunky.toChunks+++{-# INLINE empty #-}+empty :: (Monoid sig) => sig+empty = Monoid.mempty++{-# INLINE cycle #-}+cycle :: (Monoid sig) => sig -> sig+cycle x = fix (append x)++{-# INLINE append #-}+append :: (Monoid sig) => sig -> sig -> sig+append = Monoid.mappend++{-# INLINE concat #-}+concat :: (Monoid sig) => [sig] -> sig+concat = Monoid.mconcat+++{- |+Like @lengthAtLeast n xs  =  length xs >= n@,+but is more efficient, because it is more lazy.+-}+{-# INLINE lengthAtLeast #-}+lengthAtLeast :: (Transform sig) =>+   Int -> sig -> Bool+lengthAtLeast n xs =+   n<=0 || not (null (drop (pred n) xs))++{-# INLINE lengthAtMost #-}+lengthAtMost :: (Transform sig) =>+   Int -> sig -> Bool+lengthAtMost n xs =+   n>=0 && null (drop n xs)++{-# INLINE sliceVertical #-}+sliceVertical :: (Transform sig) =>+   Int -> sig -> SigS.T sig+sliceVertical n =+   SigS.map (take n) .+   SigS.takeWhile (not . null) .+   SigS.iterate (drop n)
+ src/Synthesizer/Generic/Displacement.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE NoImplicitPrelude #-}+{- |+<http://en.wikipedia.org/wiki/Particle_displacement>+-}+module Synthesizer.Generic.Displacement where++import qualified Algebra.Additive              as Additive++import qualified Synthesizer.Generic.Signal as SigG++-- import qualified Prelude as P+import PreludeBase+import NumericPrelude+++{- * Mixing -}++{-| Mix two signals.+    In opposition to 'zipWith' the result has the length of the longer signal. -}+mix :: (Additive.C v, SigG.Transform sig v) =>+   sig v -> sig v -> sig v+mix = SigG.mix++{- relict from Prelude98's Num+mixMono :: Ring.C a => [a] -> [a] -> [a]+mixMono [] x  = x+mixMono x  [] = x+mixMono (x:xs) (y:ys) = x+y : mixMono xs ys+-}++{-| Mix one or more signals. -}+mixMulti :: (Additive.C v, SigG.Transform sig v) =>+   [sig v] -> sig v+mixMulti = foldl mix SigG.empty+++{-| Add a number to all of the signal values.+    This is useful for adjusting the center of a modulation. -}+raise :: (Additive.C v, SigG.Transform sig v) =>+   v -> sig v -> sig v+raise x = SigG.map ((+) x)+++{- * Distortion -}+{- |+In "Synthesizer.Basic.Distortion" you find a collection+of appropriate distortion functions.+-}+distort :: (SigG.Read sig c, SigG.Transform sig v) =>+   (c -> v -> v) -> sig c -> sig v -> sig v+distort = SigG.zipWith
+ src/Synthesizer/Generic/Filter/Delay.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE NoImplicitPrelude #-}+module Synthesizer.Generic.Filter.Delay where++import qualified Synthesizer.Generic.Filter.NonRecursive as FiltNR+import qualified Synthesizer.Generic.Interpolation as Interpolation+import qualified Synthesizer.Generic.Signal2 as SigG2+import qualified Synthesizer.Generic.Signal  as SigG++import qualified Algebra.RealField as RealField+import qualified Algebra.Additive  as Additive++-- import qualified Prelude as P+-- import PreludeBase+import NumericPrelude++++{- * Shift -}++{-# INLINE static #-}+static ::+   (Additive.C y, SigG.Write sig y) =>+   Int -> sig y -> sig y+static = FiltNR.delay++{-# INLINE staticPad #-}+staticPad ::+   (SigG.Write sig y) =>+   y -> Int -> sig y -> sig y+staticPad = FiltNR.delayPad++{-# INLINE staticPos #-}+staticPos ::+   (Additive.C y, SigG.Write sig y) =>+   Int -> sig y -> sig y+staticPos = FiltNR.delayPos++{-# INLINE staticNeg #-}+staticNeg ::+   (SigG.Write sig y) =>+   Int -> sig y -> sig y+staticNeg = FiltNR.delayNeg+++++{-# INLINE modulatedCore #-}+modulatedCore ::+   (RealField.C t, Additive.C y, SigG.Read sig t, SigG2.Transform sig t y) =>+   Interpolation.T t y -> Int ->+   sig t -> sig y -> sig y+modulatedCore ip size =+   SigG2.zipWithTails+      (\t -> Interpolation.single ip (fromIntegral size + t))+++{- |+This is essentially different for constant interpolation,+because this function "looks forward"+whereas the other two variants "look backward".+For the symmetric interpolation functions+of linear and cubic interpolation, this does not really matter.+-}+{-# INLINE modulated #-}+modulated ::+   (RealField.C t, Additive.C y,+    SigG.Read sig t, SigG2.Transform sig t y, SigG.Write sig y) =>+   Interpolation.T t y -> Int ->+   sig t -> sig y -> sig y+modulated ip minDev ts xs =+   let size = Interpolation.number ip - minDev+   in  modulatedCore ip+          (size - Interpolation.offset ip)+          ts+          (staticPos size xs)
+ src/Synthesizer/Generic/Filter/NonRecursive.hs view
@@ -0,0 +1,363 @@+{-# LANGUAGE NoImplicitPrelude #-}+{- |+Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes+-}+module Synthesizer.Generic.Filter.NonRecursive where++import qualified Synthesizer.Generic.Signal as SigG++import qualified Synthesizer.Generic.Control as Ctrl++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 qualified Algebra.Ring           as Ring+import qualified Algebra.Additive       as Additive++import Algebra.Module( {- linearComb, -} (*>), )++import Data.Function.HT (nest, )++import PreludeBase+import NumericPrelude++++{- * Envelope application -}++{-# INLINE negate #-}+negate ::+   (Additive.C a, SigG.Transform sig a) =>+   sig a -> sig a+negate = SigG.map Additive.negate++{-# INLINE amplify #-}+amplify ::+   (Ring.C a, SigG.Transform sig a) =>+   a -> sig a -> sig a+amplify v = SigG.map (v*)++{-# INLINE amplifyVector #-}+amplifyVector ::+   (Module.C a v, SigG.Transform sig v) =>+   a -> sig v -> sig v+amplifyVector v = SigG.map (v*>)++{-# INLINE envelope #-}+envelope ::+   (Ring.C a, SigG.Transform sig a) =>+      sig a  {-^ the envelope -}+   -> sig a  {-^ the signal to be enveloped -}+   -> sig a+envelope = SigG.zipWith (*)++{-# INLINE envelopeVector #-}+envelopeVector ::+   (Module.C a v, SigG.Read sig a, SigG.Transform sig v) =>+      sig a  {-^ the envelope -}+   -> sig v  {-^ the signal to be enveloped -}+   -> sig v+envelopeVector = SigG.zipWith (*>)++++{-# INLINE fadeInOut #-}+fadeInOut ::+   (Field.C a, SigG.Write sig a) =>+   Int -> Int -> Int -> sig a -> sig a+fadeInOut tIn tHold tOut xs =+   let slopeIn  =                  recip (fromIntegral tIn)+       slopeOut = Additive.negate (recip (fromIntegral tOut))+       {-+       Since we use the size only for the internal envelope+       no laziness effect can be observed outside the function.+       We could also create the envelope as State.Signal.+       But I assume that concatenating chunks of an envelope+       is more efficient than concatenating generator loops.+       However, our intermediate envelope is still observable,+       because we have to use SigG.Write class.+       -}+       leadIn  = SigG.take tIn  $ Ctrl.linear SigG.defaultLazySize slopeIn  0+       leadOut = SigG.take tOut $ Ctrl.linear SigG.defaultLazySize slopeOut 1+       (partIn, partHoldOut) = SigG.splitAt tIn xs+       (partHold, partOut)   = SigG.splitAt tHold partHoldOut+   in  envelope leadIn partIn `SigG.append`+       partHold `SigG.append`+       envelope leadOut partOut+++{- * Smoothing -}++{-# INLINE delay #-}+delay :: (Additive.C y, SigG.Write sig y) =>+   Int -> sig y -> sig y+delay =+   delayPad zero++{-# INLINE delayPad #-}+delayPad :: (SigG.Write sig y) =>+   y -> Int -> sig y -> sig y+delayPad z n =+   if n<0+     then SigG.drop (Additive.negate n)+     else SigG.append (SigG.replicate SigG.defaultLazySize n z)++{-# INLINE delayPos #-}+delayPos :: (Additive.C y, SigG.Write sig y) =>+   Int -> sig y -> sig y+delayPos n =+   SigG.append (SigG.replicate SigG.defaultLazySize n zero)++{-# INLINE delayNeg #-}+delayNeg :: (SigG.Transform sig y) =>+   Int -> sig y -> sig y+delayNeg = SigG.drop++++{-# INLINE delayLazySize #-}+delayLazySize :: (Additive.C y, SigG.Write sig y) =>+   SigG.LazySize -> Int -> sig y -> sig y+delayLazySize size =+   delayPadLazySize size zero++{- |+The pad value @y@ must be defined,+otherwise the chunk size of the padding can be observed.+-}+{-# INLINE delayPadLazySize #-}+delayPadLazySize :: (SigG.Write sig y) =>+   SigG.LazySize -> y -> Int -> sig y -> sig y+delayPadLazySize size z n =+   if n<0+     then SigG.drop (Additive.negate n)+     else SigG.append (SigG.replicate size n z)++{-# INLINE delayPosLazySize #-}+delayPosLazySize :: (Additive.C y, SigG.Write sig y) =>+   SigG.LazySize -> Int -> sig y -> sig y+delayPosLazySize size n =+   SigG.append (SigG.replicate size n zero)++++{-| Unmodulated non-recursive filter -}+{-# INLINE generic #-}+generic ::+   (Module.C a v, SigG.Transform sig a, SigG.Write sig v) =>+   sig a -> sig v -> sig v+generic m x =+   let mr = SigG.reverse m+       xp = delayPos (pred (SigG.length m)) x+   in  SigG.mapTails (SigG.linearComb mr) xp++{-+{- |+@eps@ is the threshold relatively to the maximum.+That is, if the gaussian falls below @eps * gaussian 0@,+then the function truncated.+-}+gaussian ::+   (Trans.C a, RealField.C a, Module.C a v) =>+   a -> a -> a -> sig v -> sig v+gaussian eps ratio freq =+   let var    = ratioFreqToVariance ratio freq+       area   = var * sqrt (2*pi)+       gau t  = exp (-(t/var)^2/2) / area+       width  = ceiling (var * sqrt (-2 * log eps))  -- inverse gau+       gauSmp = map (gau . fromIntegral) [-width .. width]+   in  drop width . generic gauSmp+-}++{-+GNUPlot.plotList [] (take 1000 $ gaussian 0.001 0.5 0.04 (Filter.Test.chirp 5000) :: [Double])++The filtered chirp must have amplitude 0.5 at 400 (0.04*10000).+-}++{-+  We want to approximate a Gaussian by a binomial filter.+  The latter one can be implemented by a convolutional power.+  However we still require a number of operations per sample+  which is proportional to the variance.+-}+{-# INLINE binomial #-}+binomial ::+   (Trans.C a, RealField.C a, Module.C a v, SigG.Transform sig v) =>+   a -> a -> sig v -> sig v+binomial ratio freq =+   let width = ceiling (2 * ratioFreqToVariance ratio freq ^ 2)+   in  SigG.drop width .+       nest (2*width) (amplifyVector (asTypeOf 0.5 freq) . binomial1)++{-+exp (-(t/var)^2/2) / area *> cis (2*pi*f*t)+  == exp (-(t/var)^2/2 +: 2*pi*f*t) / area+  == exp ((-t^2 +: 2*var^2*2*pi*f*t) / (2*var^2)) / area+  == exp ((t^2 - i*2*var^2*2*pi*f*t) / (-2*var^2)) / area+  == exp (((t^2 - i*var^2*2*pi*f)^2 + (var^2*2*pi*f)^2) / (-2*var^2)) / area+  == exp (((t^2 - i*var^2*2*pi*f)^2 / (-2*var^2) - (var*2*pi*f)^2/2)) / area++sumMap (\t -> exp (-(t/var)^2/2) / area *> cis (2*pi*f*t))+       [-infinity..infinity]+  ~ sumMap (\t -> exp (-(t/var)^2/2)) [-infinity..infinity]+       * exp (-(var*2*pi*f)^2/2) / area+  = exp (-(var*2*pi*f)^2/2)+-}+{- |+  Compute the variance of the Gaussian+  such that its Fourier transform has value @ratio@ at frequency @freq@.+-}+{-# INLINE ratioFreqToVariance #-}+ratioFreqToVariance :: (Trans.C a) => a -> a -> a+ratioFreqToVariance ratio freq =+   sqrt (Additive.negate (2 * log ratio)) / (2*pi*freq)+           -- inverse of the fourier transformed gaussian++{-# INLINE binomial1 #-}+binomial1 ::+   (Additive.C v, SigG.Transform sig v) => sig v -> sig v+binomial1 = SigG.mapAdjacent (+)++++++{- |+Moving (uniformly weighted) average in the most trivial form.+This is very slow and needs about @n * length x@ operations.+-}+{-# INLINE sums #-}+sums ::+   (Additive.C v, SigG.Transform sig v) =>+   Int -> sig v -> sig v+sums n = SigG.mapTails (SigG.sum . SigG.take n)+++{-+sumsDownsample2 :: (Additive.C v) => sig v -> sig v+sumsDownsample2 (x0:x1:xs) = (x0+x1) : sumsDownsample2 xs+sumsDownsample2 xs         = xs++downsample2 :: sig a -> sig a+downsample2 (x0:_:xs) = x0 : downsample2 xs+downsample2 xs        = xs+++{- |+Given a list of numbers+and a list of sums of (2*k) of successive summands,+compute a list of the sums of (2*k+1) or (2*k+2) summands.++Eample for 2*k+1++@+ [0+1+2+3, 2+3+4+5, 4+5+6+7, ...] ->+    [0+1+2+3+4, 1+2+3+4+5, 2+3+4+5+6, 3+4+5+6+7, 4+5+6+7+8, ...]+@++Example for 2*k+2++@+ [0+1+2+3, 2+3+4+5, 4+5+6+7, ...] ->+    [0+1+2+3+4+5, 1+2+3+4+5+6, 2+3+4+5+6+7, 3+4+5+6+7+8, 4+5+6+7+8+9, ...]+@+-}+sumsUpsampleOdd :: (Additive.C v) => Int -> sig v -> sig v -> sig v+sumsUpsampleOdd n {- 2*k -} xs ss =+   let xs2k = drop n xs+   in  (head ss + head xs2k) :+          concat (zipWith3 (\s x0 x2k -> [x0+s, s+x2k])+                           (tail ss)+                           (downsample2 (tail xs))+                           (tail (downsample2 xs2k)))++sumsUpsampleEven :: (Additive.C v) => Int -> sig v -> sig v -> sig v+sumsUpsampleEven n {- 2*k -} xs ss =+   sumsUpsampleOdd (n+1) xs (zipWith (+) ss (downsample2 (drop n xs)))++sumsPyramid :: (Additive.C v) => Int -> sig v -> sig v+sumsPyramid n xs =+   let aux 1 ys = ys+       aux 2 ys = ys + tail ys+       aux m ys =+          let ysd = sumsDownsample2 ys+          in  if even m+                then sumsUpsampleEven (m-2) ys (aux (div (m-2) 2) ysd)+                else sumsUpsampleOdd  (m-1) ys (aux (div (m-1) 2) ysd)+   in  aux n xs+++propSums :: Bool+propSums =+   let n  = 1000+       xs = [0::Double ..]+       naive   =              sums        n xs+       rec     = drop (n-1) $ sumsRec     n xs+       pyramid =              sumsPyramid n xs+   in  and $ take 1000 $+         zipWith3 (\x y z -> x==y && y==z) naive rec pyramid++-}++++{- * Filter operators from calculus -}++{- |+Forward difference quotient.+Shortens the signal by one.+Inverts 'Synthesizer.Generic.Filter.Recursive.Integration.run' in the sense that+@differentiate (zero : integrate x) == x@.+The signal is shifted by a half time unit.+-}+{-# INLINE differentiate #-}+differentiate ::+   (Additive.C v, SigG.Transform sig v) =>+   sig v -> sig v+differentiate x = SigG.mapAdjacent subtract x++{- |+Central difference quotient.+Shortens the signal by two elements,+and shifts the signal by one element.+(Which can be fixed by prepending an appropriate value.)+For linear functions this will yield+essentially the same result as 'differentiate'.+You obtain the result of 'differentiateCenter'+if you smooth the one of 'differentiate'+by averaging pairs of adjacent values.++ToDo: Vector variant+-}+{-+This implementation is a bit cumbersome,+but it fits both StorableVector and State.Signal+(since it avoids recomputation).+-}+{-# INLINE differentiateCenter #-}+differentiateCenter ::+   (Field.C v, SigG.Transform sig v) =>+   sig v -> sig v+differentiateCenter =+   SigG.drop 2 .+   SigG.crochetL+      (\x0 (x1,x2) -> Just ((x2-x0)/2, (x0,x1)))+      (zero,zero)++{- |+Second derivative.+It is @differentiate2 == differentiate . differentiate@+but 'differentiate2' should be faster.+-}+{-# INLINE differentiate2 #-}+differentiate2 ::+   (Additive.C v, SigG.Transform sig v) =>+   sig v -> sig v+differentiate2 = differentiate . differentiate
+ src/Synthesizer/Generic/Filter/Recursive/Comb.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{- |+Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes++Comb filters, useful for emphasis of tones with harmonics+and for repeated echos.+-}+module Synthesizer.Generic.Filter.Recursive.Comb where++import qualified Synthesizer.Generic.Filter.NonRecursive as Filt+import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1++import qualified Synthesizer.Generic.Signal as SigG++import qualified Algebra.Module                as Module+-- import qualified Algebra.Field                 as Field+import qualified Algebra.Ring                  as Ring+import qualified Algebra.Additive              as Additive++import qualified Prelude as P+import PreludeBase+import NumericPrelude+++{- |+The most simple version of the Karplus-Strong algorithm+which is suitable to simulate a plucked string.+It is similar to the 'runProc' function.+-}+{-# INLINE karplusStrong #-}+karplusStrong ::+   (Ring.C t, Module.C t y, SigG.Write sig y) =>+   Filt1.Parameter t -> sig y -> sig y+karplusStrong c wave =+   SigG.delayLoop (SigG.modifyStatic Filt1.lowpassModifier c) wave+++{- |+Infinitely many equi-delayed exponentially decaying echos.+The echos are clipped to the input length.+We think it is easier (and simpler to do efficiently)+to pad the input with zeros or whatever+instead of cutting the result according to the input length.+-}+{-# INLINE run #-}+run :: (Module.C t y, SigG.Write sig y) =>+   Int -> t -> sig y -> sig y+run time gain =+   runProc time (Filt.amplifyVector gain)++{- |+Echos of different delays.+Chunk size must be smaller than all of the delay times.+-}+{-# INLINE runMulti #-}+runMulti :: (Ring.C t, Module.C t y, SigG.Write sig y) =>+   [Int] -> t -> sig y -> sig y+runMulti times gain x =+    let y = foldl+               (SigG.zipWith (+)) x+               (map (flip Filt.delay (Filt.amplifyVector gain y)) times)+--               (map (flip Delay.staticPos (gain *> y)) times)+    in  y++{- | Echos can be piped through an arbitrary signal processor. -}+{-# INLINE runProc #-}+runProc :: (Additive.C y, SigG.Write sig y) =>+   Int -> (sig y -> sig y) -> sig y -> sig y+runProc = SigG.delayLoopOverlap
+ src/Synthesizer/Generic/Filter/Recursive/Integration.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE NoImplicitPrelude #-}+{- |+Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes++Filter operators from calculus+-}+module Synthesizer.Generic.Filter.Recursive.Integration where++import qualified Synthesizer.Generic.Signal as SigG++-- import qualified Algebra.Field                 as Field+-- import qualified Algebra.Ring                  as Ring+import qualified Algebra.Additive              as Additive++import PreludeBase+import NumericPrelude++++{- |+Integrate with initial value zero.+However the first emitted value is the value of the input signal.+It maintains the length of the signal.+-}+{-# INLINE run #-}+run :: (Additive.C v, SigG.Transform sig v) =>+   sig v -> sig v+run =+   SigG.crochetL (\x acc -> let y = x+acc in Just (y,y)) zero+   -- scanl1 (+)++{- |+Integrate with initial condition.+First emitted value is the initial condition.+The signal become one element longer.+-}+{-# INLINE runInit #-}+runInit :: (Additive.C v, SigG.Transform sig v) =>+   v -> sig v -> sig v+runInit = SigG.scanL (+)++{- other quadrature methods may follow -}
+ src/Synthesizer/Generic/Filter/Recursive/MovingAverage.hs view
@@ -0,0 +1,178 @@+{-# LANGUAGE NoImplicitPrelude #-}+{- |+Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes++-}+module Synthesizer.Generic.Filter.Recursive.MovingAverage+   (sumsStaticInt,+    modulatedFrac,+    ) where++import qualified Synthesizer.Generic.Signal  as SigG+import qualified Synthesizer.Generic.Signal2 as SigG2++import qualified Synthesizer.Generic.Filter.Recursive.Integration as Integration+import qualified Synthesizer.Generic.Filter.Delay as Delay++import qualified Synthesizer.State.Signal as SigS++import Data.Function.HT (nest, )++import qualified Algebra.Module                as Module+import qualified Algebra.RealField             as RealField++-- import qualified Algebra.Field                 as Field+-- import qualified Algebra.Ring                  as Ring+import qualified Algebra.Additive              as Additive++import PreludeBase+import NumericPrelude++++{- |+Like 'Synthesizer.Generic.Filter.NonRecursive.sums' but in a recursive form.+This needs only linear time (independent of the window size)+but may accumulate rounding errors.++@+ys = xs * (1,0,0,0,-1) \/ (1,-1)+ys * (1,-1) = xs * (1,0,0,0,-1)+ys = xs * (1,0,0,0,-1) + ys * (0,1)+@+-}+{-# INLINE sumsStaticInt #-}+sumsStaticInt :: (Additive.C v, SigG.Write sig v) =>+   Int -> sig v -> sig v+sumsStaticInt n xs =+   Integration.run (sub xs (Delay.staticPos n xs))+++{-# INLINE sub #-}+sub :: (Additive.C v, SigG.Transform sig v) =>+   sig v -> sig v -> sig v+sub xs ys =+   SigG.mix xs (SigG.map Additive.negate ys)+++{-+Sum of a part of a vector with negative sign for reverse order.+It adds from @from@ (inclusively) to @to@ (exclusively),+that is, it sums up @abs (to-from)@ values++{-# INLINE sumFromTo #-}+sumFromTo :: (Additive.C v) => Int -> Int -> sig v -> v+sumFromTo from to =+   if from <= to+     then          Sig.sum . Sig.take (to-from) . Sig.drop from+     else negate . Sig.sum . Sig.take (from-to) . Sig.drop to+-}++{-# INLINE sumFromToFrac #-}+sumFromToFrac ::+   (RealField.C a, Module.C a v, SigG.Transform sig v) =>+   a -> a -> sig v -> v+sumFromToFrac from to xs =+   let (fromInt, fromFrac) = splitFraction from+       (toInt,   toFrac)   = splitFraction to+   in  case compare fromInt toInt of+          EQ -> (to-from) *> index zero fromInt xs+          LT ->+            (addNext ((1-fromFrac) *>) $+             nest (toInt-fromInt-1) (addNext id) $+             addNext (toFrac *>) $+             const)+            zero (SigG.drop fromInt xs)+          GT ->+            (addNext ((1-toFrac) *>) $+             nest (fromInt-toInt-1) (addNext id) $+             addNext (fromFrac *>) $+             const)+            zero (SigG.drop toInt xs)+++{-# INLINE index #-}+index ::+   (SigG.Transform sig y) =>+   y -> Int -> sig y -> y+index deflt n =+   maybe deflt fst . SigG.viewL . SigG.drop n+++{-# INLINE addNext #-}+addNext ::+   (Additive.C v, SigG.Read sig a) =>+   (a -> v) -> (v -> sig a -> v) -> v -> sig a -> v+addNext f next s =+   SigG.switchL s+      (\y ys -> next (s + f y) ys)+++{- |+@sig a@ must contain only non-negative elements.+-}+{-# INLINE sumDiffsModulated #-}+sumDiffsModulated ::+   (RealField.C a, Module.C a v, SigG2.Transform sig a v) =>+   a -> sig a -> sig v -> sig v+sumDiffsModulated d ds =+   maybe (error "MovingAverage: signal must be non-empty because we prepended a zero before") fst .+   SigG.viewR .+   -- prevent negative d's since 'drop' cannot restore past values+   zipRangesWithTails sumFromToFrac+      (SigG.cons (d+1) ds) (SigG.map (1+) ds) .+   SigG.cons zero++{-+   zipRangesWithTails sumFromToFrac+      (SigG.cons d (SigG.map (subtract 1) ds)) ds+-}++zipRangesWithTails ::+   (SigG2.Transform sig a v) =>+   (a -> a -> sig v -> v) -> sig a -> sig a -> sig v -> sig v+zipRangesWithTails f tls tus xs =+   SigG2.zipWithState+      (\(tl,suffix) tu -> f tl tu suffix)+      (SigS.zip (SigG.toState tls) (SigG.tails xs))+      tus++{-+{-# INLINE sumsModulated #-}+sumsModulated :: (RealField.C a, Module.C a v) =>+   Int -> sig a -> sig v -> sig v+sumsModulated maxDInt ds xs =+   let maxD  = fromIntegral maxDInt+       posXs = sumDiffsModulated 0 ds xs+       negXs = sumDiffsModulated maxD (SigG.map (maxD-) ds) (Delay.static maxDInt xs)+   in  Integration.run (sub posXs negXs)+-}++{- |+Shift sampling points by a half sample period+in order to preserve signals for window widths below 1.+-}+{-# INLINE sumsModulatedHalf #-}+sumsModulatedHalf ::+   (RealField.C a, Module.C a v, SigG2.Transform sig a v, SigG.Write sig v) =>+   Int -> sig a -> sig v -> sig v+sumsModulatedHalf maxDInt ds xs =+   let maxD  = fromIntegral maxDInt+       d0    = maxD+0.5+       delXs = Delay.staticPos maxDInt xs+       posXs = sumDiffsModulated d0 (SigG.map (d0+) ds) delXs+       negXs = sumDiffsModulated d0 (SigG.map (d0-) ds) delXs+   in  Integration.run (sub posXs negXs)++{-# INLINE modulatedFrac #-}+modulatedFrac ::+   (RealField.C a, Module.C a v, SigG2.Transform sig a v, SigG.Write sig v) =>+   Int -> sig a -> sig v -> sig v+modulatedFrac maxDInt ds xs =+   SigG.zipWith (\d y -> recip (2*d) *> y) ds $+   sumsModulatedHalf maxDInt ds xs
+ src/Synthesizer/Generic/Interpolation.hs view
@@ -0,0 +1,184 @@+{-# LANGUAGE NoImplicitPrelude #-}+module Synthesizer.Generic.Interpolation (+   T, func, offset, number,+   zeroPad, constantPad, cyclicPad, extrapolationPad,+   single,+   multiRelative,+   multiRelativeZeroPad, multiRelativeConstantPad,+   multiRelativeCyclicPad, multiRelativeExtrapolationPad,+   multiRelativeZeroPadConstant, multiRelativeZeroPadLinear,+   multiRelativeZeroPadCubic,+   ) where++import qualified Synthesizer.Interpolation as Interpolation+import Synthesizer.Interpolation (T, offset, number, )+import Synthesizer.Interpolation.Module (constant, linear, cubic, )++import qualified Synthesizer.Generic.Signal  as SigG+import qualified Synthesizer.Generic.Signal2 as SigG2+import qualified Synthesizer.Generic.Filter.NonRecursive as FiltNR++import qualified Algebra.Module    as Module+import qualified Algebra.RealField as RealField+-- import qualified Algebra.Field     as Field+-- import qualified Algebra.Ring      as Ring+import qualified Algebra.Additive  as Additive++import Algebra.Additive(zero, )+import Data.Maybe (fromMaybe, )++import PreludeBase+import NumericPrelude+++{-* Interpolation with various padding methods -}++{-# INLINE zeroPad #-}+zeroPad :: (RealField.C t, SigG.Write sig y) =>+   (T t y -> t -> sig y -> a) ->+   y -> T t y -> t -> sig y -> a+zeroPad interpolate z ip phase x =+   let (phInt, phFrac) = splitFraction phase+   in  interpolate ip phFrac+          (FiltNR.delayPad z (offset ip - phInt)+              (SigG.append x (SigG.repeat SigG.defaultLazySize z)))++{-# INLINE constantPad #-}+constantPad :: (RealField.C t, SigG.Write sig y) =>+   (T t y -> t -> sig y -> a) ->+   T t y -> t -> sig y -> a+constantPad interpolate ip phase x =+   let (phInt, phFrac) = splitFraction phase+       xPad =+          do (xFirst,_) <- SigG.viewL x+             return (FiltNR.delayPad xFirst+                (offset ip - phInt) (SigG.extendConstant SigG.defaultLazySize x))+   in  interpolate ip phFrac+          (fromMaybe SigG.empty xPad)+++{- |+Only for finite input signals.+-}+{-# INLINE cyclicPad #-}+cyclicPad :: (RealField.C t, SigG.Transform sig y) =>+   (T t y -> t -> sig y -> a) ->+   T t y -> t -> sig y -> a+cyclicPad interpolate ip phase x =+   let (phInt, phFrac) = splitFraction phase+   in  interpolate ip phFrac+          (SigG.drop (mod (phInt - offset ip) (SigG.length x)) (SigG.cycle x))++{- |+The extrapolation may miss some of the first and some of the last points+-}+{-# INLINE extrapolationPad #-}+extrapolationPad :: (RealField.C t, SigG.Transform sig y) =>+   (T t y -> t -> sig y -> a) ->+   T t y -> t -> sig y -> a+extrapolationPad interpolate ip phase =+   interpolate ip (phase - fromIntegral (offset ip))+{-+  This example shows pikes, although there shouldn't be any:+   plotList (take 100 $ interpolate (Zero (0::Double)) ipCubic (-0.9::Double) (repeat 0.03) [1,0,1,0.8])+-}+++{-* Interpolation of multiple values with various padding methods -}++func :: (SigG.Read sig y) =>+   T t y -> t -> sig y -> y+func ip phase =+   Interpolation.func ip phase . SigG.toState++{-# INLINE skip #-}+skip :: (RealField.C t, SigG.Transform sig y) =>+   T t y -> (t, sig y) -> (t, sig y)+skip ip (phase0, x0) =+   let (n, frac) = splitFraction phase0+       (m, x1) = SigG.dropMarginRem (number ip) n x0+   in  (fromIntegral m + frac, x1)++{-# INLINE single #-}+single :: (RealField.C t, SigG.Transform sig y) =>+   T t y -> t -> sig y -> y+single ip phase0 x0 =+   uncurry (func ip) $ skip ip (phase0, x0)+--   curry (uncurry (func ip) . skip ip)+{-+GNUPlot.plotFunc [] (GNUPlot.linearScale 1000 (0,2)) (\t -> single linear (t::Double) [0,4,1::Double])+-}+++{-* Interpolation of multiple values with various padding methods -}++{- | All values of frequency control must be non-negative. -}+{-# INLINE multiRelative #-}+multiRelative ::+   (RealField.C t, SigG2.Transform sig t y) =>+   T t y -> t -> sig y -> sig t -> sig y+multiRelative ip phase0 x0 =+   SigG2.crochetL+      (\freq pos ->+          let (phase,x) = skip ip pos+          in  Just (func ip phase x, (phase+freq,x)))+      (phase0,x0)+++{-# INLINE multiRelativeZeroPad #-}+multiRelativeZeroPad ::+   (RealField.C t, SigG2.Transform sig t y, SigG.Write sig y) =>+   y -> T t y -> t -> sig t -> sig y -> sig y+multiRelativeZeroPad z ip phase fs x =+   zeroPad multiRelative z ip phase x fs++{-# INLINE multiRelativeConstantPad #-}+multiRelativeConstantPad ::+   (RealField.C t, SigG2.Transform sig t y, SigG.Write sig y) =>+   T t y -> t -> sig t -> sig y -> sig y+multiRelativeConstantPad ip phase fs x =+   constantPad multiRelative ip phase x fs++{-# INLINE multiRelativeCyclicPad #-}+multiRelativeCyclicPad ::+   (RealField.C t, SigG2.Transform sig t y) =>+   T t y -> t -> sig t -> sig y -> sig y+multiRelativeCyclicPad ip phase fs x =+   cyclicPad multiRelative ip phase x fs++{- |+The extrapolation may miss some of the first and some of the last points+-}+{-# INLINE multiRelativeExtrapolationPad #-}+multiRelativeExtrapolationPad ::+   (RealField.C t, SigG2.Transform sig t y) =>+   T t y -> t -> sig t -> sig y -> sig y+multiRelativeExtrapolationPad ip phase fs x =+   extrapolationPad multiRelative ip phase x fs+{-+  This example shows pikes, although there shouldn't be any:+   plotList (take 100 $ interpolate (Zero (0::Double)) ipCubic (-0.9::Double) (repeat 0.03) [1,0,1,0.8])+-}++{-* All-in-one interpolation functions -}++{-# INLINE multiRelativeZeroPadConstant #-}+multiRelativeZeroPadConstant ::+   (RealField.C t, Additive.C y, SigG2.Transform sig t y, SigG.Write sig y) =>+   t -> sig t -> sig y -> sig y+multiRelativeZeroPadConstant =+   multiRelativeZeroPad zero constant++{-# INLINE multiRelativeZeroPadLinear #-}+multiRelativeZeroPadLinear ::+   (RealField.C t, Module.C t y, SigG2.Transform sig t y, SigG.Write sig y) =>+   t -> sig t -> sig y -> sig y+multiRelativeZeroPadLinear =+   multiRelativeZeroPad zero linear++{-# INLINE multiRelativeZeroPadCubic #-}+multiRelativeZeroPadCubic ::+   (RealField.C t, Module.C t y, SigG2.Transform sig t y, SigG.Write sig y) =>+   t -> sig t -> sig y -> sig y+multiRelativeZeroPadCubic =+   multiRelativeZeroPad zero cubic
+ src/Synthesizer/Generic/Noise.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE FlexibleContexts #-}+{- | Noise and random processes. -}+module Synthesizer.Generic.Noise where++import qualified Synthesizer.State.Noise as Noise++import qualified Synthesizer.Generic.Signal  as SigG+import qualified Synthesizer.Generic.Signal2 as SigG2+import qualified Synthesizer.State.Signal      as SigS++import qualified Algebra.Real                  as Real+import qualified Algebra.Ring                  as Ring++import System.Random (Random, RandomGen, randomR, mkStdGen, )+import qualified System.Random as Rnd++import qualified Prelude as P+import PreludeBase+import NumericPrelude+++{-|+Deterministic white noise, uniformly distributed between -1 and 1.+That is, variance is 1\/3.+-}+white ::+   (Ring.C y, Random y, SigG.Write sig y) =>+   SigG.LazySize -> sig y+white size =+   SigG.fromState size $ Noise.white++whiteGen ::+   (Ring.C y, Random y, RandomGen g, SigG.Write sig y) =>+   SigG.LazySize -> g -> sig y+whiteGen size =+   SigG.fromState size . Noise.whiteGen+++{- |+Approximates normal distribution with variance 1+by a quadratic B-spline distribution.+-}+whiteQuadraticBSplineGen ::+   (Ring.C y, Random y, RandomGen g, SigG.Write sig y) =>+   SigG.LazySize -> g -> sig y+whiteQuadraticBSplineGen size =+   SigG.fromState size . Noise.whiteQuadraticBSplineGen+++randomPeeks ::+   (Real.C y, Random y, SigG2.Transform sig y Bool) =>+      sig y    {- ^ momentary densities, @p@ means that there is about one peak+                      in the time range of @1\/p@ samples -}+   -> sig Bool {- ^ Every occurence of 'True' represents a peak. -}+randomPeeks =+   randomPeeksGen (mkStdGen 876)++randomPeeksGen ::+   (Real.C y, Random y, RandomGen g, SigG2.Transform sig y Bool) =>+      g+   -> sig y+   -> sig Bool+randomPeeksGen =+   SigG2.zipWithState (<) . SigS.unfoldR (Just . randomR (0,1))
+ src/Synthesizer/Generic/Oscillator.hs view
@@ -0,0 +1,162 @@+{-# LANGUAGE NoImplicitPrelude #-}+{- |+Copyright   :  (c) Henning Thielemann 2006+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes++Tone generators++Frequencies are always specified in ratios of the sample rate,+e.g. the frequency 0.01 for the sample rate 44100 Hz+means a physical frequency of 441 Hz.+-}+module Synthesizer.Generic.Oscillator where++import qualified Synthesizer.State.Oscillator as OsciS+import qualified Synthesizer.Causal.Oscillator as OsciC+import qualified Synthesizer.Causal.Process as Causal++import qualified Synthesizer.Basic.Wave       as Wave+import qualified Synthesizer.Basic.Phase      as Phase++import qualified Synthesizer.Causal.Interpolation as Interpolation++import qualified Synthesizer.Generic.Signal  as SigG+import qualified Synthesizer.Generic.Signal2 as SigG2++import Control.Arrow ((>>>), )++{-+import qualified Algebra.RealTranscendental    as RealTrans+import qualified Algebra.Module                as Module+import qualified Algebra.VectorSpace           as VectorSpace++import Algebra.Module((*>))+-}+import qualified Algebra.Transcendental        as Trans+import qualified Algebra.RealField             as RealField+-- import qualified Algebra.Field                 as Field+import qualified Algebra.Ring                  as Ring+import qualified Algebra.Additive              as Additive++-- import qualified Number.NonNegative       as NonNeg++import NumericPrelude++-- import qualified Prelude as P+import PreludeBase++++{- * Oscillators with arbitrary but constant waveforms -}++{- | oscillator with constant frequency -}+static :: (RealField.C a, SigG.Write sig b) =>+   SigG.LazySize ->+   Wave.T a b -> (Phase.T a -> a -> sig b)+static size wave phase freq =+   SigG.fromState size (OsciS.static wave phase freq)++{- | oscillator with modulated frequency -}+freqMod :: (RealField.C a, SigG2.Transform sig a b) =>+   Wave.T a b -> Phase.T a -> sig a -> sig b+freqMod wave phase =+   Causal.applyGeneric (OsciC.freqMod wave phase)++{- | oscillator with modulated phase -}+phaseMod :: (RealField.C a, SigG2.Transform sig a b) =>+   Wave.T a b -> a -> sig a -> sig b+phaseMod wave =+   shapeMod (Wave.phaseOffset wave) zero++{- | oscillator with modulated shape -}+shapeMod :: (RealField.C a, SigG2.Transform sig c b) =>+   (c -> Wave.T a b) -> Phase.T a -> a -> sig c -> sig b+shapeMod wave phase freq =+   Causal.applyGeneric (OsciC.shapeMod wave phase freq)++{- | oscillator with both phase and frequency modulation -}+phaseFreqMod :: (RealField.C a, SigG2.Transform sig a b) =>+   Wave.T a b -> sig a -> sig a -> sig b+phaseFreqMod wave =+   shapeFreqMod (Wave.phaseOffset wave) zero++{- | oscillator with both shape and frequency modulation -}+shapeFreqMod ::+   (RealField.C a, SigG.Read sig c, SigG2.Transform sig a b) =>+   (c -> Wave.T a b) -> Phase.T a -> sig c -> sig a -> sig b+shapeFreqMod wave phase parameters =+   Causal.applyGeneric+      (Causal.feedGenericFst parameters >>>+       OsciC.shapeFreqMod wave phase)+++{- | oscillator with a sampled waveform with constant frequency+This is essentially an interpolation with cyclic padding.+-}+staticSample :: (RealField.C a, SigG.Read wave b, SigG.Write sig b) =>+   SigG.LazySize ->+   Interpolation.T a b -> wave b -> Phase.T a -> a -> sig b+staticSample size ip wave phase freq =+   let len = fromIntegral $ SigG.length wave+   in  SigG.fromState size $+       Interpolation.relativeCyclicPad+          ip (len * Phase.toRepresentative phase)+          (SigG.toState wave)+       `Causal.applyConst`+       (freq * len)++{- | oscillator with a sampled waveform with modulated frequency+Should behave homogenously for different types of interpolation.+-}+freqModSample :: (RealField.C a, SigG.Read wave b, SigG2.Transform sig a b) =>+   Interpolation.T a b -> wave b -> Phase.T a -> sig a -> sig b+freqModSample ip wave phase freqs =+   let len = fromIntegral $ SigG.length wave+   in  Interpolation.relativeCyclicPad+          ip (len * Phase.toRepresentative phase)+          (SigG.toState wave)+       `Causal.applyGeneric`+       SigG.map (* len) freqs+++{-+Shape+phase modulating oscillators can be found in Causal.Oscillator.+-}++{- * Oscillators with specific waveforms -}++{- | sine oscillator with static frequency -}+staticSine :: (Trans.C a, RealField.C a, SigG.Write sig a) =>+   SigG.LazySize ->+   Phase.T a -> a -> sig a+staticSine size =+   static size Wave.sine++{- | sine oscillator with modulated frequency -}+freqModSine :: (Trans.C a, RealField.C a, SigG.Transform sig a) =>+   Phase.T a -> sig a -> sig a+freqModSine phase =+   Causal.applyGenericSameType (OsciC.freqMod Wave.sine phase)++{- | sine oscillator with modulated phase, useful for FM synthesis -}+phaseModSine :: (Trans.C a, RealField.C a, SigG.Transform sig a) =>+   a -> sig a -> sig a+phaseModSine freq =+   Causal.applyGenericSameType (OsciC.phaseMod Wave.sine freq)++{- | saw tooth oscillator with modulated frequency -}+staticSaw :: (RealField.C a, SigG.Write sig a) =>+   SigG.LazySize ->+   Phase.T a -> a -> sig a+staticSaw size =+   static size Wave.saw++{- | saw tooth oscillator with modulated frequency -}+freqModSaw :: (RealField.C a, SigG.Transform sig a) =>+   Phase.T a -> sig a -> sig a+freqModSaw phase =+   Causal.applyGenericSameType (OsciC.freqMod Wave.saw phase)
+ src/Synthesizer/Generic/Signal.hs view
@@ -0,0 +1,521 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{- |+Type classes that give a uniform interface to+storable signals, stateful signals, lists, fusable lists.+Some of the signal types require constraints on the element type.+Storable signals require Storable elements.+Thus we need multiparameter type classes.+In this module we collect functions+where the element type is not altered by the function.+-}+module Synthesizer.Generic.Signal+   (module Synthesizer.Generic.Signal,+    Cut.null,+    Cut.length,+    Cut.empty,+    Cut.cycle,+    Cut.append,+    Cut.concat,+    Cut.take,+    Cut.drop,+    Cut.dropMarginRem,+    Cut.splitAt,+    Cut.reverse,+    Cut.lengthAtLeast,+    Cut.lengthAtMost,+    Cut.sliceVertical,+   ) where++import Synthesizer.Generic.Cut (append, )+import qualified Synthesizer.Generic.Cut as Cut++import qualified Synthesizer.Plain.Signal as Sig+import qualified Synthesizer.State.Signal as SigS+import qualified Synthesizer.FusionList.Signal as SigFL+import qualified Synthesizer.Storable.Signal as SigSt+import qualified Data.StorableVector.Lazy as Vector++import qualified Synthesizer.Plain.Modifier as Modifier++import qualified Algebra.Module   as Module+import qualified Algebra.Additive as Additive++import Foreign.Storable (Storable)++import Control.Monad.Trans.State (runState, runStateT, )++import Data.Function (fix, )+import qualified Data.List.HT as ListHT+import qualified Data.List as List+import Data.Tuple.HT (mapPair, mapFst, )++import Prelude+   (Bool, Int, Maybe(Just), maybe, snd,+    flip, uncurry, (.), ($), id,+    fmap, return, )+++class Cut.Read (sig y) => Read sig y where+   toList :: sig y -> [y]+   toState :: sig y -> SigS.T y+--   toState :: StateT (sig y) Maybe y+   foldL :: (s -> y -> s) -> s -> sig y -> s+-- better move to Transform class?+   viewL :: sig y -> Maybe (y, sig y)+   viewR :: sig y -> Maybe (sig y, y)++class (Read sig y, Cut.Transform (sig y)) => Transform sig y where+   {- |+   This function belongs logically to the Write class,+   but since an empty signal contains no data,+   the maximum package size is irrelevant.+   This makes e.g. the definition of mixMulti more general.+   -}+   cons :: y -> sig y -> sig y+   takeWhile :: (y -> Bool) -> sig y -> sig y+   dropWhile :: (y -> Bool) -> sig y -> sig y+   span :: (y -> Bool) -> sig y -> (sig y, sig y)+   -- functions from Transform2 that are oftenly used with only one type variable+   map :: (y -> y) -> (sig y -> sig y)+   scanL :: (y -> y -> y) -> y -> sig y -> sig y+   crochetL :: (y -> s -> Maybe (y, s)) -> s -> sig y -> sig y+   zipWithAppend :: (y -> y -> y) -> sig y -> sig y -> sig y+++{- |+This type is used for specification of the maximum size of strict packets.+Packets can be smaller, can have different sizes in one signal.+In some kinds of streams, like lists and stateful generators,+the packet size is always 1.+The packet size is not just a burden caused by efficiency,+but we need control over packet size in applications with feedback.+-}+newtype LazySize = LazySize Int++{- |+This can be used for internal signals+that have no observable effect on laziness.+E.g. when you construct a list+by @repeat defaultLazySize zero@+we assume that 'zero' is defined for all Additive types.+-}+defaultLazySize :: LazySize+defaultLazySize =+   let (Vector.ChunkSize size) = Vector.defaultChunkSize+   in  LazySize size++{- |+We could provide the 'LazySize' by a Reader monad,+but we don't do that because we expect that the choice of the lazy size+is more local than say the choice of the sample rate.+E.g. there is no need to have the same laziness coarseness+for multiple signal processors.+-}+class Transform sig y => Write sig y where+   fromList :: LazySize -> [y] -> sig y+--   fromState :: LazySize -> SigS.T y -> sig y+--   fromState :: LazySize -> StateT s Maybe y -> s -> sig y+   repeat :: LazySize -> y -> sig y+   replicate :: LazySize -> Int -> y -> sig y+   iterate :: LazySize -> (y -> y) -> y -> sig y+   iterateAssociative :: LazySize -> (y -> y -> y) -> y -> sig y+   unfoldR :: LazySize -> (s -> Maybe (y,s)) -> s -> sig y+++-- instance Storable y => Read SigSt.T y where+instance Storable y => Read Vector.Vector y where+   {-# INLINE toList #-}+   toList = Vector.unpack+   {-# INLINE toState #-}+   toState = SigS.fromStorableSignal+   {-# INLINE viewL #-}+   viewL = Vector.viewL+   {-# INLINE viewR #-}+   viewR = Vector.viewR+   {-# INLINE foldL #-}+   foldL = Vector.foldl++instance Storable y => Transform Vector.Vector y where+   {-# INLINE cons #-}+   cons = Vector.cons+   {-# INLINE takeWhile #-}+   takeWhile = Vector.takeWhile+   {-# INLINE dropWhile #-}+   dropWhile = Vector.dropWhile+   {-# INLINE span #-}+   span = Vector.span++   {-# INLINE map #-}+   map = Vector.map+   {-# INLINE scanL #-}+   scanL = Vector.scanl+   {-# INLINE crochetL #-}+   crochetL = Vector.crochetL+   {-# INLINE zipWithAppend #-}+   zipWithAppend = SigSt.zipWithAppend++++withStorableContext ::+   (Vector.ChunkSize -> a) -> (LazySize -> a)+withStorableContext f =+   \(LazySize size) -> f (Vector.ChunkSize size)++instance Storable y => Write Vector.Vector y where+   {-# INLINE fromList #-}+   fromList = withStorableContext $ \size -> Vector.pack size+   {-# INLINE repeat #-}+   repeat = withStorableContext $ \size -> Vector.repeat size+   {-# INLINE replicate #-}+   replicate = withStorableContext $ \size -> Vector.replicate size+   {-# INLINE iterate #-}+   iterate = withStorableContext $ \size -> Vector.iterate size+   {-# INLINE unfoldR #-}+   unfoldR = withStorableContext $ \size -> Vector.unfoldr size+   {-# INLINE iterateAssociative #-}+   iterateAssociative = withStorableContext $ \size op x -> Vector.iterate size (op x) x -- should be optimized++++instance Read [] y where+   {-# INLINE toList #-}+   toList = id+   {-# INLINE toState #-}+   toState = SigS.fromList+   {-# INLINE viewL #-}+   viewL = ListHT.viewL+   {-# INLINE viewR #-}+   viewR = ListHT.viewR+   {-# INLINE foldL #-}+   foldL = List.foldl++instance Transform [] y where+   {-# INLINE cons #-}+   cons = (:)+   {-# INLINE takeWhile #-}+   takeWhile = List.takeWhile+   {-# INLINE dropWhile #-}+   dropWhile = List.dropWhile+   {-# INLINE span #-}+   span = List.span++   {-# INLINE map #-}+   map = List.map+   {-# INLINE scanL #-}+   scanL = List.scanl+   {-# INLINE crochetL #-}+   crochetL = Sig.crochetL+   {-# INLINE zipWithAppend #-}+   zipWithAppend = Sig.zipWithAppend+++instance Write [] y where+   {-# INLINE fromList #-}+   fromList _ = id+   {-# INLINE repeat #-}+   repeat _ = List.repeat+   {-# INLINE replicate #-}+   replicate _ = List.replicate+   {-# INLINE iterate #-}+   iterate _ = List.iterate+   {-# INLINE unfoldR #-}+   unfoldR _ = List.unfoldr+   {-# INLINE iterateAssociative #-}+   iterateAssociative _ = ListHT.iterateAssociative++++instance Read SigFL.T y where+   {-# INLINE toList #-}+   toList = SigFL.toList+   {-# INLINE toState #-}+   toState = SigS.fromList . SigFL.toList+   {-# INLINE viewL #-}+   viewL = SigFL.viewL+   {-# INLINE viewR #-}+   viewR = SigFL.viewR+   {-# INLINE foldL #-}+   foldL = SigFL.foldL++instance Transform SigFL.T y where+   {-# INLINE cons #-}+   cons = SigFL.cons+   {-# INLINE takeWhile #-}+   takeWhile = SigFL.takeWhile+   {-# INLINE dropWhile #-}+   dropWhile = SigFL.dropWhile+   {-# INLINE span #-}+   span = SigFL.span++   {-# INLINE map #-}+   map = SigFL.map+   {-# INLINE scanL #-}+   scanL = SigFL.scanL+   {-# INLINE crochetL #-}+   crochetL = SigFL.crochetL+   {-# INLINE zipWithAppend #-}+   zipWithAppend = SigFL.zipWithAppend+++instance Write SigFL.T y where+   {-# INLINE fromList #-}+   fromList _ = SigFL.fromList+   {-# INLINE repeat #-}+   repeat _ = SigFL.repeat+   {-# INLINE replicate #-}+   replicate _ = SigFL.replicate+   {-# INLINE iterate #-}+   iterate _ = SigFL.iterate+   {-# INLINE unfoldR #-}+   unfoldR _ = SigFL.unfoldR+   {-# INLINE iterateAssociative #-}+   iterateAssociative _ = SigFL.iterateAssociative++++instance Read SigS.T y where+   {-# INLINE toList #-}+   toList = SigS.toList+   {-# INLINE toState #-}+   toState = id+   {-# INLINE viewL #-}+   viewL = SigS.viewL+   {-# INLINE viewR #-}+   viewR =+      -- This implementation is slow. Better leave it unimplemented?+      fmap (mapFst SigS.fromList) .+      ListHT.viewR . SigS.toList+   {-# INLINE foldL #-}+   foldL = SigS.foldL++instance Transform SigS.T y where+   {-# INLINE cons #-}+   cons = SigS.cons+   {-# INLINE takeWhile #-}+   takeWhile = SigS.takeWhile+   {-# INLINE dropWhile #-}+   dropWhile = SigS.dropWhile+   {-# INLINE span #-}+   span p =+      -- This implementation is slow. Better leave it unimplemented?+      mapPair (SigS.fromList, SigS.fromList) .+      List.span p . SigS.toList++   {-# INLINE map #-}+   map = SigS.map+   {-# INLINE scanL #-}+   scanL = SigS.scanL+   {-# INLINE crochetL #-}+   crochetL = SigS.crochetL+   {-# INLINE zipWithAppend #-}+   zipWithAppend = SigS.zipWithAppend+++instance Write SigS.T y where+   {-# INLINE fromList #-}+   fromList _ = SigS.fromList+   {-# INLINE repeat #-}+   repeat _ = SigS.repeat+   {-# INLINE replicate #-}+   replicate _ = SigS.replicate+   {-# INLINE iterate #-}+   iterate _ = SigS.iterate+   {-# INLINE unfoldR #-}+   unfoldR _ = SigS.unfoldR+   {-# INLINE iterateAssociative #-}+   iterateAssociative _ = SigS.iterateAssociative++++{-# INLINE switchL #-}+switchL :: (Read sig y) =>+   a -> (y -> sig y -> a) -> sig y -> a+switchL nothing just =+   maybe nothing (uncurry just) . viewL++{-# INLINE mix #-}+mix :: (Additive.C y, Transform sig y) =>+   sig y -> sig y -> sig y+mix = zipWithAppend (Additive.+)++{-# INLINE zipWith #-}+zipWith :: (Read sig a, Transform sig b) =>+   (a -> b -> b) -> (sig a -> sig b -> sig b)+zipWith h a =+   crochetL+      (\x0 a0 ->+          do (y0,a1) <- viewL a0+             Just (h y0 x0, a1))+      a+++{-# INLINE delay #-}+delay :: (Write sig y) =>+   LazySize -> y -> Int -> sig y -> sig y+delay size z n =+   append (replicate size n z)++{-# INLINE delayLoop #-}+delayLoop ::+   (Transform sig y) =>+      (sig y -> sig y)+            -- ^ processor that shall be run in a feedback loop+   -> sig y -- ^ prefix of the output, its length determines the delay+   -> sig y+delayLoop proc prefix =+   fix (append prefix . proc)+++{-# INLINE delayLoopOverlap #-}+delayLoopOverlap ::+   (Additive.C y, Write sig y) =>+      Int+   -> (sig y -> sig y)+            {- ^ Processor that shall be run in a feedback loop.+                 It's absolutely necessary that this function preserves the chunk structure+                 and that it does not look a chunk ahead.+                 That's guaranteed for processes that do not look ahead at all,+                 like 'Vector.map', 'Vector.crochetL' and+                 all of type @Causal.Process@. -}+   -> sig y -- ^ input+   -> sig y -- ^ output has the same length as the input+delayLoopOverlap time proc xs =+   fix (zipWith (Additive.+) xs .+        delay defaultLazySize Additive.zero time . proc)++++{-# INLINE sum #-}+sum :: (Additive.C a, Read sig a) => sig a -> a+sum = foldL (Additive.+) Additive.zero++{-# INLINE tails #-}+tails :: (Transform sig y) => sig y -> SigS.T (sig y)+tails =+   SigS.unfoldR (fmap (\x -> (x, fmap snd (viewL x)))) . Just++{-# INLINE mapAdjacent #-}+mapAdjacent :: (Read sig a, Transform sig a) =>+   (a -> a -> a) -> sig a -> sig a+mapAdjacent f xs0 =+   let xs1 = maybe xs0 snd (viewL xs0)+   in  zipWith f xs0 xs1++{-# INLINE modifyStatic #-}+modifyStatic :: (Transform sig a) =>+   Modifier.Simple s ctrl a a -> ctrl -> sig a -> sig a+modifyStatic (Modifier.Simple state proc) control =+   crochetL (\a acc -> Just (runState (proc control a) acc)) state++{-| Here the control may vary over the time. -}+{-# INLINE modifyModulated #-}+modifyModulated :: (Transform sig a, Read sig ctrl) =>+   Modifier.Simple s ctrl a a -> sig ctrl -> sig a -> sig a+modifyModulated (Modifier.Simple state proc) control =+   crochetL+      (\x (acc0,cs0) ->+         do (c,cs1) <- viewL cs0+            let (y,acc1) = runState (proc c x) acc0+            return (y,(acc1,cs1)))+      (state,control)+{-+modifyModulated (Modifier.Simple state proc) control x =+   crochetL+      (\ca acc -> Just (runState (uncurry proc ca) acc))+      state (zip control x)+-}++-- cf. Module.linearComb+{-# INLINE linearComb #-}+linearComb ::+   (Module.C t y, Read sig t, Read sig y) =>+   sig t -> sig y -> y+linearComb ts ys =+   SigS.sum (SigS.zipWith (Module.*>) (toState ts) (toState ys))+++fromState :: (Write sig y) =>+   LazySize -> SigS.T y -> sig y+fromState size (SigS.Cons f x) =+   unfoldR size (runStateT f) x++{-# INLINE extendConstant #-}+extendConstant :: (Write sig y) =>+   LazySize -> sig y -> sig y+extendConstant size xt =+   maybe+      xt+      (append xt . repeat size . snd)+      (viewR xt)+++-- comonadic 'bind'+-- only non-empty suffixes are processed+{-# INLINE mapTails #-}+mapTails :: (Transform sig a) =>+   (sig a -> a) -> sig a -> sig a+mapTails f x =+   crochetL (\_ xs0 ->+      do (_,xs1) <- viewL xs0+         Just (f xs0, xs1))+      x x+{-+Implementation with unfoldR is more natural,+but it could not preserve the chunk structure of the input signal.+Thus we prefer crochetL, although we do not consume single elements of the input signal.+-}+mapTailsAlt ::+   (Read sig a, Write sig b) =>+   LazySize -> (sig a -> b) -> sig a -> sig b+mapTailsAlt size f =+   unfoldR size (\xs ->+      do (_,ys) <- viewL xs+         Just (f xs, ys))++{- |+Only non-empty suffixes are processed.+More oftenly we might need++> zipWithTails :: (Read sig b, Transform2 sig a) =>+>    (b -> sig a -> a) -> sig b -> sig a -> sig a++this would preserve the chunk structure of @sig a@,+but it is a bit more hassle to implement that.+-}+{-# INLINE zipWithTails #-}+zipWithTails :: (Read sig b, Transform sig a) =>+   (a -> sig b -> a) -> sig a -> sig b -> sig a+zipWithTails f =+   flip (crochetL (\x ys0 ->+      do (_,ys) <- viewL ys0+         Just (f x ys0, ys)))++{-+instance (Additive.C y, Sample.C y, C sig) => Additive.C (sig y) where+   (+) = mix+   negate = map Additive.negate+-}+++{-+This does not work, because we can constrain only the instances of Data+but this is not checked when implementing methods of C.++class Data sig y where++class C sig where+   add :: (Data sig y, Additive.C y) => sig y -> sig y -> sig y+   map :: (Data sig a, Data sig b) => (a -> b) -> (sig a -> sig b)+   zipWith :: (Data sig a, Data sig b, Data sig c) =>+                  (a -> b -> c) -> (sig a -> sig b -> sig c)+-}++{-+This does not work, because we would need type parameters for all occuring element types.++class C sig y where+   add :: (Additive.C y) => sig y -> sig y -> sig y+   map :: C sig a => (a -> y) -> (sig a -> sig y)+   zipWith :: (a -> b -> y) -> (sig a -> sig b -> sig y)+-}
+ src/Synthesizer/Generic/Signal2.hs view
@@ -0,0 +1,167 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{- |+Type class for several signal storage types+that allows alter element types.+There is some overlap between the two @Transform@ classes.+This was done in order to save us+from ubiquitous @Transform sig y y@ constraints.+-}+module Synthesizer.Generic.Signal2 where++import Synthesizer.Generic.Signal (Read, viewL, sum, )+import qualified Synthesizer.Generic.Signal as SigG++import qualified Algebra.Module   as Module+-- import qualified Algebra.Additive as Additive++import qualified Synthesizer.State.Signal as SigS+import qualified Synthesizer.Plain.Signal as Sig+-- import qualified Synthesizer.Storable.Signal as SigSt+import qualified Data.StorableVector.Lazy as Vector++import qualified Synthesizer.Plain.Modifier as Modifier++import Foreign.Storable (Storable)++import Control.Monad.Trans.State (runState, )++import qualified Data.List as List++import Data.Tuple.HT (fst3, snd3, thd3, )+import Prelude+   (Bool, Int, Maybe(Just), maybe, fst, snd,+    flip,+    return, )+++class (SigG.Transform sig y0, SigG.Transform sig y1) =>+          Transform sig y0 y1 where+   map :: (y0 -> y1) -> (sig y0 -> sig y1)+   scanL :: (y1 -> y0 -> y1) -> y1 -> sig y0 -> sig y1+   crochetL :: (y0 -> s -> Maybe (y1, s)) -> s -> sig y0 -> sig y1+++instance (Storable y0, Storable y1) => Transform Vector.Vector y0 y1 where+   {-# INLINE map #-}+   map = Vector.map+   {-# INLINE scanL #-}+   scanL = Vector.scanl+   {-# INLINE crochetL #-}+   crochetL = Vector.crochetL+++instance Transform [] y0 y1 where+   {-# INLINE map #-}+   map = List.map+   {-# INLINE scanL #-}+   scanL = List.scanl+   {-# INLINE crochetL #-}+   crochetL = Sig.crochetL+++instance Transform SigS.T y0 y1 where+   {-# INLINE map #-}+   map = SigS.map+   {-# INLINE scanL #-}+   scanL = SigS.scanL+   {-# INLINE crochetL #-}+   crochetL = SigS.crochetL++++{-# INLINE zipWith #-}+zipWith :: (Read sig a, Transform sig b c) =>+   (a -> b -> c) -> (sig a -> sig b -> sig c)+zipWith h a =+   crochetL+      (\x0 a0 ->+          do (y0,a1) <- viewL a0+             Just (h y0 x0, a1))+      a++{-# INLINE mapAdjacent #-}+mapAdjacent :: (Read sig a, Transform sig a b) =>+   (a -> a -> b) -> sig a -> sig b+mapAdjacent f xs0 =+   let xs1 = maybe xs0 snd (viewL xs0)+   in  zipWith f xs0 xs1+++{-# INLINE zip #-}+zip :: (Read sig a, Transform sig b (a,b)) =>+   sig a -> sig b -> sig (a,b)+zip = zipWith (,)+++{-# INLINE unzip #-}+unzip :: (Transform sig (a,b) a, Transform sig (a,b) b) =>+   sig (a,b) -> (sig a, sig b)+unzip xs =+   (map fst xs, map snd xs)++{-# INLINE unzip3 #-}+unzip3 :: (Transform sig (a,b,c) a, Transform sig (a,b,c) b, Transform sig (a,b,c) c) =>+   sig (a,b,c) -> (sig a, sig b, sig c)+unzip3 xs =+   (map fst3 xs, map snd3 xs, map thd3 xs)++++{-# INLINE modifyStatic #-}+modifyStatic :: (Transform sig a b) =>+   Modifier.Simple s ctrl a b -> ctrl -> sig a -> sig b+modifyStatic (Modifier.Simple state proc) control =+   crochetL (\a acc -> Just (runState (proc control a) acc)) state++{-| Here the control may vary over the time. -}+{-# INLINE modifyModulated #-}+modifyModulated :: (Transform sig a b, Read sig ctrl) =>+   Modifier.Simple s ctrl a b -> sig ctrl -> sig a -> sig b+modifyModulated (Modifier.Simple state proc) control =+   crochetL+      (\x (acc0,cs0) ->+         do (c,cs1) <- viewL cs0+            let (y,acc1) = runState (proc c x) acc0+            return (y,(acc1,cs1)))+      (state,control)++linearComb ::+   (Module.C t y, Read sig t, Transform sig y y) =>+   sig t -> sig y -> y+linearComb ts ys =+   sum (zipWith (Module.*>) ts ys)++mapTails :: (Transform sig a b) =>+   (sig a -> b) -> sig a -> sig b+mapTails f x =+   crochetL (\_ xs0 ->+      do (_,xs1) <- viewL xs0+         Just (f xs0, xs1))+      x x++{-# INLINE zipWithTails #-}+zipWithTails :: (Read sig b, Transform sig a c) =>+   (a -> sig b -> c) -> sig a -> sig b -> sig c+zipWithTails f =+   flip (crochetL (\x ys0 ->+      do (_,ys) <- viewL ys0+         Just (f x ys0, ys)))++{-# INLINE zipWith2Tails #-}+zipWith2Tails :: (Read sig b, Read sig c, Transform sig a d) =>+   (a -> sig b -> sig c -> d) -> sig a -> sig b -> sig c -> sig d+zipWith2Tails f as bs cs =+   crochetL (\x (ys0,zs0) ->+      do (_,ys1) <- viewL ys0+         (_,zs1) <- viewL zs0+         Just (f x ys0 zs0, (ys1,zs1)))+      (bs,cs) as++zipWithState :: (Transform sig b c) =>+   (a -> b -> c) -> SigS.T a -> sig b -> sig c+zipWithState f =+   crochetL (\b as0 ->+      do (a,as1) <- SigS.viewL as0+         Just (f a b, as1))
+ src/Synthesizer/Generic/Tutorial.hs view
@@ -0,0 +1,231 @@+{-# LANGUAGE FlexibleContexts #-}+{- |+In this module we demonstrate techniques for getting sound in real-time.+Getting real-time performance is mostly an issue of the right signal data structure.+However, there is no one-size-fits-all data structure.+For choosing the right one, you need to understand how various data structures work,+what are their strengths and what are their weaknesses.+-}+module Synthesizer.Generic.Tutorial+{-# DEPRECATED "do not import that module, it is only intended for demonstration" #-}+ where++import qualified Synthesizer.Plain.Tutorial as Tutorial -- needed for Haddock++import qualified Sound.Sox.Play as Play+import qualified Sound.Sox.Option.Format as SoxOpt+import qualified Synthesizer.Basic.Binary as BinSmp+import qualified Synthesizer.Storable.Signal as SigSt+import qualified Synthesizer.Generic.Signal as SigG+import qualified Synthesizer.Generic.Signal2 as SigG2+import qualified Synthesizer.State.Signal as Sig+import qualified Synthesizer.Causal.Process as Causal+import Control.Arrow ((&&&), (^<<), (<<^), (<<<), )++import qualified Synthesizer.Generic.Oscillator as Osci+import qualified Synthesizer.Generic.Filter.NonRecursive as Filt+import qualified Synthesizer.Plain.Filter.Recursive as FiltRec+import qualified Synthesizer.Plain.Filter.Recursive.Universal as UniFilter+import qualified Synthesizer.Basic.Wave as Wave++import qualified Synthesizer.State.Control as CtrlS+import qualified Synthesizer.State.Oscillator as OsciS++import System.Exit (ExitCode, )+import NumericPrelude+import PreludeBase+import Prelude ()+++{- |+First, we define a play routine for lazy storable vectors.+Storable lazy vectors are lazy lists of low-level arrays.+They are both efficient in time and memory consumption,+but the blocks disallow feedback by small delays.+Elements of a storable vector must be of type class Storable.+This means that elements must have fixed size+and advanced data types like functions cannot be used.+-}+play :: SigSt.T Double -> IO ExitCode+play =+   Play.simple SigSt.hPut SoxOpt.none 44100 .+   SigSt.map BinSmp.int16FromDouble++{- |+Here is a simple oscillator generated as lazy storable vector.+An oscillator is a signal generator,+that is it produces a signal+without consuming other signals that correspond in time.+Signal generators have the maximal block size as parameter.+This is the lower limit of possible feedback delays.+-}+oscillator :: IO ExitCode+oscillator =+   play (Osci.static SigG.defaultLazySize Wave.sine zero (0.01::Double))++{- |+We rewrite the filter example 'Tutorial.filterSaw'+in terms of type classes for more signal types.+The constraints become quite large+because we must assert, that a particular sample type+can be used in the addressed signal type.+-}+filterSawSig ::+   (SigG.Write sig Double,+    SigG2.Transform sig (UniFilter.Result Double) Double,+    SigG2.Transform sig Double (UniFilter.Result Double),+    SigG2.Transform sig Double (UniFilter.Parameter Double)) =>+   sig Double+filterSawSig =+   SigG2.map UniFilter.lowpass $ SigG2.modifyModulated UniFilter.modifier (SigG2.map (\f -> UniFilter.parameter $ FiltRec.Pole 10 (0.04+0.02*f)) $ Osci.static SigG.defaultLazySize Wave.sine zero (0.00001::Double)) $ Osci.static SigG.defaultLazySize Wave.saw zero (0.002::Double)++{- |+Here we instantiate 'filterSawSig' for storable vectors and play it.+This means that all operations convert a storable vector into another storable vector.+While every single operation probably is as efficient as possible,+the composition of all those processes could be more efficient.+So keep on reading.+-}+filterSaw :: IO ExitCode+filterSaw =+   play filterSawSig+++{- |+The next signal type we want to consider is the stateful signal generator.+It is not a common data structure, where the sample values are materialized.+Instead it is a description of how to generate sample values iteratively.+This is almost identical to the @Data.Stream@ module from the @stream-fusion@ package.+With respect to laziness and restrictions of the sample type (namely none),+this signal representation is equivalent to lists.+You can convert one into the other in a lossless way.+That is, function as sample type is possible.+Combination of such signal generators is easily possible+and does not require temporary storage,+because this signal representation needs no sample value storage at all.+However at the end of such processes, the signal must be materialized.+Here we write the result into a lazy storable vector and play that.+What the compiler actually does is to create a single loop,+that generates the storable vector to be played in one go.+-}+playState :: Sig.T Double -> IO ExitCode+playState =+   Play.simple SigSt.hPut SoxOpt.none 44100 .+   SigG.fromState SigG.defaultLazySize .+   Sig.map BinSmp.int16FromDouble++{- |+We demonstrate the stateful signal generator using the known 'filterSaw' example.+Actually we can reuse the code from above,+because the signal generator is also an instance of the generic signal class.+-}+filterSawState :: IO ExitCode+filterSawState =+   playState filterSawSig+++{- |+Merging subsequent signal processes based on signal generators+into an efficient large signal processor is easy.+Not storing intermediate results is however a problem in another situation:+Sometimes you want to share one signal between several processes.+-}+filterPingStateProc :: Sig.T Double -> Sig.T Double+filterPingStateProc env =+   Filt.envelope env $ Sig.map UniFilter.lowpass $ Sig.modifyModulated UniFilter.modifier (Sig.map (\f -> UniFilter.parameter $ FiltRec.Pole 10 (0.03*f)) $ env) $ OsciS.static Wave.saw zero (0.002::Double)++{- |+In the following example we generate an exponential curve+which shall be used both as envelope+and as resonance frequency control of a resonant lowpass.+Actually, recomputing an exponential curve is not an issue,+since it only needs one multiplication per sample.+But it is simple enough to demonstrate the problem and its solutions.+The expression @let env = exponential2 50000 1@ fools the reader of the program,+since the @env@ that is shared, is only the signal generator,+that is, the description of how to compute the exponential curve successively.+That is wherever a signal process reads @env@, it is computed again.+-}+filterPingState :: IO ExitCode+filterPingState =+   playState $+   filterPingStateProc $+   CtrlS.exponential2 50000 1++{- |+You can achieve sharing by a very simple way.+You can write the result of the signal generator in a list ('Sig.toList')+and use this list as source for a new generator ('Sig.fromList').+'Sig.fromList' provides a signal generator that generates new sample values+by delivering the next sample from the list.++In a real world implementation you would move+the @Sig.fromList . Sig.toList@ to 'filterPingStateProc',+since the caller cannot know, that this function uses the signal twice,+and the implementor of 'filterPingStateProc' cannot know,+how expensive the computation of @env@ is.++You can use any other signal type for sharing, e.g. storable vectors,+but whatever type you choose, you also get its disadvantages.+Namely, storable vectors only work for storable samples+and lists are generally slow,+and they also cannot be optimized away,+since this only works, when no sharing is required.++Whenever a signal is shared as input between several signal processes,+the actual materialized data is that+between the slowest and the fastest reading process.+This is due to lazy evaluation and garbage collection.+If the different readers read with different speed,+then you will certainly need a temporary sample storage.+-}+filterPingShare :: IO ExitCode+filterPingShare =+   playState $+   filterPingStateProc $+   Sig.fromList $ Sig.toList $ CtrlS.exponential2 50000 1++{- |+It is however not uncommon that all readers read with the same speed.+In this case we would in principle only need to share the input signal per sample.+This way we would not need a data structure+for storing a sub-sequence of samples temporarily.+But how to do that practically?++The solution is not to think in terms of signals and signal processors,+e.g. @Sig.T a@ and @Sig.T a -> Sig.T b -> Sig.T c@, respectively,+but in terms of signal processors, that are guaranteed to run in sync.+That is we must assert that signal processors+process the samples in chronological order and emit one sample per input sample.+We call such processes \"causal\" processes.+For example @Causal.T (a,b) c@ represents the function @Sig.T (a,b) -> Sig.T c@+but it also carries the guarantee,+that for each input of type @(a,b)@+one sample of type @c@ is emitted or the output terminates.+Internally it is the Kleisli arrow of the @StateT Maybe@ monad.++Another important application of the Causal arrow is feedback.+Using causal processes guarantees, that a process cannot read ahead,+such that it runs into future data, which does still not exist due to recursion.++Programming with arrows needs a bit experience or Haskell extensions.+Haskell extensions are either an @Arrow@ syntax preprocessor+or the preprocessor that is built into GHC.+However, for computing with physical dimensions+you can no longer use the original @Arrow@ class+and thus you cannot use the arrow syntax.+So here is an example of how to program 'filterPingShare'+using @Arrow@ combinators.+-}+filterPingCausal :: IO ExitCode+filterPingCausal =+   playState $+   let proc =+          uncurry (*) ^<<+          ((UniFilter.lowpass ^<<+            UniFilter.causal <<<+            Causal.feedSnd (OsciS.static Wave.saw zero (0.002::Double)) <<^+            (\f -> UniFilter.parameter $ FiltRec.Pole 10 (0.03*f)))+           &&&+           Causal.id)+   in  Causal.apply proc $ CtrlS.exponential2 50000 1
+ src/Synthesizer/Generic/Wave.hs view
@@ -0,0 +1,48 @@+module Synthesizer.Generic.Wave where++import qualified Synthesizer.State.ToneModulation as ToneMod+import qualified Synthesizer.Basic.Wave as Wave++import qualified Synthesizer.Generic.Signal as SigG++import qualified Synthesizer.Interpolation as Interpolation++import qualified Algebra.RealField             as RealField++-- import Data.Tuple.HT (swap, )++import NumericPrelude+import PreludeBase+import Prelude ()+++sample ::+   (RealField.C a, SigG.Transform sig v) =>+   Interpolation.T a v -> sig v -> Wave.T a v+sample ip wave =+   let len = SigG.length wave+       cycleWave = SigG.cycle wave+   in  Wave.fromFunction $ \ phase ->+           let (n,q) = RealField.splitFraction (phase * fromIntegral len)+           in  Interpolation.func ip q $+               SigG.toState $+               SigG.drop n cycleWave+++{- |+Interpolate first within waves and then across waves,+which is simpler but maybe less efficient for lists.+However for types with fast indexing/drop like StorableVector this is optimal.+-}+sampledTone ::+   (RealField.C a, SigG.Transform sig v) =>+   Interpolation.T a v ->+   Interpolation.T a v ->+   a -> sig v -> a -> Wave.T a v+sampledTone ipLeap ipStep period tone shape = Wave.Cons $ \phase ->+--   uncurry (ToneMod.interpolateCell ipStep ipLeap . swap) $+   uncurry (ToneMod.interpolateCell ipLeap ipStep) $+   ToneMod.sampledToneCell+      (ToneMod.makePrototype (Interpolation.margin ipLeap) (Interpolation.margin ipStep) period tone)+      shape phase+
+ src/Synthesizer/Interpolation.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE NoImplicitPrelude #-}+module Synthesizer.Interpolation where++import qualified Synthesizer.State.Signal  as Sig++import Control.Monad.Trans.State (StateT(StateT), evalStateT, )+import Control.Monad.Trans.Writer (Writer, writer, runWriter, )+import Data.Monoid (Sum(Sum), )+import Control.Applicative (Applicative(pure, (<*>)), (<$>), liftA2, )++import PreludeBase+import NumericPrelude+++++{- | interpolation as needed for resampling -}+data T t y =+  Cons {+    margin :: !Margin,+    func   :: !(t -> Sig.T y -> y)+  }++data Margin =+    Margin {+       marginNumber :: !Int,+          -- ^ interpolation requires a total number of 'number'+       marginOffset :: !Int+          -- ^ interpolation requires 'offset' values before the current+    }+   deriving (Show, Eq)++cons :: Int -> Int -> (t -> Sig.T y -> y) -> T t y+cons num off =+   Cons (Margin num off)++number :: T t y -> Int+number = marginNumber . margin++offset :: T t y -> Int+offset = marginOffset . margin++++{-* Different kinds of interpolation -}++{-** Hard-wired interpolations -}++{-+Applicative composition of two applicative functors,+namely @Writer@ and @StateT Maybe@.+We could also use (.:) from TypeCompose.+-}+newtype PrefixReader y a =+   PrefixReader (Writer (Sum Int) (StateT (Sig.T y) Maybe a))++instance Functor (PrefixReader y) where+   {-# INLINE fmap #-}+   fmap f (PrefixReader m) =+      PrefixReader (fmap (fmap f) m)++instance Applicative (PrefixReader y) where+   {-# INLINE pure #-}+   {-# INLINE (<*>) #-}+   pure = PrefixReader . pure . pure+   (PrefixReader f) <*> (PrefixReader x) =+       PrefixReader (liftA2 (<*>) f x)+++{-# INLINE getNode #-}+getNode :: PrefixReader y y+getNode =+   PrefixReader $ writer (StateT Sig.viewL, Sum 1)++{-# INLINE fromPrefixReader #-}+fromPrefixReader :: String -> Int -> PrefixReader y (t -> y) -> T t y+fromPrefixReader name off (PrefixReader pr) =+   let (parser, Sum count) = runWriter pr+   in  cons count off+          (\t xs ->+              maybe+                 (error (name ++ " interpolation: not enough nodes"))+                 ($t)+                 (evalStateT parser xs))++{-| Consider the signal to be piecewise constant. -}+{-# INLINE constant #-}+constant :: T t y+constant =+   fromPrefixReader "constant" 0 (const <$> getNode)
+ src/Synthesizer/Interpolation/Class.hs view
@@ -0,0 +1,202 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{- |+See NumericPrelude.AffineSpace for design discussion.+-}+module Synthesizer.Interpolation.Class where++import qualified Synthesizer.State.Signal as Sig++import qualified Algebra.Module as Module+import qualified Algebra.PrincipalIdealDomain as PID+import qualified Algebra.Ring as Ring+import qualified Algebra.Additive as Additive++import qualified Number.Ratio as Ratio+import qualified Number.Complex as Complex++import Control.Applicative (Applicative(pure, (<*>)), )+import Data.Tuple.HT (mapPair, mapSnd, fst3, snd3, thd3, )++import NumericPrelude hiding (zero, )+import PreludeBase+import Prelude ()++{- |+Given that @scale zero v == Additive.zero@+this type class is equivalent to Module in the following way:++> scaleAndAccumulate (a,x) =+>    let ax = a *> x+>    in  (ax, (ax+))++(see implementation of 'scaleAndAccumulateModule')+and++> x+y = scaleAccumulate one y $ scale one x+> zero = scale zero x+> s*>x = scale s x++But this redundancy is only because of a lack of the type system+or lack of my imagination how to solve it better.+Use this type class for all kinds of interpolation,+that is where addition and scaling alone make no sense.++I intended to name this class AffineSpace,+because all interpolations should be affine combinations.+This property is equivalent to interpolations that preserve constant functions.+However, I cannot easily assert this property+and I'm not entirely sure+that all reasonable interpolations are actually affine.++Early versions had a @zero@ method,+but this is against the idea of interpolation.+For implementing @zero@ we needed a @Maybe@ wrapper+for interpolation of @StorableVector@s.+Btw. having @zero@ instead of @scale@ is also inefficient,+since every sum must include a zero summand,+which works well only when the optimizer+simplifies addition with a constant.++We use only one class method+that contains actually two methods:+@scale@ and @scaleAccumulate@.+We expect that instances are always defined on record types+lifting interpolations from scalars to records.+This should be done using 'makeMac' and friends+or the 'MAC' type and the 'Applicative' interface+for records with many elements.+-}+class Ring.C a => C a v where+   scaleAndAccumulate :: (a,v) -> (v, v -> v)+++instance C Float Float where+   {-# INLINE scaleAndAccumulate #-}+   scaleAndAccumulate = scaleAndAccumulateRing++instance C Double Double where+   {-# INLINE scaleAndAccumulate #-}+   scaleAndAccumulate = scaleAndAccumulateRing++instance (C a v) => C a (Complex.T v) where+   {-# INLINE scaleAndAccumulate #-}+   scaleAndAccumulate =+      makeMac2 (Complex.+:) Complex.real Complex.imag++instance (PID.C a) => C (Ratio.T a) (Ratio.T a) where+   {-# INLINE scaleAndAccumulate #-}+   scaleAndAccumulate = scaleAndAccumulateRing++instance (C a v, C a w) => C a (v, w) where+   {-# INLINE scaleAndAccumulate #-}+   scaleAndAccumulate = makeMac2 (,) fst snd++instance (C a v, C a w, C a u) => C a (v, w, u) where+   {-# INLINE scaleAndAccumulate #-}+   scaleAndAccumulate = makeMac3 (,,) fst3 snd3 thd3++++infixl 6 +.*++{-# INLINE scale #-}+scale :: C a v => (a,v) -> v+scale = fst . scaleAndAccumulate++{-# INLINE scaleAccumulate #-}+scaleAccumulate :: C a v => (a,v) -> v -> v+scaleAccumulate = snd . scaleAndAccumulate++{- |+Infix variant of 'scaleAccumulate'.+-}+{-# INLINE (+.*) #-}+(+.*) :: C a v => v -> (a,v) -> v+(+.*) = flip scaleAccumulate+++combine2 :: C a v => a -> (v, v) -> v+combine2 a (x,y) =+   scaleAccumulate (one-a, x) $+   scale (a, y)++combineMany :: C a v => (a, Sig.T a) -> (v, Sig.T v) -> v+combineMany (a,as) (v,vs) =+   Sig.foldL (flip scaleAccumulate) (scale (a,v)) $+   Sig.zip as vs+++-- * convenience functions for defining scaleAndAccumulate++{-# INLINE scaleAndAccumulateRing #-}+scaleAndAccumulateRing ::+   Ring.C a =>+   (a,a) -> (a, a -> a)+scaleAndAccumulateRing (a,x) =+   let ax = a * x+   in  (ax, (ax+))++{-# INLINE scaleAndAccumulateModule #-}+scaleAndAccumulateModule ::+   Module.C a v =>+   (a,v) -> (v, v -> v)+scaleAndAccumulateModule (a,x) =+   let ax = a *> x+   in  (ax, (ax+))+++{- |+A special reader monad.+-}+newtype MAC a v x = MAC {runMac :: (a,v) -> (x, v -> x)}++{-# INLINE element #-}+element ::+   (C a x) =>+   (v -> x) -> MAC a v x+element f =+   MAC $ \(a,x) ->+      mapSnd (.f) $ scaleAndAccumulate (a, f x)++instance Functor (MAC a v) where+   {-# INLINE fmap #-}+   fmap f (MAC x) =+      MAC $ mapPair (f, (f .)) . x++instance Applicative (MAC a v) where+   {-# INLINE pure #-}+   {-# INLINE (<*>) #-}+   pure x = MAC $ const (x, const x)+   MAC f <*> MAC x =+      MAC $ \av ->+         let (xav,add) = x av+             (g,fadd)  = f av+         in  (g xav, \y -> fadd y (add y))++{-# INLINE makeMac #-}+makeMac ::+   (C a x) =>+   (x -> v) ->+   (v -> x) ->+   (a,v) -> (v, v -> v)+makeMac cons x =+   runMac $ pure cons <*> element x++{-# INLINE makeMac2 #-}+makeMac2 ::+   (C a x, C a y) =>+   (x -> y -> v) ->+   (v -> x) -> (v -> y) ->+   (a,v) -> (v, v -> v)+makeMac2 cons x y =+   runMac $ pure cons <*> element x <*> element y++{-# INLINE makeMac3 #-}+makeMac3 ::+   (C a x, C a y, C a z) =>+   (x -> y -> z -> v) ->+   (v -> x) -> (v -> y) -> (v -> z) ->+   (a,v) -> (v, v -> v)+makeMac3 cons x y z =+   runMac $ pure cons <*> element x <*> element y <*> element z
+ src/Synthesizer/Interpolation/Custom.hs view
@@ -0,0 +1,156 @@+{-# LANGUAGE NoImplicitPrelude #-}+{- |+Special interpolations defined in terms of our custom Interpolation class.+-}+module Synthesizer.Interpolation.Custom (+   T,+   constant,+   linear,+   cubic,+   piecewise,+   piecewiseConstant,+   piecewiseLinear,+   piecewiseCubic,+   function,+   ) where++import qualified Synthesizer.State.Signal  as Sig+import qualified Synthesizer.Plain.Control as Ctrl+import qualified Synthesizer.Interpolation.Class as Interpol++import Synthesizer.Interpolation (+   T, cons, getNode, fromPrefixReader,+   constant,+   )++import qualified Algebra.Field     as Field+import qualified Algebra.Ring      as Ring+import qualified Algebra.Additive  as Additive++import Synthesizer.Interpolation.Class ((+.*), )++import Control.Applicative (liftA2, )+import Synthesizer.ApplicativeUtility (liftA4, )++import PreludeBase+import NumericPrelude++++{-| Consider the signal to be piecewise linear. -}+{-# INLINE linear #-}+linear :: (Interpol.C t y) => T t y+linear =+   fromPrefixReader "linear" 0+      (liftA2+          (\x0 x1 phase -> Interpol.combine2 phase (x0,x1))+          getNode getNode)++{-|+Consider the signal to be piecewise cubic,+with smooth connections at the nodes.+It uses a cubic curve which has node values+x0 at 0 and x1 at 1 and derivatives+(x1-xm1)/2 and (x2-x0)/2, respectively.+You can see how it works+if you evaluate the expression for t=0 and t=1+as well as the derivative at these points.+-}+{-# INLINE cubic #-}+cubic :: (Field.C t, Interpol.C t y) => T t y+cubic =+   fromPrefixReader "cubicAlt" 1 $ liftA4+      (\xm1 x0 x1 x2 t ->+       let (am1, a0, a1) = cubicHalf    t+           ( b2, b1, b0) = cubicHalf (1-t)+       in  Interpol.scale (am1,xm1)+             +.* (a0+b0,x0)+             +.* (a1+b1,x1)+             +.* (b2,x2))+      getNode getNode getNode getNode++{- |+See 'cubicHalfModule'.+-}+{-# INLINE cubicHalf #-}+cubicHalf :: (Field.C t) => t -> (t,t,t)+cubicHalf t =+   let c = (t-1)^2+       ct2 = c*t/2+   in  (-ct2, c*(1+2*t), ct2)+++{-** Interpolation based on piecewise defined functions -}++{- |+List of functions must be non-empty.+-}+{-# INLINE piecewise #-}+piecewise :: (Interpol.C t y) =>+   Int -> [t -> t] -> T t y+piecewise center ps =+   cons (length ps) (center-1) $+   \t ->+      combineMany+         "Interpolation.element: list of functions empty"+         "Interpolation.element: list of samples empty" $+            Sig.map ($t) $ Sig.fromList $ reverse ps++{-# INLINE piecewiseConstant #-}+piecewiseConstant :: (Interpol.C t y) => T t y+piecewiseConstant =+   piecewise 1 [const 1]++{-# INLINE piecewiseLinear #-}+piecewiseLinear :: (Interpol.C t y) => T t y+piecewiseLinear =+   piecewise 1 [id, (1-)]++{-# INLINE piecewiseCubic #-}+piecewiseCubic :: (Field.C t, Interpol.C t y) => T t y+piecewiseCubic =+   piecewise 2 $+      Ctrl.cubicFunc (0,(0,0))    (1,(0,1/2)) :+      Ctrl.cubicFunc (0,(0,1/2))  (1,(1,0)) :+      Ctrl.cubicFunc (0,(1,0))    (1,(0,-1/2)) :+      Ctrl.cubicFunc (0,(0,-1/2)) (1,(0,0)) :+      []++{-+GNUPlot.plotList [] $ take 100 $ interpolate (Zero 0) piecewiseCubic (-2.3 :: Double) (repeat 0.1) [2,1,2::Double]+-}+++{-** Interpolation based on arbitrary functions -}++{- | with this wrapper you can use the collection of interpolating functions from Donadio's DSP library -}+{-# INLINE function #-}+function :: (Interpol.C t y) =>+      (Int,Int)   {- ^ @(left extent, right extent)@, e.g. @(1,1)@ for linear hat -}+   -> (t -> t)+   -> T t y+function (left,right) f =+   let len = left+right+       ps  = Sig.take len $ Sig.iterate pred (pred right)+       -- ps = Sig.reverse $ Sig.take len $ Sig.iterate succ (-left)+   in  cons len left $+       \t ->+          combineMany+             "Interpolation.function: empty function domain"+             "Interpolation.function: list of samples empty" $+             Sig.map (\x -> f (t + fromIntegral x)) ps+{-+GNUPlot.plotList [] $ take 300 $ interpolate (Zero 0) (function (1,1) (\x -> exp (-6*x*x))) (-2.3 :: Double) (repeat 0.03) [2,1,2::Double]+-}++combineMany ::+   (Interpol.C a v) =>+   String -> String ->+   Sig.T a -> Sig.T v -> v+combineMany msgCoefficients msgSamples ct xt =+   Sig.switchL (error msgCoefficients)+      (\c cs ->+         Sig.switchL (error msgSamples)+            (curry (Interpol.combineMany (c,cs)))+            xt)+      ct
+ src/Synthesizer/Interpolation/Module.hs view
@@ -0,0 +1,156 @@+{-# LANGUAGE NoImplicitPrelude #-}+{- |+Special interpolations defined in terms of Module operations.+-}+module Synthesizer.Interpolation.Module (+   T,+   constant,+   linear,+   cubic,+   cubicAlt,+   piecewise,+   piecewiseConstant,+   piecewiseLinear,+   piecewiseCubic,+   function,+   ) where++import qualified Synthesizer.State.Signal  as Sig+import qualified Synthesizer.Plain.Control as Ctrl++import Synthesizer.Interpolation (+   T, cons, getNode, fromPrefixReader,+   constant,+   )++import qualified Algebra.Module    as Module+-- import qualified Algebra.RealField as RealField+import qualified Algebra.Field     as Field+import qualified Algebra.Ring      as Ring+import qualified Algebra.Additive  as Additive++import Algebra.Module((*>))++import Control.Applicative (liftA2, )+import Synthesizer.ApplicativeUtility (liftA4, )+import Synthesizer.Utility (affineComb, )++import PreludeBase+import NumericPrelude+++{-| Consider the signal to be piecewise linear. -}+{-# INLINE linear #-}+linear :: (Module.C t y) => T t y+linear =+   fromPrefixReader "linear" 0+      (liftA2+          (\x0 x1 phase -> affineComb phase (x0,x1))+          getNode getNode)++{- |+Consider the signal to be piecewise cubic,+with smooth connections at the nodes.+It uses a cubic curve which has node values+x0 at 0 and x1 at 1 and derivatives+(x1-xm1)/2 and (x2-x0)/2, respectively.+You can see how it works+if you evaluate the expression for t=0 and t=1+as well as the derivative at these points.+-}+{-# INLINE cubic #-}+cubic :: (Field.C t, Module.C t y) => T t y+cubic =+   fromPrefixReader "cubic" 1+      (liftA4+         (\xm1 x0 x1 x2 t ->+            let lipm12 = affineComb t (xm1,x2)+                lip01  = affineComb t (x0, x1)+                three  = 3 `asTypeOf` t+            in  lip01 + (t*(t-1)/2) *>+                           (lipm12 + (x0+x1) - three *> lip01))+         getNode getNode getNode getNode)++{- |+The interpolators for module operations+do not simply compute a straight linear combination of some vectors.+Instead they add then scale, then add again, and so on.+This is efficient whenever scaling and addition is cheap.+In this case they might save multiplications.+I can't say much about numeric cancellations, however.+-}+{-# INLINE cubicAlt #-}+cubicAlt :: (Field.C t, Module.C t y) => T t y+cubicAlt =+   fromPrefixReader "cubicAlt" 1+      (liftA4+         (\xm1 x0 x1 x2 t ->+          let half = 1/2 `asTypeOf` t+          in  cubicHalf    t  x0 (half *> (x1-xm1)) ++              cubicHalf (1-t) x1 (half *> (x0-x2)))+         getNode getNode getNode getNode)+++{- |+@\t -> cubicHalf t x x'@ has a double zero at 1 and+at 0 it has value x and slope x'.+-}+{-# INLINE cubicHalf #-}+cubicHalf :: (Module.C t y) => t -> y -> y -> y+cubicHalf t x x' =+   (t-1)^2 *> ((1+2*t)*>x + t*>x')++++{-** Interpolation based on piecewise defined functions -}++{-# INLINE piecewise #-}+piecewise :: (Module.C t y) =>+   Int -> [t -> t] -> T t y+piecewise center ps =+   cons (length ps) (center-1)+      (\t -> Sig.linearComb (Sig.fromList (map ($t) (reverse ps))))++{-# INLINE piecewiseConstant #-}+piecewiseConstant :: (Module.C t y) => T t y+piecewiseConstant =+   piecewise 1 [const 1]++{-# INLINE piecewiseLinear #-}+piecewiseLinear :: (Module.C t y) => T t y+piecewiseLinear =+   piecewise 1 [id, (1-)]++{-# INLINE piecewiseCubic #-}+piecewiseCubic :: (Field.C t, Module.C t y) => T t y+piecewiseCubic =+   piecewise 2 $+      Ctrl.cubicFunc (0,(0,0))    (1,(0,1/2)) :+      Ctrl.cubicFunc (0,(0,1/2))  (1,(1,0)) :+      Ctrl.cubicFunc (0,(1,0))    (1,(0,-1/2)) :+      Ctrl.cubicFunc (0,(0,-1/2)) (1,(0,0)) :+      []++{-+GNUPlot.plotList [] $ take 100 $ interpolate (Zero 0) piecewiseCubic (-2.3 :: Double) (repeat 0.1) [2,1,2::Double]+-}+++{-** Interpolation based on arbitrary functions -}++{- | with this wrapper you can use the collection of interpolating functions from Donadio's DSP library -}+{-# INLINE function #-}+function :: (Module.C t y) =>+      (Int,Int)   {- ^ @(left extent, right extent)@, e.g. @(1,1)@ for linear hat -}+   -> (t -> t)+   -> T t y+function (left,right) f =+   let len = left+right+       ps  = Sig.take len $ Sig.iterate pred (pred right)+       -- ps = Sig.reverse $ Sig.take len $ Sig.iterate succ (-left)+   in  cons len left+          (\t -> Sig.linearComb $+                   Sig.map (\x -> f (t + fromIntegral x)) ps)+{-+GNUPlot.plotList [] $ take 300 $ interpolate (Zero 0) (function (1,1) (\x -> exp (-6*x*x))) (-2.3 :: Double) (repeat 0.03) [2,1,2::Double]+-}
+ src/Synthesizer/Piecewise.hs view
@@ -0,0 +1,87 @@+{- |+Construction of a data type that describes piecewise defined curves.+-}+module Synthesizer.Piecewise where+++type T t y sig = [PieceData t y sig]++{- |+The curve type of a piece of a piecewise defined control curve.+-}+newtype Piece t y sig =+   Piece {computePiece :: y  {- y0 -}+                       -> y  {- y1 -}+                       -> t  {- duration -}+                       -> sig}++pieceFromFunction ::+   (y -> y -> t -> sig) -> Piece t y sig+pieceFromFunction = Piece+++{- |+The full description of a control curve piece.+-}+data PieceData t y sig =+     PieceData {pieceType :: Piece t y sig,+                pieceY0 :: y,+                pieceY1 :: y,+                pieceDur :: t}+--   deriving (Eq, Show)+++newtype PieceRightSingle y = PRS y+newtype PieceRightDouble y = PRD y++data PieceDist t y sig = PD t (Piece t y sig) y+++-- precedence and associativity like (:)+infixr 5 -|#, #|-, =|#, #|=, |#, #|++{- |+The 6 operators simplify constructing a list of @PieceData a@.+The description consists of nodes (namely the curve values at nodes)+and the connecting curve types.+The naming scheme is as follows:+In the middle there is a bar @|@.+With respect to the bar,+the pad symbol @\#@ is at the side of the curve type,+at the other side there is nothing, a minus sign @-@, or an equality sign @=@.++ (1) Nothing means that here is the start or the end node of a curve.++ (2) Minus means that here is a node where left and right curve meet at the same value.+     The node description is thus one value.++ (3) Equality sign means that here is a split node,+     where left and right curve might have different ending and beginning values, respectively.+     The node description consists of a pair of values.+-}++-- the leading space is necessary for the Haddock parser++( #|-) :: (t, Piece t y sig) -> (PieceRightSingle y, T t y sig) ->+   (PieceDist t y sig, T t y sig)+(d,c) #|- (PRS y1, xs)  =  (PD d c y1, xs)++(-|#) :: y -> (PieceDist t y sig, T t y sig) ->+   (PieceRightSingle y, T t y sig)+y0 -|# (PD d c y1, xs)  =  (PRS y0, PieceData c y0 y1 d : xs)++( #|=) :: (t, Piece t y sig) -> (PieceRightDouble y, T t y sig) ->+   (PieceDist t y sig, T t y sig)+(d,c) #|= (PRD y1, xs)  =  (PD d c y1, xs)++(=|#) :: (y,y) -> (PieceDist t y sig, T t y sig) ->+   (PieceRightDouble y, T t y sig)+(y01,y10) =|# (PD d c y11, xs)  =  (PRD y01, PieceData c y10 y11 d : xs)++( #|) :: (t, Piece t y sig) -> y ->+   (PieceDist t y sig, T t y sig)+(d,c) #| y1  =  (PD d c y1, [])++(|#) :: y -> (PieceDist t y sig, T t y sig) ->+   T t y sig+y0 |# (PD d c y1, xs)  =  PieceData c y0 y1 d : xs
+ src/Synthesizer/Plain/Analysis.hs view
@@ -0,0 +1,342 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+module Synthesizer.Plain.Analysis where++import qualified Synthesizer.Plain.Signal as Sig+import qualified Synthesizer.Plain.Control as Ctrl+import qualified Synthesizer.Plain.Filter.Recursive.Integration as Integration++-- import qualified Algebra.Module                as Module+-- import qualified Algebra.Transcendental        as Trans+import qualified Algebra.Algebraic             as Algebraic+import qualified Algebra.RealField             as RealField+import qualified Algebra.Field                 as Field+import qualified Algebra.Real                  as Real+import qualified Algebra.Ring                  as Ring+import qualified Algebra.Additive              as Additive++import qualified Algebra.NormedSpace.Maximum   as NormedMax+import qualified Algebra.NormedSpace.Euclidean as NormedEuc+import qualified Algebra.NormedSpace.Sum       as NormedSum++import qualified Data.Array as Array++import qualified Data.IntMap as IntMap++-- import Algebra.Module((*>))++import Data.Array (accumArray)+import Data.List (foldl', )++import qualified Prelude as P+import PreludeBase+import NumericPrelude+++{- * Notions of volume -}++{- |+Volume based on Manhattan norm.+-}+volumeMaximum :: (Real.C y) => Sig.T y -> y+volumeMaximum =+   foldl max zero . rectify+--   maximum . rectify++{- |+Volume based on Energy norm.+-}+volumeEuclidean :: (Algebraic.C y) => Sig.T y -> y+volumeEuclidean =+   Algebraic.sqrt . volumeEuclideanSqr++volumeEuclideanSqr :: (Field.C y) => Sig.T y -> y+volumeEuclideanSqr =+   average . map sqr++{- |+Volume based on Sum norm.+-}+volumeSum :: (Field.C y, Real.C y) => Sig.T y -> y+volumeSum = average . rectify++++{- |+Volume based on Manhattan norm.+-}+volumeVectorMaximum :: (NormedMax.C y yv, Ord y) => Sig.T yv -> y+volumeVectorMaximum =+   NormedMax.norm+--   maximum . map NormedMax.norm++{- |+Volume based on Energy norm.+-}+volumeVectorEuclidean :: (Algebraic.C y, NormedEuc.C y yv) => Sig.T yv -> y+volumeVectorEuclidean =+   Algebraic.sqrt . volumeVectorEuclideanSqr++volumeVectorEuclideanSqr :: (Field.C y, NormedEuc.Sqr y yv) => Sig.T yv -> y+volumeVectorEuclideanSqr =+   average . map NormedEuc.normSqr++{- |+Volume based on Sum norm.+-}+volumeVectorSum :: (NormedSum.C y yv, Field.C y) => Sig.T yv -> y+volumeVectorSum =+   average . map NormedSum.norm+++++{- |+Compute minimum and maximum value of the stream the efficient way.+Input list must be non-empty and finite.+-}+bounds :: Ord y => Sig.T y -> (y,y)+bounds [] = error "Analysis.bounds: List must contain at least one element."+bounds (x:xs) =+   foldl' (\(minX,maxX) y -> (min y minX, max y maxX)) (x,x) xs+++++{- * Miscellaneous -}++{-+histogram:+    length x = sum (histogramDiscrete x)++    units:+    1) histogram (amplify k x) = timestretch k (amplify (1/k) (histogram x))+    2) histogram (timestretch k x) = amplify k (histogram x)+    timestretch: k -> (s -> V) -> (k*s -> V)+    amplify:     k -> (s -> V) -> (s -> k*V)+    histogram:   (a -> b) -> (a^ia*b^ib -> a^ja*b^jb)+    x:           (s -> V)+    1) => (s^ia*(k*V)^ib -> s^ja*(k*V)^jb)+              = (s^ia*V^ib*k -> s^ja*V^jb/k)+       => ib=1, jb=-1+    2) => ((k*s)^ia*V^ib -> (k*s)^ja*V^jb)+              = (s^ia*V^ib -> s^ja*V^jb*k)+       => ia=0, ja=1+    histogram:   (s -> V) -> (V -> s/V)+histogram':+    integral (histogram' x) = integral x+    histogram' (amplify k x) = timestretch k (histogram' x)+    histogram' (timestretch k x) = amplify k (histogram' x)+     -> this does only apply if we slice the area horizontally+        and sum the slice up at each level,+        we must also restrict to the positive values,+        this is not quite the usual histogram+-}++{- |+Input list must be finite.+List is scanned twice, but counting may be faster.+-}+histogramDiscreteArray :: Sig.T Int -> (Int, Sig.T Int)+histogramDiscreteArray [] =+   (error "histogramDiscreteArray: no bounds found", [])+histogramDiscreteArray x =+   let hist =+          accumArray (+) zero+             (bounds x) (attachOne x)+   in  (fst (Array.bounds hist), Array.elems hist)+++{- |+Input list must be finite.+If the input signal is empty, the offset is @undefined@.+List is scanned twice, but counting may be faster.+The sum of all histogram values is one less than the length of the signal.+-}+histogramLinearArray :: RealField.C y => Sig.T y -> (Int, Sig.T y)+histogramLinearArray [] =+   (error "histogramLinearArray: no bounds found", [])+histogramLinearArray [x] = (floor x, [])+histogramLinearArray x =+   let (xMin,xMax) = bounds x+       hist =+          accumArray (+) zero+             (floor xMin, floor xMax)+             (meanValues x)+   in  (fst (Array.bounds hist), Array.elems hist)+++{- |+Input list must be finite.+If the input signal is empty, the offset is @undefined@.+List is scanned once, counting may be slower.+-}+histogramDiscreteIntMap :: Sig.T Int -> (Int, Sig.T Int)+histogramDiscreteIntMap [] =+   (error "histogramDiscreteIntMap: no bounds found", [])+histogramDiscreteIntMap x =+   let hist = IntMap.fromListWith (+) (attachOne x)+   in  case IntMap.toAscList hist of+          [] -> error "histogramDiscreteIntMap: the list was non-empty before processing ..."+          fAll@((fIndex,fHead):fs) -> (fIndex, fHead :+              concat (zipWith+                 (\(i0,_) (i1,f1) -> replicate (i1-i0-1) zero ++ [f1])+                 fAll fs))++histogramLinearIntMap :: RealField.C y => Sig.T y -> (Int, Sig.T y)+histogramLinearIntMap [] =+   (error "histogramLinearIntMap: no bounds found", [])+histogramLinearIntMap [x] = (floor x, [])+histogramLinearIntMap x =+   let hist = IntMap.fromListWith (+) (meanValues x)+   -- we can rely on the fact that the keys are contiguous+       (startKey:_, elems) = unzip (IntMap.toAscList hist)+   in  (startKey, elems)+   -- This doesn't work, due to a bug in IntMap of GHC-6.4.1+   -- in  (head (IntMap.keys hist), IntMap.elems hist)++{-+The bug in IntMap GHC-6.4.1 is:++*Synthesizer.Plain.Analysis> IntMap.keys $ IntMap.fromList $ [(0,0),(-1,-1::Int)]+[0,-1]+*Synthesizer.Plain.Analysis> IntMap.elems $ IntMap.fromList $ [(0,0),(-1,-1::Int)]+[0,-1]+*Synthesizer.Plain.Analysis> IntMap.assocs $ IntMap.fromList $ [(0,0),(-1,-1::Int)]+[(0,0),(-1,-1)]++The bug has gone in IntMap as shipped with GHC-6.6.+-}++histogramIntMap :: (RealField.C y) => y -> Sig.T y -> (Int, Sig.T Int)+histogramIntMap binsPerUnit =+   histogramDiscreteIntMap . quantize binsPerUnit++quantize :: (RealField.C y) => y -> Sig.T y -> Sig.T Int+quantize binsPerUnit = map (floor . (binsPerUnit*))++attachOne :: Sig.T i -> Sig.T (i,Int)+attachOne = map (\i -> (i,one))++meanValues :: RealField.C y => Sig.T y -> [(Int,y)]+meanValues x = concatMap spread (zip x (tail x))++spread :: RealField.C y => (y,y) -> [(Int,y)]+spread (l0,r0) =+   let (l,r) = if l0<=r0 then (l0,r0) else (r0,l0)+       (li,lf) = splitFraction l+       (ri,rf) = splitFraction r+       k = recip (r-l)+       nodes =+          (li,k*(1-lf)) :+          zip [li+1 ..] (replicate (ri-li-1) k) +++          (ri, k*rf) :+          []+   in  if li==ri+         then [(li,one)]+         else nodes++{- |+Requires finite length.+This is identical to the arithmetic mean.+-}+directCurrentOffset :: Field.C y => Sig.T y -> y+directCurrentOffset = average+++scalarProduct :: Ring.C y => Sig.T y -> Sig.T y -> y+scalarProduct xs ys =+   sum (zipWith (*) xs ys)++{- |+'directCurrentOffset' must be non-zero.+-}+centroid :: Field.C y => Sig.T y -> y+centroid xs =+   firstMoment xs / sum xs++centroidAlt :: Field.C y => Sig.T y -> y+centroidAlt xs =+   sum (scanr (+) zero (tail xs)) / sum xs++firstMoment :: Ring.C y => Sig.T y -> y+firstMoment =+   scalarProduct (iterate (one+) zero)+++average :: Field.C y => Sig.T y -> y+average x =+   sum x / fromIntegral (length x)++rectify :: Real.C y => Sig.T y -> Sig.T y+rectify = map abs++{- |+Detects zeros (sign changes) in a signal.+This can be used as a simple measure of the portion+of high frequencies or noise in the signal.+It ca be used as voiced\/unvoiced detector in a vocoder.++@zeros x !! n@ is @True@ if and only if+@(x !! n >= 0) \/= (x !! (n+1) >= 0)@.+The result will be one value shorter than the input.+-}+zeros :: (Ord y, Ring.C y) => Sig.T y -> Sig.T Bool+zeros xs =+   let signs = map (>=zero) xs+   in  zipWith (/=) signs (tail signs)++++data BinaryLevel = Low | High+   deriving (Eq, Show, Enum)++binaryLevelFromBool :: Bool -> BinaryLevel+binaryLevelFromBool False = Low+binaryLevelFromBool True  = High++binaryLevelToNumber :: Ring.C a => BinaryLevel -> a+binaryLevelToNumber Low  = negate one+binaryLevelToNumber High =        one+++{- |+Detect thresholds with a hysteresis.+-}+flipFlopHysteresis :: (Ord y) =>+   (y,y) -> BinaryLevel -> Sig.T y -> Sig.T BinaryLevel+flipFlopHysteresis (lower,upper) =+   scanl+      (\state x -> binaryLevelFromBool $+          case state of+            High -> not(x<lower)+            Low  -> x>upper)++{- |+Almost naive implementation of the chirp transform,+a generalization of the Fourier transform.++More sophisticated algorithms like Rader, Cooley-Tukey, Winograd, Prime-Factor may follow.+-}+chirpTransform :: Ring.C y =>+   y -> Sig.T y -> Sig.T y+chirpTransform z xs =+   let powers = Ctrl.curveMultiscaleNeutral (*) z one+       powerPowers =+          map (\zn -> Ctrl.curveMultiscaleNeutral (*) zn one) powers+   in  map (scalarProduct xs) powerPowers+++binarySign :: Real.C y => Sig.T y -> Sig.T BinaryLevel+binarySign =+   map (binaryLevelFromBool . (zero <=))++{- |+The output type could be different from the input type+but then we would need a conversion from output to input for feedback.+-}+deltaSigmaModulation :: Real.C y => Sig.T y -> Sig.T BinaryLevel+deltaSigmaModulation x =+   let y = binarySign (Integration.runInit zero (x - map binaryLevelToNumber y))+   in  y
+ src/Synthesizer/Plain/Builder.hs view
@@ -0,0 +1,57 @@+module Synthesizer.Plain.Builder (+   T, Put, put, run,+   signalToBinary, signalToBinaryMono, signalToBinaryStereo,+   ) where++import qualified Synthesizer.Basic.Binary as BinSmp++import Data.Monoid (Monoid, mempty, mappend, mconcat, Endo(Endo), appEndo, )++import qualified Algebra.ToInteger as ToInteger+import qualified Algebra.RealField as RealField++import qualified Prelude as P98++import PreludeBase+import NumericPrelude++++newtype T a = Cons {decons :: Endo [a]}++type Put a = a -> T a+++instance Monoid (T a) where+   mempty = Cons mempty+   mappend x y = Cons $ decons x `mappend` decons y++put :: Put a+put = Cons . Endo . (:)++run :: T a -> [a]+run = flip appEndo [] . decons+++{-# INLINE signalToBinary #-}+signalToBinary ::+   (BinSmp.C v, ToInteger.C int, Bounded int) =>+   [v] -> [int]+signalToBinary =+   run . mconcat . map (BinSmp.outputFromCanonical put)++{-# INLINE signalToBinaryMono #-}+signalToBinaryMono ::+   (RealField.C a, ToInteger.C int, Bounded int) =>+   [a] -> [int]+signalToBinaryMono =+   map (BinSmp.fromCanonicalWith round)++{-# INLINE signalToBinaryStereo #-}+signalToBinaryStereo ::+   (RealField.C a, ToInteger.C int, Bounded int) =>+   [(a,a)] -> [int]+signalToBinaryStereo =+   concatMap (\(l,r) ->+      [BinSmp.fromCanonicalWith round l,+       BinSmp.fromCanonicalWith round r])
+ src/Synthesizer/Plain/Control.hs view
@@ -0,0 +1,493 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+module Synthesizer.Plain.Control where++import Synthesizer.Plain.Displacement (raise)++import qualified Synthesizer.Plain.Signal as Sig++import qualified Algebra.Module                as Module+import qualified Algebra.Transcendental        as Trans+import qualified Algebra.RealField             as RealField+import qualified Algebra.Field                 as Field+import qualified Algebra.Ring                  as Ring+import qualified Algebra.Additive              as Additive++import Algebra.Module((*>))++import Number.Complex (cis,real)+-- import qualified Number.Complex as Complex+import Data.List (zipWith4, tails, )+import Data.List.HT (iterateAssociative, )++import qualified Prelude as P+import PreludeBase+import NumericPrelude+++{- * Control curve generation -}++constant :: y -> Sig.T y+constant = repeat+++linear :: Additive.C y =>+      y   {-^ steepness -}+   -> y   {-^ initial value -}+   -> Sig.T y {-^ linear progression -}+linear d y0 = iterate (d+) y0++{- |+Minimize rounding errors by reducing number of operations per element+to a logarithmuc number.+-}+linearMultiscale :: Additive.C y =>+      y+   -> y+   -> Sig.T y+linearMultiscale = curveMultiscale (+)++{- |+Linear curve starting at zero.+-}+linearMultiscaleNeutral :: Additive.C y =>+      y+   -> Sig.T y+linearMultiscaleNeutral slope =+   curveMultiscaleNeutral (+) slope zero++{- |+As stable as the addition of time values.+-}+linearStable :: Ring.C y =>+      y+   -> y+   -> Sig.T y+linearStable d y0 =+   curveStable (d*) (+) 1 y0+++{- |+It computes the same like 'linear' but in a numerically more stable manner,+namely using a subdivision scheme.+The division needed is a division by two.++0       4       8+0   2   4   6   8+0 1 2 3 4 5 6 7 8+-}+linearMean :: Field.C y =>+      y+   -> y+   -> Sig.T y+linearMean d y0 = y0 :+   foldr (\pow xs -> y0+pow : linearSubdivision xs)+         unreachable (iterate (2*) d)++{- | Intersperse linearly interpolated values. -}+linearSubdivision :: Field.C y =>+      Sig.T y+   -> Sig.T y+linearSubdivision = subdivide (\x0 x1 -> (x0+x1)/2)+++{- |+Linear curve of a fixed length.+The final value is not actually reached,+instead we stop one step before.+This way we can concatenate several lines+without duplicate adjacent values.+-}+line :: Field.C y =>+      Int     {-^ length -}+   -> (y,y)   {-^ initial and final value -}+   -> Sig.T y {-^ linear progression -}+line n (y0,y1) =+   take n $ linear ((y1-y0) / fromIntegral n) y0++++exponential, exponentialMultiscale, exponentialStable :: Trans.C y =>+      y   {-^ time where the function reaches 1\/e of the initial value -}+   -> y   {-^ initial value -}+   -> Sig.T y {-^ exponential decay -}+exponential time = iterate (* exp (- recip time))+exponentialMultiscale time = curveMultiscale (*) (exp (- recip time))+exponentialStable time = exponentialStableGen exp (- recip time)++exponentialMultiscaleNeutral :: Trans.C y =>+      y   {-^ time where the function reaches 1\/e of the initial value -}+   -> Sig.T y {-^ exponential decay -}+exponentialMultiscaleNeutral time =+   curveMultiscaleNeutral (*) (exp (- recip time)) one++exponential2, exponential2Multiscale, exponential2Stable :: Trans.C y =>+      y   {-^ half life -}+   -> y   {-^ initial value -}+   -> Sig.T y {-^ exponential decay -}+exponential2 halfLife = iterate (*  0.5 ** recip halfLife)+exponential2Multiscale halfLife = curveMultiscale (*) (0.5 ** recip halfLife)+exponential2Stable halfLife = exponentialStableGen (0.5 **) (recip halfLife)++exponential2MultiscaleNeutral :: Trans.C y =>+      y   {-^ half life -}+   -> Sig.T y {-^ exponential decay -}+exponential2MultiscaleNeutral halfLife =+   curveMultiscaleNeutral (*) (0.5 ** recip halfLife) one+++exponentialFromTo, exponentialFromToMultiscale :: Trans.C y =>+      y   {-^ time where the function reaches 1\/e of the initial value -}+   -> y   {-^ initial value -}+   -> y   {-^ value after given time -}+   -> Sig.T y {-^ exponential decay -}+exponentialFromTo time y0 y1 =+   iterate (*  (y1/y0) ** recip time) y0+exponentialFromToMultiscale time y0 y1 =+   curveMultiscale (*) ((y1/y0) ** recip time) y0+++exponentialStableGen :: (Ring.C y, Ring.C t) =>+      (t -> y)+   -> t+   -> y+   -> Sig.T y+exponentialStableGen expFunc = curveStable expFunc (*)+++++{-| This is an extension of 'exponential' to vectors+    which is straight-forward but requires more explicit signatures.+    But since it is needed rarely I setup a separate function. -}+vectorExponential :: (Trans.C y, Module.C y v) =>+       y  {-^ time where the function reaches 1\/e of the initial value -}+   ->  v  {-^ initial value -}+   -> Sig.T v {-^ exponential decay -}+vectorExponential time y0 = iterate (exp (-1/time) *>) y0++vectorExponential2 :: (Trans.C y, Module.C y v) =>+       y  {-^ half life -}+   ->  v  {-^ initial value -}+   -> Sig.T v {-^ exponential decay -}+vectorExponential2 halfLife y0 = iterate (0.5**(1/halfLife) *>) y0++++cosine, cosineMultiscale, cosineSubdiv, cosineStable :: Trans.C y =>+       y  {-^ time t0 where  1 is approached -}+   ->  y  {-^ time t1 where -1 is approached -}+   -> Sig.T y {-^ a cosine wave where one half wave is between t0 and t1 -}+cosine = cosineWithSlope $+   \d x -> map cos (linear d x)++cosineMultiscale = cosineWithSlope $+   \d x -> map real (curveMultiscale (*) (cis d) (cis x))+++{-+  cos (a-b) = cos a * cos b + sin a * sin b+  cos (a+b) = cos a * cos b - sin a * sin b+  cos  a    = (cos (a-b) + cos (a+b)) / (2 * cos b)++  Problem: (cos b) might be close to zero,+  example: Syn.cosineStable 1 (9::Double)+-}+cosineSubdiv =+   let aux d y0 =+          cos y0 :+            foldr (\pow xs -> cos(y0+pow) : cosineSubdivision pow xs)+                  unreachable (iterate (2*) d)+   in  cosineWithSlope aux++cosineSubdivision :: Trans.C y =>+      y+   -> Sig.T y+   -> Sig.T y+cosineSubdivision angle =+   let k = recip (2 * cos angle)+   in  subdivide (\x0 x1 -> (x0+x1)*k)++cosineStable = cosineWithSlope $+   \d x -> map real (exponentialStableGen cis d (cis x))+++cosineWithSlope :: Trans.C y =>+      (y -> y -> signal)+   ->  y+   ->  y+   -> signal+cosineWithSlope c t0 t1 =+   let inc = pi/(t1-t0)+   in  c inc (-t0*inc)+++cubicHermite :: Field.C y => (y, (y,y)) -> (y, (y,y)) -> Sig.T y+cubicHermite node0 node1 =+   map (cubicFunc node0 node1) (linear 1 0)++{- |+0                                     16+0               8                     16+0       4       8         12          16+0   2   4   6   8   10    12    14    16+0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16+-}+cubicFunc :: Field.C y => (y, (y,y)) -> (y, (y,y)) -> y -> y+cubicFunc (t0, (y0,dy0)) (t1, (y1,dy1)) t =+   let dt  = t0-t1+       dt0 = t-t0+       dt1 = t-t1+       x0  = dt1^2+       x1  = dt0^2+   in  ((dy0*dt0 + y0 * (1-2/dt*dt0)) * x0 ++        (dy1*dt1 + y1 * (1+2/dt*dt1)) * x1) / dt^2+{-+cubic t0 (y0,dy0) t1 (y1,dy1) t =+   let x0 = ((t-t1) / (t0-t1))^2+       x1 = ((t-t0) / (t1-t0))^2+   in  y0 * x0 + y1 * x1 ++       (dy0 - y0*2/(t0-t1)) * (t-t0)*x0 ++       (dy1 - y1*2/(t1-t0)) * (t-t1)*x1+-}++cubicHermiteStable :: Field.C y => (y, (y,y)) -> (y, (y,y)) -> Sig.T y+cubicHermiteStable node0 node1 =+   cubicFunc node0 node1 0 :+      foldr (\pow xs ->+                cubicFunc node0 node1 pow : head xs :+                cubicFunc node0 node1 (3*pow) : cubicSubdivision xs)+            unreachable (iterate (2*) 1)++cubicSubdivision :: Field.C y => Sig.T y -> Sig.T y+cubicSubdivision xs =+   let xs0:xs1:xs2:xs3:_ = tails xs+       inter = zipWith4 (\x0 x1 x2 x3 -> (9*(x1+x2) - (x0+x3))/16)+                        xs0 xs1 xs2 xs3+   in  head xs1 : flattenPairs (zip inter xs2)++{-+            foldr (\(pow0:pow1:_) ~(_:xs) ->+                      cos (y0+pow0) : cos (y0+pow1) : cos (y0+pow0+pow1) :+                         cosineSubdivision pow0 xs)+                  unreachable (tails (iterate (2*) d))+-}+++{-+maybe cubicHermite could also be implemented in a Multiscale manner+using a difference scheme.++cubicHermiteMultiscale :: Field.C y => (y, (y,y)) -> (y, (y,y)) -> Sig.T y+cubicHermiteMultiscale node0@(t0,y0) node1@(t1,y1) =+   let -- could be inlined and simplified+       ys = map (cubicFunc node0 node1) [0,1,2,3]+       (d0:d1:d2:d3:_) = iterate (zapWith substract) ys++I thought multiplying difference schemes could help somehow,+but it doesn't. :-(++cubicHermiteMultiscale++Leibniz rule for differences++D3(s+r) = D0(s)*D3(r) + 3*D1(s)*D2(r) + 3*D2(s)*D1(r) + D3(s)*D0(r)+++mulDiffs4 :: Ring.C a => (a,a,a,a) -> (a,a,a,a) -> (a,a,a,a)+mulDiffs4 (r0,r1,r2,r3) (s0,s1,s2,s3) =+   (r0*s0,+    r0*s1 +   r1*s0,+    r0*s2 + 2*r1*s1 +   r2*s0,+    r0*s3 + 3*r1*s2 + 3*r2*s1 + r3*s0)++mulDiffs4zero :: Ring.C a => (a,a,a) -> (a,a,a) -> (a,a,a)+mulDiffs4zero (r0,r1,r2,r3) (s0,s1,s2,s3) =+   (r0*s0,+    r0*s1 +   r1*s0,+    r0*s2 + 2*r1*s1 +   r2*s0,+    r0*s3 + 3*r1*s2 + 3*r2*s1 + r3*s0)++mulDiffs3 :: Ring.C a => (a,a,a) -> (a,a,a) -> (a,a,a)+mulDiffs3 (r0,r1,r2) (s0,s1,s2) =+   (r0*s0,+    r0*s1 +   r1*s0,+    r0*s2 + 2*r1*s1 +   r2*s0)++mulDiffs3Karatsuba :: Ring.C a => (a,a,a) -> (a,a,a) -> (a,a,a)+mulDiffs3Karatsuba (r0,r1,r2) (s0,s1,s2) =+   let r0s0 = r0*s0+       r1s1 = r1*s1+   in  (r0s0,+        (r0+r1)*(s0+s1) - r0s0 - r1s1,+        r0*s2 + 2*r1s1 + r2*s0)+-}++++{- |+The curve type of a piece of a piecewise defined control curve.+-}+data Control y =+     CtrlStep+   | CtrlLin+   | CtrlExp {ctrlExpSaturation :: y}+   | CtrlCos+   | CtrlCubic {ctrlCubicGradient0 :: y,+                ctrlCubicGradient1 :: y}+   deriving (Eq, Show)++{- |+The full description of a control curve piece.+-}+data ControlPiece y =+     ControlPiece {pieceType :: Control y,+                   pieceY0 :: y,+                   pieceY1 :: y,+                   pieceDur :: y}+   deriving (Eq, Show)+++newtype PieceRightSingle y = PRS y+newtype PieceRightDouble y = PRD y++type ControlDist y = (y, Control y, y)+++-- precedence and associativity like (:)+infixr 5 -|#, #|-, =|#, #|=, |#, #|++{- |+The 6 operators simplify constructing a list of @ControlPiece a@.+The description consists of nodes (namely the curve values at nodes)+and the connecting curve types.+The naming scheme is as follows:+In the middle there is a bar @|@.+With respect to the bar,+the pad symbol @\#@ is at the side of the curve type,+at the other side there is nothing, a minus sign @-@, or an equality sign @=@.++ (1) Nothing means that here is the start or the end node of a curve.++ (2) Minus means that here is a node where left and right curve meet at the same value.+     The node description is thus one value.++ (3) Equality sign means that here is a split node,+     where left and right curve might have different ending and beginning values, respectively.+     The node description consists of a pair of values.+-}++-- the leading space is necessary for the Haddock parser++( #|-) :: (y, Control y) -> (PieceRightSingle y, [ControlPiece y]) ->+   (ControlDist y, [ControlPiece y])+(d,c) #|- (PRS y1, xs)  =  ((d,c,y1), xs)++(-|#) :: y -> (ControlDist y, [ControlPiece y]) ->+   (PieceRightSingle y, [ControlPiece y])+y0 -|# ((d,c,y1), xs)  =  (PRS y0, ControlPiece c y0 y1 d : xs)++( #|=) :: (y, Control y) -> (PieceRightDouble y, [ControlPiece y]) ->+   (ControlDist y, [ControlPiece y])+(d,c) #|= (PRD y1, xs)  =  ((d,c,y1), xs)++(=|#) :: (y,y) -> (ControlDist y, [ControlPiece y]) ->+   (PieceRightDouble y, [ControlPiece y])+(y01,y10) =|# ((d,c,y11), xs)  =  (PRD y01, ControlPiece c y10 y11 d : xs)++( #|) :: (y, Control y) -> y ->+   (ControlDist y, [ControlPiece y])+(d,c) #| y1  =  ((d,c,y1), [])++(|#) :: y -> (ControlDist y, [ControlPiece y]) ->+   [ControlPiece y]+y0 |# ((d,c,y1), xs)  =  ControlPiece c y0 y1 d : xs+++piecewise :: (Trans.C y, RealField.C y) =>+   [ControlPiece y] -> Sig.T y+piecewise xs =+   let ts = scanl (\(_,fr) d -> splitFraction (fr+d))+                  (0,1) (map pieceDur xs)+   in  concat (zipWith3+          (\n t (ControlPiece c yi0 yi1 d) ->+               piecewisePart yi0 yi1 t d n c)+          (map fst (tail ts)) (map (subtract 1 . snd) ts)+          xs)+++piecewisePart :: (Trans.C y) =>+   y -> y -> y -> y -> Int -> Control y -> Sig.T y+piecewisePart y0 y1 t0 d n ctrl =+   take n+      (case ctrl of+         CtrlStep  -> constant y0+         CtrlLin   -> let s = (y1-y0)/d in linearStable s (y0-t0*s)+         CtrlExp s -> let y0' = y0-s; y1' = y1-s; yd = y0'/y1'+                      in  raise s (exponentialStable (d / log yd)+                                           (y0' * yd**(t0/d)))+         CtrlCos   -> map (\y -> (1+y)*(y0/2)+(1-y)*(y1/2))+                          (cosineStable t0 (t0+d))+         CtrlCubic yd0 yd1 ->+            cubicHermiteStable (t0,(y0,yd0)) (t0+d,(y1,yd1)))++{-+  exp (-1/time) == yd**(-1/d)+  1/time == log yd / d+  time   == d / log yd+-}++{-+  piecewise (0 |# (10.21, CtrlExp 1.1) #|- 1 -|# (10,CtrlExp 0.49) #|- 0.5 -|# (30, CtrlLin) #|- 0.5 -|# (20, CtrlCos) #| 0)++  piecewise (0 |# (10.21, CtrlExp 1.1) #|- 1 -|# (10,CtrlCubic (-0.1) 0) #|- 0.5 -|# (30, CtrlLin) #|- 0.5 -|# (20, CtrlCos) #| 0)+-}+++{- * Auxiliary functions -}++curveStable :: (Additive.C t) =>+      (t -> y)+   -> (y -> y -> y)+   -> t+   -> y+   -> Sig.T y+curveStable expFunc op time y0 =+   y0 : map (op y0)+      (foldr+         (\e xs ->+            let k = expFunc e+            in  k : concatMapPair (\x -> (x, op x k)) xs)+       unreachable (iterate double time))++unreachable :: a+unreachable = error "only reachable in infinity"++double :: Additive.C t => t -> t+double t = t+t++concatMapPair :: (a -> (b,b)) -> Sig.T a -> Sig.T b+concatMapPair f = flattenPairs . map f++flattenPairs :: Sig.T (a,a) -> Sig.T a+flattenPairs = foldr (\(a,b) xs -> a:b:xs) []++subdivide :: (y -> y -> y) -> Sig.T y -> Sig.T y+subdivide f xs0@(x:xs1) =+   x : flattenPairs (zipWith (\x0 x1 -> (f x0 x1, x1)) xs0 xs1)+subdivide _ [] = []+++concatMapPair' :: (a -> (b,b)) -> Sig.T a -> Sig.T b+concatMapPair' f = concatMap ((\(x,y) -> [x,y]) . f)+++curveMultiscale :: (y -> y -> y) -> y -> y -> Sig.T y+curveMultiscale op d y0 =+   y0 : map (op y0) (iterateAssociative op d)+++curveMultiscaleNeutral :: (y -> y -> y) -> y -> y -> Sig.T y+curveMultiscaleNeutral op d neutral =+   neutral : iterateAssociative op d
+ src/Synthesizer/Plain/Cut.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE NoImplicitPrelude #-}+{- |+Copyright   :  (c) Henning Thielemann 2006+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes+-}+module Synthesizer.Plain.Cut (+   {- * dissection -}+   takeUntilPause,+   takeUntilInterval,++   {- * glueing -}+   selectBool,+   select,+   arrange,+   ) where++import qualified Synthesizer.Plain.Signal as Sig++import qualified Data.EventList.Relative.TimeBody as EventList++import qualified MathObj.LaurentPolynomial as Laurent+import qualified Algebra.Real     as Real+import qualified Algebra.Additive as Additive++import Data.Array (Array, Ix, (!))++import qualified Number.NonNegative as NonNeg++import PreludeBase+import NumericPrelude++++{- |+Take signal until it falls short of a certain amplitude for a given time.+-}+takeUntilPause :: (Real.C a) => a -> Int -> Sig.T a -> Sig.T a+takeUntilPause y =+   takeUntilInterval ((<=y) . abs)++{- |+Take values until the predicate p holds for n successive values.+The list is truncated at the beginning of the interval of matching values.+-}+takeUntilInterval :: (a -> Bool) -> Int -> Sig.T a -> Sig.T a+takeUntilInterval p n xs =+   map fst $+   takeWhile ((<n) . snd) $+   zip xs $+   drop n $+   scanl (\acc x -> if p x then succ acc else 0) 0 xs+      ++ repeat 0++++-- Better use zipWithMatch from NumericPrelude?+selectBool :: (Sig.T a, Sig.T a) -> Sig.T Bool -> Sig.T a+selectBool =+   uncurry (zipWith3 (\xf xt c -> if c then xt else xf))+{-+   zipWithMatch (\(xf,xt) c -> if c then xt else xf) .+   uncurry (zipWithMatch (,))+-}+++select :: Ix i => Array i (Sig.T a) -> Sig.T i -> Sig.T a+select arr =+   zipWith (!)+      (map (fmap head) $ iterate (fmap tail) arr)++++{- |+Given a list of signals with time stamps,+mix them into one signal as they occur in time.+Ideally for composing music.++Cf. 'MathObj.LaurentPolynomial.series'+-}+arrange :: (Additive.C v) =>+       EventList.T NonNeg.Int (Sig.T v)+            {-^ A list of pairs: (relative start time, signal part),+                The start time is relative to the start time+                of the previous event. -}+    -> Sig.T v+            {-^ The mixed signal. -}+arrange evs =+   let xs = EventList.getBodies evs+   in  case map NonNeg.toNumber (EventList.getTimes evs) of+          t:ts -> replicate t zero ++ Laurent.addShiftedMany ts xs+          []   -> []
+ src/Synthesizer/Plain/Displacement.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE NoImplicitPrelude #-}+{- |+<http://en.wikipedia.org/wiki/Particle_displacement>+-}+module Synthesizer.Plain.Displacement where++import qualified Algebra.Additive              as Additive++import qualified Synthesizer.Plain.Signal as Sig++-- import qualified Prelude as P+import PreludeBase+import NumericPrelude+++{- * Mixing -}++{-| Mix two signals.+    In opposition to 'zipWith' the result has the length of the longer signal. -}+mix :: (Additive.C v) => Sig.T v -> Sig.T v -> Sig.T v+mix = (+)++{- relict from Prelude98's Num+mixMono :: Ring.C a => [a] -> [a] -> [a]+mixMono [] x  = x+mixMono x  [] = x+mixMono (x:xs) (y:ys) = x+y : mixMono xs ys+-}++{-| Mix an arbitrary number of signals. -}+mixMulti :: (Additive.C v) => [Sig.T v] -> Sig.T v+mixMulti = foldl mix zero+++{-| Add a number to all of the signal values.+    This is useful for adjusting the center of a modulation. -}+raise :: (Additive.C v) => v -> Sig.T v -> Sig.T v+raise x = map ((+) x)+++{- * Distortion -}+{- |+In "Synthesizer.Basic.Distortion" you find a collection+of appropriate distortion functions.+-}+distort :: (c -> a -> a) -> Sig.T c -> Sig.T a -> Sig.T a+distort = zipWith
+ src/Synthesizer/Plain/Effect.hs view
@@ -0,0 +1,120 @@+module Synthesizer.Plain.Effect where++import qualified Synthesizer.Plain.Noise as Noise+import qualified Synthesizer.Plain.Filter.Recursive as Filter+import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder  as Filt1+-- import qualified Synthesizer.Plain.Filter.Recursive.Allpass     as Allpass+-- import qualified Synthesizer.Plain.Filter.Recursive.Universal   as UniFilter+import qualified Synthesizer.Plain.Filter.Recursive.Moog        as Moog+import qualified Synthesizer.Plain.Filter.Recursive.Comb        as Comb+-- import qualified Synthesizer.Plain.Filter.Recursive.Integration as Integrate+import qualified Synthesizer.Plain.Filter.Recursive.Butterworth as Butter+import qualified Synthesizer.Plain.Filter.Recursive.Chebyshev   as Cheby+import Synthesizer.Plain.Control(exponential2)+import Synthesizer.Plain.Instrument+import Synthesizer.Plain.Effect.Glass(glass)+import qualified Synthesizer.Plain.File as File+import Synthesizer.Filter.Example(guitarRaw, flangedSaw)+--import Interpolation(interpolate,interpolateConstant)+--import System.Random+import System.Exit(ExitCode)+import System.Cmd(rawSystem)++main :: IO ExitCode+main =+   let rate = 44100+   in  do {- File.writeMono "test" rate+                (take (round (3*rate)) (soundD rate)) -}+          File.renderMonoToInt16 "test.aiff" rate soundE+          rawSystem "play" ["test.aiff"]+++soundE, soundD,+   soundC, soundB, soundA,+   sound9, sound8, sound7,+   sound6, sound5, sound4,+   sound3, sound2, sound1,+   sound0, soundm0 :: Double -> [Double]++soundE = glass++soundD = flangedSaw++soundC _ = guitarRaw++cFreq :: Double+cFreq = 521.3417849066773++soundB sampleRate =+   let baseFreq = cFreq/2+       chord = zipWith3 (\x y z -> (x+y+z)/5)+                        (choir sampleRate (baseFreq*1/1))+                        (choir sampleRate (baseFreq*5/4))+                        (choir sampleRate (baseFreq*3/2))+       filterFreqs = map (3000/sampleRate*)+                         (map sin (iterate (pi/(6*sampleRate)+) 0))+   in  Butter.lowpassPole 8 (repeat (0.3::Double)) filterFreqs (chord::[Double])++soundA sampleRate =+   choir sampleRate cFreq++sound9 sampleRate =+   map (*0.1) (accumulatedSaws sampleRate cFreq !! 20)++sound8 sampleRate =+   let filterFreqs = exponential2 (-0.5*sampleRate) (100/sampleRate)+   --  Cheby.lowpassBPole+   --  Cheby.highpassBPole+   --  Cheby.lowpassAPole+   --  Cheby.highpassAPole+   in  Cheby.lowpassBPole 8 (repeat (0.3::Double)) filterFreqs (Noise.white::[Double])++sound7 sampleRate =+   let filterFreqs = exponential2 (-0.5*sampleRate) (100/sampleRate)+   --  butterworthHighpass+   in  Butter.lowpassPole 8 (repeat (0.3::Double)) filterFreqs (Noise.white::[Double])++-- a moog filter which randomly changes the resonance frequency+sound6 sampleRate =+   let order = 10+       {- unused+       switchRates = repeat (8/sampleRate)+       filterFreqs = map (\exp -> 100*2**exp/sampleRate)+                         ((randomRs (0,6) (mkStdGen 142857))::[Double])+       filterReso  = 10+        -}++       control0 {-, control1, control2-} :: [Moog.Parameter Double]+       -- constant control+       control0 = repeat (Moog.parameter order (Filter.Pole 10 (400/sampleRate)))+       -- apply moogFilterParam first then resample, fast+       {- Need Additive and VectorSpace instances for MoogFilterParam+       control1 = interpolateConstant 0 switchRates+                     (map (moogFilterParam order)+                          (map (Pole filterReso) filterFreqs))+       -- first resample then apply moogFilterParam, slow+       control2 = map (moogFilterParam order)+                      (map (Pole filterReso)+                           (interpolateConstant 0 switchRates filterFreqs))+       -}+   in  Moog.lowpass order control0+          (map (0.5*) (fatSawChord sampleRate 220))++sound5 sampleRate =+   Comb.runMulti+      (map (\t -> round (t*sampleRate)) [0.08,0.13,0.21])+      (0.3::Double) (bell sampleRate 441)+sound4 sampleRate =+   Comb.runProc+      (round (0.3*sampleRate))+      (Filt1.lowpass+          (repeat (Filt1.parameter (441/sampleRate::Double))))+      (bell sampleRate 441)++sound3 sampleRate = allpassPlain sampleRate 0.3 1 441+sound2 sampleRate = allpassDown  sampleRate 10 0.5 1000 441++sound1 sampleRate = map (0.1*) (moogDown sampleRate 6 0.4 5000 441)+sound0 sampleRate = map (0.3*) (moogReso sampleRate 6 0.1 2000 441)++soundm0 sampleRate = fatSawChordFilter sampleRate 110
+ src/Synthesizer/Plain/Effect/Fly.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE NoImplicitPrelude #-}+module Synthesizer.Plain.Effect.Fly where++import qualified Synthesizer.Plain.Oscillator as Osci+import qualified Synthesizer.Plain.Filter.NonRecursive as FiltNR+import qualified Synthesizer.Plain.Interpolation as Interpolation+import qualified Synthesizer.Plain.Miscellaneous as Syn++import qualified Synthesizer.Plain.File as File+import System.Exit(ExitCode)++import System.Random++import qualified Algebra.NormedSpace.Euclidean as Euc++import PreludeBase+import NumericPrelude+++{-+  ghc -O -fvia-C -fglasgow-exts -fallow-undecidable-instances --make Fly.hs && echo start && time a.out+-}++main :: IO ExitCode+main =+   File.writeStereoToInt16 "Fly" sampleRate+      (take (round (10*sampleRate)) fly)++sampleRate :: Double+sampleRate = 44100++{-| stereo sound of a humming fly -}+fly :: [(Double,Double)]+fly =+   let pinkNoise seed freq range =+           Interpolation.multiRelativeZeroPadCubic (0::Double)+           (repeat (freq/sampleRate))+           (randomRs (-range,range) (mkStdGen seed))+       {- the track of a fly is composed of a slow motion over a big range+          and fast but small oscillations -}+       flyCoord seed = zipWith (+) (pinkNoise seed 40 0.3)+                                   (pinkNoise seed  1 10)+       {- explicit signature required+          because of multi-param type class NormedEuc -}+       trajectory :: [(Double, Double, Double)]+       trajectory =+          zip3 (flyCoord 366210)+               (flyCoord 234298)+               (flyCoord 654891)++       channel ear =+          let (phase,volumes) = Syn.receive3Dsound 1 0.1 ear trajectory+              -- (*sampleRate) in 'speed' and+              -- (/sampleRate) in 'freqs' neutralizes+              speeds  = map (\v -> 250/sampleRate+2*(Euc.norm v))+                            (zipWith subtract (tail trajectory) trajectory)+              freqs   = zipWith (+) speeds (FiltNR.differentiate phase)+              sound   = Osci.freqModSaw 0 freqs+          in  zipWith (*) (map (10*) volumes) sound++   in  zip (channel (-1,0,0)) (channel (1,0,0))
+ src/Synthesizer/Plain/Effect/Glass.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE NoImplicitPrelude #-}+module Synthesizer.Plain.Effect.Glass where++import qualified Data.EventList.Relative.TimeBody as EventList+import qualified Number.NonNegative as NonNeg++import qualified Synthesizer.Plain.Oscillator as Osci+import qualified Synthesizer.Basic.Wave       as Wave+import qualified Synthesizer.Plain.Cut        as Cut+import qualified Synthesizer.Plain.Control    as Ctrl+import qualified Synthesizer.Plain.Noise      as Noise+import qualified Synthesizer.Plain.Filter.NonRecursive as FiltNR++import qualified Algebra.Transcendental as Trans+import qualified Algebra.RealField      as RealField+import qualified Algebra.Additive       as Additive+import qualified Algebra.Module         as Module++import System.Random(randomRs, mkStdGen)++import PreludeBase+import NumericPrelude as NP+++{- | We try to simulate the sound of broken glass+     as a mixture of short percussive sounds with random pitch -}+glass :: Double -> [Double]+glass sampleRate =+   Cut.arrange (particles sampleRate 1500)++particles :: Double -> Double -> EventList.T NonNeg.Int [Double]+particles sampleRate freq =+   let sampledDensity =+          (2000/sampleRate) *> map densityHeavy [0, (1/sampleRate) ..]+       pattern = take (round (0.8*sampleRate))+                      (Noise.randomPeeks sampledDensity)+       times   = timeDiffs pattern+       chirp   = iterate (0.001+) 0+       pitches = map ((freq*) . (2**))+                     (zipWith (+) chirp (randomRs (0,1) (mkStdGen 56)))+       amps    = map (0.4*) (map (2**) (randomRs (-2,0) (mkStdGen 721)))+   in  EventList.fromPairList $ zip times $+       zipWith (particle sampleRate) pitches amps+++particle :: (RealField.C a, Trans.C a, Module.C a a) => a -> a -> a -> [a]+particle sampleRate freq amp =+   let halfLife = 0.01+   in  take (round (10*halfLife*sampleRate))+            (FiltNR.envelopeVector+                (Osci.static Wave.square 0 (freq/sampleRate))+                (Ctrl.exponential2 (0.01*sampleRate) amp))++densitySmooth, densityHeavy :: Trans.C a => a -> a+densitySmooth x = x * exp(-10*x*x)+densityHeavy  x = 0.4 * exp (-4*x)++timeDiffsAlt :: [Bool] -> [NonNeg.Int]+timeDiffsAlt =+   let diffs n (True  : xs) = n : diffs 1 xs+       diffs n (False : xs) = diffs (succ n) xs+       diffs _ [] = []+   in  diffs (NonNeg.fromNumber 0)++timeDiffs :: [Bool] -> [NonNeg.Int]+timeDiffs = map (NonNeg.fromNumber . length) . segmentBefore id++segmentBefore :: (a -> Bool) -> [a] -> [[a]]+segmentBefore p =+   foldr (\ x ~(y:ys) -> (if p x then ([]:) else id) ((x:y):ys)) [[]]
+ src/Synthesizer/Plain/File.hs view
@@ -0,0 +1,178 @@+{-# LANGUAGE NoImplicitPrelude #-}+module Synthesizer.Plain.File where++import qualified Sound.Sox.Convert as Convert+import qualified Sound.Sox.Frame as Frame+import qualified Sound.Sox.Frame.Stereo as Stereo+import qualified Sound.Sox.Option.Format as SoxOpt+import qualified Sound.Sox.Write as Write+import qualified Sound.Sox.Read as Read+import qualified Sound.Sox.Signal.List as SoxList++import qualified Synthesizer.Plain.IO as FileL+import qualified Synthesizer.Plain.Builder as Builder++import qualified Data.ByteString.Lazy as B+import qualified Data.Binary.Get as Get+import qualified Synthesizer.Basic.Binary as BinSmp+import Foreign.Storable (Storable, )+import Data.Int (Int16, )++import System.Cmd (rawSystem, )+import System.Exit (ExitCode, )+import Control.Monad (liftM2, )+import Data.Monoid (mconcat, )++import qualified Algebra.ToInteger          as ToInteger+import qualified Algebra.RealField          as RealField+import qualified Algebra.Field              as Field++import qualified System.FilePath as FilePath++import PreludeBase+import NumericPrelude++++{- |+See 'write'.+-}+render ::+   (Storable int, Frame.C int, ToInteger.C int, Bounded int,+    RealField.C a, BinSmp.C v) =>+   Builder.Put int -> FilePath -> a -> (a -> [v]) -> IO ExitCode+render put fileName sampleRate renderer =+   write put fileName sampleRate (renderer sampleRate)++renderToInt16 :: (RealField.C a, BinSmp.C v) =>+   FilePath -> a -> (a -> [v]) -> IO ExitCode+renderToInt16 fileName sampleRate renderer =+   writeToInt16 fileName sampleRate (renderer sampleRate)++renderMonoToInt16 :: (RealField.C a) =>+   FilePath -> a -> (a -> [a]) -> IO ExitCode+renderMonoToInt16 fileName sampleRate renderer =+   writeMonoToInt16 fileName sampleRate (renderer sampleRate)++renderStereoToInt16 :: (RealField.C a) =>+   FilePath -> a -> (a -> [(a,a)]) -> IO ExitCode+renderStereoToInt16 fileName sampleRate renderer =+   writeStereoToInt16 fileName sampleRate (renderer sampleRate)+++{- |+The output format is determined by SoX by the file name extension.+The sample precision is determined by the provided 'Builder.Put' function.++Example:++> import qualified Synthesizer.Plain.Builder as Builder+>+> write (Builder.put :: Builder.Put Int16) "test.aiff" 44100 sound+-}+write ::+   (Storable int, Frame.C int, ToInteger.C int, Bounded int,+    RealField.C a, BinSmp.C v) =>+   Builder.Put int -> FilePath -> a -> [v] -> IO ExitCode+write put fileName sampleRate signal =+   writeRaw+      (SoxOpt.numberOfChannels (BinSmp.numberOfSignalChannels signal))+      fileName+      sampleRate+      (Builder.run . mconcat . map (BinSmp.outputFromCanonical put) $+       signal)++writeToInt16 :: (RealField.C a, BinSmp.C v) =>+   FilePath -> a -> [v] -> IO ExitCode+writeToInt16 =+   write (Builder.put :: Builder.Put Int16)++writeMonoToInt16 :: (RealField.C a) =>+   FilePath -> a -> [a] -> IO ExitCode+writeMonoToInt16 fileName sampleRate signal =+   writeRaw SoxOpt.none fileName sampleRate+      (map BinSmp.int16FromCanonical signal)++writeStereoToInt16 :: (RealField.C a) =>+   FilePath -> a -> [(a,a)] -> IO ExitCode+writeStereoToInt16 fileName sampleRate signal =+   writeRaw SoxOpt.none fileName sampleRate+      (map (fmap BinSmp.int16FromCanonical . uncurry Stereo.cons) signal)++writeRaw :: (RealField.C a, Frame.C v, Storable v) =>+   SoxOpt.T -> FilePath -> a -> [v] -> IO ExitCode+writeRaw opts fileName sampleRate signal =+   Write.extended SoxList.put opts SoxOpt.none fileName (round sampleRate) signal++{- |+You hardly need this routine+since you can use a filename with @.mp3@ or @.ogg@+extension for 'writeRaw'+and SoX will do the corresponding compression for you.+-}+writeRawCompressed :: (RealField.C a, Frame.C v, Storable v) =>+   SoxOpt.T -> FilePath -> a -> [v] -> IO ExitCode+writeRawCompressed opts fileName sampleRate signal =+   do writeRaw opts fileName sampleRate signal+      compress fileName+++{-# DEPRECATED rawToAIFF "If you want to generate AIFF, then just write to files with .aiff filename extension. If you want to convert files to AIFF, use Sound.Sox.Convert." #-}+rawToAIFF :: (RealField.C a) =>+   FilePath -> SoxOpt.T -> a -> Int -> IO ExitCode+rawToAIFF fileName soxOptions sampleRate numChannels =+   let fileNameRaw  = fileName ++ ".sw"+       fileNameAIFF = fileName ++ ".aiff"+   in  Convert.simple+          (mconcat $+           soxOptions :+           SoxOpt.sampleRate (round sampleRate) :+           SoxOpt.numberOfChannels numChannels :+           [])+          fileNameRaw+          SoxOpt.none fileNameAIFF++compress :: FilePath -> IO ExitCode+compress fileName =+   do rawSystem "oggenc" ["--quality", "5", fileName]+      rawSystem "lame"+         ["-h", fileName, FilePath.replaceExtension fileName "mp3"]+++{-# DEPRECATED readAIFFMono "Use readMonoFromInt16 instead" #-}+{-+This implementation doesn't work properly.+It seems like readFile is run+after all system calls to Sox are performed.+Aren't the calls serialized?++readAIFFMono :: (RealField.C a, Floating a) => FilePath -> IO [a]+readAIFFMono file =+   do putStrLn ("sox "++file++" /tmp/sample.sw")+      system ("sox "++file++" /tmp/sample.sw")+      str <- readFile "/tmp/sample.sw"+      return (binaryToSignalMono str)+-}+readAIFFMono :: (Field.C a) => FilePath -> IO [a]+readAIFFMono file =+   do --putStrLn ("sox "++file++" "++tmp)+      let tmp = FilePath.replaceExtension file "sw"+      Convert.simple SoxOpt.none file SoxOpt.none tmp+      fmap (map BinSmp.int16ToCanonical) (FileL.readInt16StreamStrict tmp)+++{- |+I suspect we cannot handle file closing properly.+-}+readMonoFromInt16 :: (Field.C a) => FilePath -> IO [a]+readMonoFromInt16 fileName =+   Read.open SoxOpt.none fileName >>=+   Read.withHandle1 (fmap (Get.runGet getInt16List) . B.hGetContents) >>=+   return . map BinSmp.int16ToCanonical++getInt16List :: Get.Get [Int16]+getInt16List =+   do b <- Get.isEmpty+      if b+        then return []+        else liftM2 (:) (fmap fromIntegral Get.getWord16host) getInt16List
+ src/Synthesizer/Plain/Filter/Delay.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE NoImplicitPrelude #-}+module Synthesizer.Plain.Filter.Delay where++import qualified Synthesizer.Plain.Filter.NonRecursive as FiltNR+import qualified Synthesizer.Plain.Displacement as Syn+import qualified Synthesizer.Plain.Control as Ctrl+import qualified Synthesizer.Plain.Noise   as Noise+import System.Random (Random, randomRs, mkStdGen, )++import qualified Algebra.Module    as Module+import qualified Algebra.RealField as RealField+import qualified Algebra.Additive  as Additive++import qualified Synthesizer.Plain.Interpolation as Interpolation++import qualified Synthesizer.Plain.Filter.Delay.ST    as DelayST+import qualified Synthesizer.Plain.Filter.Delay.List  as DelayList+import qualified Synthesizer.Plain.Filter.Delay.Block as DelayBlock++import qualified Prelude as P+import PreludeBase+import NumericPrelude+++phaser :: (Module.C a v, RealField.C a) => a -> [a] -> [v] -> [v]+phaser maxDelay ts xs =+   FiltNR.amplifyVector (0.5 `asTypeOf` head ts)+      (Syn.mix xs+          (DelayBlock.modulated Interpolation.constant (ceiling maxDelay) ts xs))+++plane :: Double -> [Double]+plane sampleRate =+   let maxDelay = 500+   in  phaser+          maxDelay+          (map (maxDelay-)+               (Ctrl.exponential2 (10*sampleRate) maxDelay))+          Noise.white+++-- move to test suite ***+propSingle :: Interpolation.T Double Double -> [Bool]+propSingle ip =+   let maxDelay = (5::Int)+       xs = randomRs (-1,1) (mkStdGen 1037)+       ts = take 20 (randomRs (0, fromIntegral maxDelay) (mkStdGen 2330))+       pm0 = DelayST.modulated      ip maxDelay ts xs+       pm1 = DelayList.modulatedRev ip maxDelay ts xs+       pm2 = DelayList.modulated    ip maxDelay ts xs+       pm3 = DelayBlock.modulated   ip maxDelay ts xs+       approx x y = abs (x-y) < 1e-10+       -- equal as = and (zipWith (==) as (tail as))+       -- equal [pm0, pm1 {-, pm2-}]+   in  [pm0==pm1, pm2==pm3, and (zipWith approx pm1 pm2)]++{- |+The test for constant interpolation will fail,+due to different point of views in forward and backward interpolation.+-}+propAll :: [[Bool]]+propAll =+   map propSingle $+      Interpolation.constant :+      Interpolation.linear :+      Interpolation.cubic :+      []
+ src/Synthesizer/Plain/Filter/Delay/Block.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE NoImplicitPrelude #-}+{- |+Fast delay based on block lists.+Blocks are arrays. They are part of Haskell 98.+In contrast to ring buffers,+block lists allow infinite look ahead.+-}+module Synthesizer.Plain.Filter.Delay.Block where++import qualified Synthesizer.Plain.Interpolation as Interpolation+import qualified Synthesizer.Plain.Signal as Sig++import qualified Algebra.RealField as RealField+import qualified Algebra.Additive  as Additive++import Data.Array((!), Array, listArray, elems, bounds, indices, rangeSize)+import Data.List(tails)++import Test.QuickCheck ((==>), Property)++import qualified Prelude as P+import PreludeBase+import NumericPrelude+++modulatedCore :: (RealField.C a, Additive.C v) =>+   Interpolation.T a v -> Int -> Sig.T a -> Sig.T v -> Sig.T v+modulatedCore ip size ts =+   zipWith+      (\t (offset,bs) ->+          let (ti,tf) = splitFraction (-t)+          in  Interpolation.func ip tf (dropBlocksToList (size+offset+ti) bs))+      ts .+   suffixIndexes .+   {- Using 'size' for the block size is a heuristics,+      maybe it is not a good choice in many cases. -}+   listToBlocks size++modulated :: (RealField.C a, Additive.C v) =>+   Interpolation.T a v -> Int -> Sig.T a -> Sig.T v -> Sig.T v+modulated ip maxDelay ts xs =+   let size = maxDelay + Interpolation.number ip+   in  modulatedCore ip+          (size - Interpolation.offset ip)+          ts+          (replicate size zero ++ xs)+++type BlockList a = [Array Int a]+++listToBlocks :: Int -> Sig.T a -> BlockList a+listToBlocks blockSize =+   map (listArray (0,blockSize-1)) .+   takeWhile (not . null) .+   iterate (drop blockSize)+++dropBlocksToList :: Int -> BlockList a -> Sig.T a+dropBlocksToList number blocks =+   let dropUntil remain (b:bs) =+          if remain <= snd (bounds b)+            then (remain, b, bs)+            else dropUntil (remain - rangeSize (bounds b)) bs+       dropUntil remain [] = (remain, listArray (0,-1) [], [])+       (offset, lead, suffix) = dropUntil number blocks+   in  map (lead!) [offset .. (snd $ bounds lead)] +++       concatMap elems suffix++propDrop :: Int -> Int -> [Int] -> Property+propDrop size n xs =+   let infXs = cycle xs+       len = 1000+   in  size>0 && n>=0 && not (null xs) ==>+          take len (drop n infXs)  ==+          take len (dropBlocksToList n (listToBlocks size infXs))++{- |+Drop elements from a blocked list.+The offset must lie in the leading block.+-}+dropSingleBlocksToList :: Int -> BlockList a -> Sig.T a+dropSingleBlocksToList number (arr:arrs) =+   map (arr!) [number .. (snd $ bounds arr)] +++   concatMap elems arrs+dropSingleBlocksToList _ [] = []+++suffixIndexes :: BlockList a -> [(Int, BlockList a)]+suffixIndexes xs =+   do blockSuffix <- init $ tails xs+      i <- indices $ head blockSuffix+      return (i,blockSuffix)
+ src/Synthesizer/Plain/Filter/Delay/List.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE NoImplicitPrelude #-}+module Synthesizer.Plain.Filter.Delay.List where++import qualified Synthesizer.Plain.Interpolation as Interpolation++import qualified Algebra.RealField as RealField+import qualified Algebra.Additive  as Additive++import Data.List(tails)++import qualified Prelude as P+import PreludeBase+import NumericPrelude+++{- |+This function uses suffixes of the reversed signal.+This way small delays perform well+but the big drawback is that the garbage collector+can not deallocate old samples.+-}+modulatedRevCore :: (RealField.C a, Additive.C v) =>+   Interpolation.T a v -> Int -> [a] -> [v] -> [v]+modulatedRevCore ip size ts xs =+   zipWith+      (\t x ->+          let (ti,tf) = splitFraction t+          in  Interpolation.func ip tf (drop ti x))+      ts (drop size (scanl (flip (:)) [] xs))++modulatedRev :: (RealField.C a, Additive.C v) =>+   Interpolation.T a v -> Int -> [a] -> [v] -> [v]+modulatedRev ip maxDelay ts xs =+   let size = maxDelay + Interpolation.number ip+   in  modulatedRevCore ip+          (size + 1 + Interpolation.offset ip)+          ts+          (replicate size zero ++ xs)++++modulatedCore :: (RealField.C a, Additive.C v) =>+   Interpolation.T a v -> Int -> [a] -> [v] -> [v]+modulatedCore ip size ts xs =+   zipWith+      (\t x ->+          let (ti,tf) = splitFraction (-t)+          in  Interpolation.func ip tf (drop (size+ti) x))+      ts (tails xs)++{- |+This is essentially different for constant interpolation,+because this function "looks forward"+whereas the other two variants "look backward".+For the symmetric interpolation functions+of linear and cubic interpolation, this does not really matter.+-}+modulated :: (RealField.C a, Additive.C v) =>+   Interpolation.T a v -> Int -> [a] -> [v] -> [v]+modulated ip maxDelay ts xs =+   let size = maxDelay + Interpolation.number ip+   in  modulatedCore ip+          (size - Interpolation.offset ip)+          ts+          (replicate size zero ++ xs)
+ src/Synthesizer/Plain/Filter/Delay/ST.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE NoImplicitPrelude #-}+{- |+An implementation of a Delay using a classical circular buffer+running in the State Thread monad.+-}+module Synthesizer.Plain.Filter.Delay.ST where++import qualified Synthesizer.Plain.Interpolation as Interpolation++import qualified Algebra.RealField as RealField+import qualified Algebra.Additive  as Additive++import Control.Monad.ST.Lazy(runST,strictToLazyST,ST)+import Data.Array.ST++import qualified Prelude as P+import PreludeBase+import NumericPrelude+++{-+I had no success in hiding ST in the 'modulatedST' function.+The explicit type signature is crucial.+-}+modulatedAction :: (RealField.C a, Additive.C v) =>+   Interpolation.T a v -> Int -> [a] -> [v] -> ST s [v]+modulatedAction ip size ts xs =+   let ipNum  = Interpolation.number ip+       ipFunc = Interpolation.func   ip+   in  do arr <- strictToLazyST (newArray (0,2*size-1) zero)+                    :: Additive.C v => ST s (STArray s Int v)+          mapM (\(n,t,x) -> strictToLazyST $+                  do writeArray arr n x+                     writeArray arr (n+size) x+                     let (ti,tf) = splitFraction t+                     y <- mapM (readArray arr) (take ipNum [(n+ti) ..])+                     return (if ti<0+                               then error "negative delay"+                               else+                                 if size < ti+ipNum+                                   then error "too much delay"+                                   else ipFunc tf y))+               (zip3 (cycle [(size-1),(size-2)..0]) ts xs)++modulated :: (RealField.C a, Additive.C v) =>+   Interpolation.T a v -> Int -> [a] -> [v] -> [v]+modulated ip maxDelay ts xs =+   let offset = Interpolation.offset ip+   in  drop offset+          (runST+             (modulatedAction+                ip (maxDelay + Interpolation.number ip)+                (replicate offset zero ++ ts) xs))++
+ src/Synthesizer/Plain/Filter/LinearPredictive.hs view
@@ -0,0 +1,39 @@+module Synthesizer.Plain.Filter.LinearPredictive where++import qualified Algebra.Field    as Field+import qualified Algebra.Ring     as Ring+import qualified Algebra.Additive as Additive+import Synthesizer.Plain.Analysis (scalarProduct)++import qualified Data.List.Match as ListMatch+import qualified Data.List as List++import NumericPrelude+import PreludeBase+import Prelude ()+++{- |+Determine optimal filter coefficients and residue by adaptive approximation.+The number of initial filter coefficients is used as filter order.+-}+approxCoefficients :: Field.C a =>+   a -> [a] -> [a] -> [(a,[a])]+approxCoefficients k mask0 xs =+   let infixes = map (ListMatch.take mask0) (List.tails xs)+       targets = ListMatch.drop mask0 xs+   in  scanl+          (\(_,mask) (infx,target) ->+              let residue = target - scalarProduct mask infx+                  norm2 = scalarProduct infx infx+              in  (residue,+                   mask + map ((k*residue/norm2)*) infx))+          (zero,mask0) (zip infixes targets)+{-+mapM print $ take 20 $ drop 2000 $ approxCoefficients (1::Double) [0,0,0,0.1] (iterate (1+) 100)+++mapM print $ take 20 $ drop 10000 $ approxCoefficients (0.2::Double) [0.1,0] (map sin (iterate (0.03+) 0))++must yield coefficients [-1, 2*cos(0.03::Double)]+-}
+ src/Synthesizer/Plain/Filter/NonRecursive.hs view
@@ -0,0 +1,291 @@+{-# LANGUAGE NoImplicitPrelude #-}+{- |+Copyright   :  (c) Henning Thielemann 2006+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes+-}+module Synthesizer.Plain.Filter.NonRecursive where++import qualified Synthesizer.Plain.Control as Ctrl+import qualified Synthesizer.Plain.Signal  as Sig++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 qualified Algebra.Ring           as Ring+import qualified Algebra.Additive       as Additive++import Algebra.Module(linearComb, (*>))++import Data.Function.HT (nest, )+import Data.List (tails, )++-- import Control.Monad.Trans.State (StateT)+-- import Control.Monad.Trans.Writer (WriterT)++import PreludeBase+import NumericPrelude+++{- * Envelope application -}++amplify :: (Ring.C a) => a -> Sig.T a -> Sig.T a+amplify v = map (v*)++amplifyVector :: (Module.C a v) => a -> Sig.T v -> Sig.T v+amplifyVector = (*>)+++envelope :: (Ring.C a) =>+      Sig.T a  {-^ the envelope -}+   -> Sig.T a  {-^ the signal to be enveloped -}+   -> Sig.T a+envelope = zipWith (*)++envelopeVector :: (Module.C a v) =>+      Sig.T a  {-^ the envelope -}+   -> Sig.T v  {-^ the signal to be enveloped -}+   -> Sig.T v+envelopeVector = zipWith (*>)++++fadeInOut :: (Field.C a) => Int -> Int -> Int -> Sig.T a -> Sig.T a+fadeInOut tIn tHold tOut xs =+   let leadIn  = take tIn  $ Ctrl.linearMultiscale (  recip (fromIntegral tIn))  0+       leadOut = take tOut $ Ctrl.linearMultiscale (- recip (fromIntegral tOut)) 1+       (partIn, partHoldOut) = splitAt tIn xs+       (partHold, partOut) = splitAt tHold partHoldOut+   in  envelope leadIn partIn +++       partHold +++       envelope leadOut partOut+++fadeInOutAlt :: (Field.C a) => Int -> Int -> Int -> Sig.T a -> Sig.T a+fadeInOutAlt tIn tHold tOut =+   zipWith id+      ((map (\x y -> y * fromIntegral x / fromIntegral tIn) [0..tIn-1]) +++       (replicate tHold id) +++       (map (\x y -> y * fromIntegral x / fromIntegral tOut) [tOut-1,tOut-2..0]))++++{- * Shift -}++delay :: Additive.C y => Int -> Sig.T y -> Sig.T y+delay = delayPad zero++delayPad :: y -> Int -> Sig.T y -> Sig.T y+delayPad z n =+   if n<0+     then drop (negate n)+     else (replicate n z ++)+++{- * Smoothing -}+++{-| Unmodulated non-recursive filter -}+generic :: Module.C a v =>+   Sig.T a -> Sig.T v -> Sig.T v+generic m x =+   let mr = reverse m+       xp = delay (pred (length m)) x+   in  map (linearComb mr) (init (tails xp))++{-|+Unmodulated non-recursive filter+Output has same length as the input.++It is elegant but leaks memory.+ -}+genericAlt :: Module.C a v =>+   Sig.T a -> Sig.T v -> Sig.T v+genericAlt m x =+   map (linearComb m)+      (tail (scanl (flip (:)) [] x))+++propGeneric :: (Module.C a v, Eq v) =>+   Sig.T a -> Sig.T v -> Bool+propGeneric m x =+--   generic m x == genericAlt m x+   and $ zipWith (==) (generic m x) (genericAlt m x)++++{- |+@eps@ is the threshold relatively to the maximum.+That is, if the gaussian falls below @eps * gaussian 0@,+then the function truncated.+-}+gaussian :: (Trans.C a, RealField.C a, Module.C a v) => a -> a -> a -> Sig.T v -> Sig.T v+gaussian eps ratio freq =+   let var    = ratioFreqToVariance ratio freq+       area   = var * sqrt (2*pi)+       gau t  = exp (-(t/var)^2/2) / area+       width  = ceiling (var * sqrt (-2 * log eps))  -- inverse gau+       gauSmp = map (gau . fromIntegral) [-width .. width]+   in  drop width . generic gauSmp++{-+GNUPlot.plotList [] (take 1000 $ gaussian 0.001 0.5 0.04 (Filter.Test.chirp 5000) :: [Double])++The filtered chirp must have amplitude 0.5 at 400 (0.04*10000).+-}++{-+  We want to approximate a Gaussian by a binomial filter.+  The latter one can be implemented by a convolutional power.+  However we still require a number of operations per sample+  which is proportional to the variance.+-}+binomial :: (Trans.C a, RealField.C a, Module.C a v) => a -> a -> Sig.T v -> Sig.T v+binomial ratio freq =+   let width = ceiling (2 * ratioFreqToVariance ratio freq ^ 2)+   in  drop width . nest (2*width) ((asTypeOf 0.5 freq *>) . binomial1)++{-+exp (-(t/var)^2/2) / area *> cis (2*pi*f*t)+  == exp (-(t/var)^2/2 +: 2*pi*f*t) / area+  == exp ((-t^2 +: 2*var^2*2*pi*f*t) / (2*var^2)) / area+  == exp ((t^2 - i*2*var^2*2*pi*f*t) / (-2*var^2)) / area+  == exp (((t^2 - i*var^2*2*pi*f)^2 + (var^2*2*pi*f)^2) / (-2*var^2)) / area+  == exp (((t^2 - i*var^2*2*pi*f)^2 / (-2*var^2) - (var*2*pi*f)^2/2)) / area++sumMap (\t -> exp (-(t/var)^2/2) / area *> cis (2*pi*f*t))+       [-infinity..infinity]+  ~ sumMap (\t -> exp (-(t/var)^2/2)) [-infinity..infinity]+       * exp (-(var*2*pi*f)^2/2) / area+  = exp (-(var*2*pi*f)^2/2)+-}+{- |+  Compute the variance of the Gaussian+  such that its Fourier transform has value @ratio@ at frequency @freq@.+-}+ratioFreqToVariance :: (Trans.C a) => a -> a -> a+ratioFreqToVariance ratio freq =+   sqrt (-2 * log ratio) / (2*pi*freq)+           -- inverse of the fourier transformed gaussian++binomial1 :: (Additive.C v) => Sig.T v -> Sig.T v+binomial1 xt@(x:xs) = x : (xs + xt)+binomial1 [] = []+++++++{- |+Moving (uniformly weighted) average in the most trivial form.+This is very slow and needs about @n * length x@ operations.+-}+sums :: (Additive.C v) => Int -> Sig.T v -> Sig.T v+sums n = map (sum . take n) . init . tails++++sumsDownsample2 :: (Additive.C v) => Sig.T v -> Sig.T v+sumsDownsample2 (x0:x1:xs) = (x0+x1) : sumsDownsample2 xs+sumsDownsample2 xs         = xs++downsample2 :: Sig.T a -> Sig.T a+downsample2 (x0:_:xs) = x0 : downsample2 xs+downsample2 xs        = xs+++{- |+Given a list of numbers+and a list of sums of (2*k) of successive summands,+compute a list of the sums of (2*k+1) or (2*k+2) summands.++Eample for 2*k+1++@+ [0+1+2+3, 2+3+4+5, 4+5+6+7, ...] ->+    [0+1+2+3+4, 1+2+3+4+5, 2+3+4+5+6, 3+4+5+6+7, 4+5+6+7+8, ...]+@++Example for 2*k+2++@+ [0+1+2+3, 2+3+4+5, 4+5+6+7, ...] ->+    [0+1+2+3+4+5, 1+2+3+4+5+6, 2+3+4+5+6+7, 3+4+5+6+7+8, 4+5+6+7+8+9, ...]+@+-}+sumsUpsampleOdd :: (Additive.C v) => Int -> Sig.T v -> Sig.T v -> Sig.T v+sumsUpsampleOdd n {- 2*k -} xs ss =+   let xs2k = drop n xs+   in  (head ss + head xs2k) :+          concat (zipWith3 (\s x0 x2k -> [x0+s, s+x2k])+                           (tail ss)+                           (downsample2 (tail xs))+                           (tail (downsample2 xs2k)))++sumsUpsampleEven :: (Additive.C v) => Int -> Sig.T v -> Sig.T v -> Sig.T v+sumsUpsampleEven n {- 2*k -} xs ss =+   sumsUpsampleOdd (n+1) xs (zipWith (+) ss (downsample2 (drop n xs)))++sumsPyramid :: (Additive.C v) => Int -> Sig.T v -> Sig.T v+sumsPyramid =+   let aux 1 ys = ys+       aux 2 ys = ys + tail ys  -- binomial1+       aux m ys =+          let ysd = sumsDownsample2 ys+          in  if even m+                then sumsUpsampleEven (m-2) ys (aux (div (m-2) 2) ysd)+                else sumsUpsampleOdd  (m-1) ys (aux (div (m-1) 2) ysd)+   in  aux+++{-+*Synthesizer.Plain.Filter.NonRecursive> movingAverageModulated 10 (replicate 10 (3::Double) ++ [1.1,2.2,2.6,0.7,0.1,0.1]) (repeat (1::Double))+[0.5,0.6666666666666666,0.8333333333333333,1.0,1.0,1.0,1.0,1.0,1.0,1.0,0.9999999999999999,1.0,0.9999999999999998,0.999999999999999,0.9999999999999942,0.9999999999999942]+-}+++{- * Filter operators from calculus -}++{- |+Forward difference quotient.+Shortens the signal by one.+Inverts 'Synthesizer.Plain.Filter.Recursive.Integration.run' in the sense that+@differentiate (zero : integrate x) == x@.+The signal is shifted by a half time unit.+-}+differentiate :: Additive.C v => Sig.T v -> Sig.T v+differentiate x = zipWith subtract x (tail x)++{- |+Central difference quotient.+Shortens the signal by two elements,+and shifts the signal by one element.+(Which can be fixed by prepending an appropriate value.)+For linear functions this will yield+essentially the same result as 'differentiate'.+You obtain the result of 'differentiateCenter'+if you smooth the one of 'differentiate'+by averaging pairs of adjacent values.++ToDo: Vector variant+-}+differentiateCenter :: Field.C v => Sig.T v -> Sig.T v+differentiateCenter x =+   map ((1/2)*) $+   zipWith subtract x (tail (tail x))++{- |+Second derivative.+It is @differentiate2 == differentiate . differentiate@+but 'differentiate2' should be faster.+-}+differentiate2 :: Additive.C v => Sig.T v -> Sig.T v+differentiate2 xs0 =+   let xs1 = tail xs0+       xs2 = tail xs1+   in  zipWith3 (\x0 x1 x2 -> x0+x2-(x1+x1)) xs0 xs1 xs2
+ src/Synthesizer/Plain/Filter/Recursive.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{- |+Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes+-}+module Synthesizer.Plain.Filter.Recursive where++import qualified Algebra.Module                as Module+-- import qualified Algebra.Transcendental        as Trans+-- import qualified Algebra.Field                 as Field+-- import qualified Algebra.Ring                  as Ring+import qualified Algebra.Additive              as Additive++import Algebra.Additive((+), (-), negate, )+import Algebra.Module((*>))++import qualified Prelude as P+import PreludeBase+import NumericPrelude+++{- * Various Filters -}+++{- ** Recursive filters with resonance -}++{-| Description of a filter pole. -}+data Pole a =+    Pole {poleResonance :: !a  {- ^ Resonance, that is the amplification of the band center frequency. -}+        , poleFrequency :: !a  {- ^ Band center frequency. -} }+    deriving (Eq, Show, Read)++instance Additive.C v => Additive.C (Pole v) where+   zero = Pole zero zero+   (+) (Pole yr yf) (Pole xr xf) = Pole (yr + xr) (yf + xf)+   (-) (Pole yr yf) (Pole xr xf) = Pole (yr - xr) (yf - xf)+   negate           (Pole xr xf) = Pole (negate xr) (negate xf)++{-+An instance for Module.C of the Pole datatype+makes no sense in most cases,+but when it comes to interpolation+this is very handy.+-}+instance Module.C a v => Module.C a (Pole v) where+   s *> (Pole xr xf) = Pole (s *> xr) (s *> xf)+++data Passband = Lowpass | Highpass+       deriving (Show, Eq, Enum)
+ src/Synthesizer/Plain/Filter/Recursive/Allpass.hs view
@@ -0,0 +1,202 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{- |+Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes+-}+module Synthesizer.Plain.Filter.Recursive.Allpass where++import qualified Synthesizer.Plain.Signal   as Sig+import qualified Synthesizer.Plain.Modifier as Modifier+import qualified Synthesizer.Causal.Process as Causal+import qualified Synthesizer.Interpolation.Class as Interpol++import qualified Algebra.Module                as Module+import qualified Algebra.RealTranscendental    as RealTrans+import qualified Algebra.Transcendental        as Trans+import qualified Algebra.Field                 as Field+import qualified Algebra.Ring                  as Ring+import qualified Algebra.Additive              as Additive++import Algebra.Module((*>))++import Number.Complex ((+:))+import qualified Number.Complex as Complex+import Data.Tuple.HT (mapSnd, )+import Data.Function.HT (nest, )++import Control.Monad.Trans.State (State, state, runState, evalState, )++import qualified Prelude as P+import PreludeBase+import NumericPrelude++++newtype Parameter a =+   Parameter {getParameter :: a}  {- ^ Feedback factor. -}+   deriving Show+++instance Interpol.C a v => Interpol.C a (Parameter v) where+   {-# INLINE scaleAndAccumulate #-}+   scaleAndAccumulate = Interpol.makeMac Parameter getParameter+++{-+Shall the phase parameter be of type Phase?+I think no, because for the allpass cascade we divide by the order+and then there is a difference between phase pi and 3*pi.+-}+{-# INLINE parameter #-}+parameter :: Trans.C a =>+     Int  {- ^ The number of equally designed 1st order allpasses. -}+  -> a    {- ^ The phase shift to be achieved for the given frequency. -}+  -> a    {- ^ The frequency we specified the phase shift for. -}+  -> Parameter a+parameter order phase frequency =+    let orderFloat = fromIntegral order+        omega = frequency * 2 * pi+        phi = phase / orderFloat+        k = (cos phi - cos omega) / (1 - cos (phi - omega))+    in  Parameter k++{-# INLINE flangerPhase #-}+flangerPhase :: Trans.C a => a+flangerPhase = -2*pi++{-# INLINE flangerParameter #-}+flangerParameter :: Trans.C a => Int -> a -> Parameter a+flangerParameter order frequency =+   parameter order flangerPhase frequency++{-# INLINE firstOrderStep #-}+firstOrderStep :: (Ring.C a, Module.C a v) =>+   Parameter a -> v -> State (v,v) v+firstOrderStep (Parameter k) u0 =+   state (\(u1,y1) -> let y0 = u1 + k *> (u0-y1) in (y0,(u0,y0)))++{-# INLINE firstOrderModifier #-}+firstOrderModifier :: (Ring.C a, Module.C a v) =>+   Modifier.Simple (v,v) (Parameter a) v v+firstOrderModifier =+   Modifier.Simple (zero,zero) firstOrderStep++{-# INLINE firstOrderCausal #-}+firstOrderCausal :: (Ring.C a, Module.C a v) =>+   Causal.T (Parameter a, v) v+firstOrderCausal =+   Causal.fromSimpleModifier firstOrderModifier++{-# INLINE firstOrder #-}+firstOrder :: (Ring.C a, Module.C a v) =>+   Sig.T (Parameter a) -> Sig.T v -> Sig.T v+firstOrder = Sig.modifyModulated firstOrderModifier+++{-# INLINE makePhase #-}+makePhase :: RealTrans.C a => Parameter a -> a -> a+makePhase (Parameter k) frequency =+    let omega = 2*pi * frequency+    in  2 * Complex.phase ((k+cos omega)+:(- sin omega)) + omega++{-+internal storage is not very efficient+because the second value of one pair is equal+to the first value of the subsequent value+-}+{-# INLINE cascadeStepStackPairs #-}+cascadeStepStackPairs :: (Ring.C a, Module.C a v) =>+   Parameter a -> v -> State [(v,v)] v+cascadeStepStackPairs k =+   -- stackStatesR would work as well, but with reversed list of states+   Modifier.stackStatesL (firstOrderStep k)++{-# INLINE cascadeStepStack #-}+cascadeStepStack :: (Ring.C a, Module.C a v) =>+   Parameter a -> v -> State [v] v+cascadeStepStack k x =+   state $+      mapSnd fromPairs .+      runState (cascadeStepStackPairs k x) .+      toPairs++{-# INLINE fromPairs #-}+fromPairs :: [(a,a)] -> [a]+fromPairs xs@(x:_) = fst x : map snd xs+fromPairs [] = error "Allpass.fromPairs: empty list"++{-# INLINE toPairs #-}+toPairs :: [a] -> [(a,a)]+toPairs xs = zip xs (tail xs)++{-# INLINE cascadeStep #-}+{-# INLINE cascadeStepRec #-}+{-# INLINE cascadeStepRecAlt #-}+cascadeStep, cascadeStepRec, cascadeStepRecAlt ::+   (Ring.C a, Module.C a v) =>+   Parameter a -> v -> State [v] v++cascadeStep = cascadeStepRec++cascadeStepRec (Parameter k) x = state $ \s ->+    let crawl _ [] = error "Allpass.crawl needs at least one element in the list"+        crawl u0 (_:[]) = u0:[]+        crawl u0 (u1:y1:us) =+            let y0 = u1 + k *> (u0-y1)+            in  u0 : crawl y0 (y1:us)+        news = crawl x s+    in  (last news, news)++cascadeStepRecAlt k x = state $ \s ->+    let crawl _ [] = error "Allpass.crawl needs at least one element in the list"+        crawl u0 (u1:u1s) = mapSnd (u0:) $+           case u1s of+              [] -> (u0,[])+              (y1:_) ->+                 crawl (evalState (firstOrderStep k u0) (u1,y1)) u1s+    in  crawl x s++{-# INLINE cascadeModifier #-}+cascadeModifier :: (Ring.C a, Module.C a v) =>+   Int -> Modifier.Simple [v] (Parameter a) v v+cascadeModifier order =+   Modifier.Simple (replicate (succ order) zero) cascadeStep++{-# INLINE cascadeCausal #-}+{-# INLINE cascadeCausalStacked #-}+{-# INLINE cascadeCausalModifier #-}+cascadeCausal, cascadeCausalStacked, cascadeCausalModifier ::+   (Ring.C a, Module.C a v) =>+   Int -> Causal.T (Parameter a, v) v+cascadeCausal = cascadeCausalModifier++cascadeCausalStacked order =+   Causal.replicateControlled order firstOrderCausal++cascadeCausalModifier order =+   Causal.fromSimpleModifier (cascadeModifier order)+++{-# INLINE cascade #-}+{-# INLINE cascadeState #-}+{-# INLINE cascadeIterative #-}+cascade, cascadeState, cascadeIterative ::+   (Ring.C a, Module.C a v) =>+   Int -> Sig.T (Parameter a) -> Sig.T v -> Sig.T v++{-| Choose one of the implementations below -}+cascade = cascadeState++{-| Simulate the Allpass cascade by a list of states of the partial allpasses -}+cascadeState order =+   Sig.modifyModulated (cascadeModifier order)++{-| Directly implement the allpass cascade as multiple application of allpasses of 1st order -}+cascadeIterative order c =+   nest order (firstOrder c)
+ src/Synthesizer/Plain/Filter/Recursive/AllpassPoly.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{- |+Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes+-}+module Synthesizer.Plain.Filter.Recursive.AllpassPoly where++-- import qualified Synthesizer.Plain.Signal   as Sig+-- import qualified Synthesizer.Plain.Modifier as Modifier++import qualified Algebra.Module                as Module+import qualified Algebra.RealTranscendental    as RealTrans+import qualified Algebra.Transcendental        as Trans+import qualified Algebra.Field                 as Field+import qualified Algebra.Ring                  as Ring+import qualified Algebra.Additive              as Additive++import Algebra.Module((*>))++import Number.Complex (cis,(+:),real,imag)+import qualified Number.Complex as Complex+import Orthogonals(Scalar,one_ket_solution)++import qualified Prelude as P+import PreludeBase+import NumericPrelude++++newtype Parameter a = Parameter [a]+   deriving Show++{- | Compute coefficients for an allpass that shifts low frequencies+     by approximately the shift you want.+     To achieve this we solve a linear least squares problem,+     where low frequencies are more weighted than high ones.+     The output is a list of coefficients for an arbitrary order allpass. -}+shiftParam :: (Scalar a, P.Fractional a, Trans.C a) =>+   Int -> a -> a -> Parameter a+shiftParam order weight phase =+    let {- construct matrix for normal equations -}+        normalVector = map negate+           (map (scalarProdScrewExp weight order phase 0) [1..order])+        normalMatrix = map (\j ->+            map (scalarProdScrewExp weight order phase j) [1..order]) [1..order]+    in  Parameter (one_ket_solution normalMatrix normalVector)++{-+  GNUPlot.plotFunc (GNUPlot.linearScale 500 (0,1)) ((fwrap (-pi,pi)).(makePhase (shiftParam 6 (-6) (-pi/2::Double))))+-}+makePhase :: RealTrans.C a => Parameter a -> a -> a+makePhase (Parameter ks) frequency =+    let omega  = 2*pi * frequency+        omegas = iterate (omega+) omega+        denom = 1+sum (zipWith (\k w -> k*cos w +: k*sin w) ks omegas)+    in  2 * Complex.phase denom - omega*(fromIntegral (length ks))++{- integrate (0,2*pi) (\omega -> exp (r*omega) * screwProd order phase k j omega) -}+scalarProdScrewExp :: Trans.C a => a -> Int -> a -> Int -> Int -> a+scalarProdScrewExp r order phase k j =+    let (intCos,intSin) = integrateScrewExp r (k+j-order)+    in  2 * (fst (integrateScrewExp r (k-j)) -+              (cos phase * intCos + sin phase * intSin))++screwProd :: Trans.C a => Int -> a -> Int -> Int -> a -> a+screwProd order phase k j omega =+    let z0 = cis (fromIntegral k * omega) -+                       cis phase * cis (fromIntegral (order-k) * omega)+        z1 = cis (fromIntegral j * omega) -+                       cis phase * cis (fromIntegral (order-j) * omega)+    in  real z0 * real z1 + imag z0 * imag z1++{- integrate (0,2*pi) (\omega -> (exp (r*omega) +: 0) * cis (k*omega)) -}+integrateScrewExp :: Trans.C a => a -> Int -> (a,a)+integrateScrewExp r kInt =+    let k = fromIntegral kInt+        q = (exp (2*pi*r) - 1) / (r^2 + k^2)+    in  (r*q, -k*q)++{- Should be moved to NumericPrelude -}+integrateNum :: (Field.C a, Module.C a v) => Int -> (a,a) -> (a->v) -> v+integrateNum n (lo,hi) f =+    let xs = map (\k -> lo + (hi-lo) * fromIntegral k / fromIntegral n)+                 [1..(n-1)]+    in  ((hi-lo) / fromIntegral n) *>+        (foldl (+) ((1/2 `asTypeOf` lo) *> (f lo + f hi))+               (map f xs))
+ src/Synthesizer/Plain/Filter/Recursive/Butterworth.hs view
@@ -0,0 +1,192 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{- |+Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes++Butterworth lowpass and highpass+-}+module Synthesizer.Plain.Filter.Recursive.Butterworth where++import Synthesizer.Plain.Filter.Recursive (Passband(Lowpass,Highpass), Pole(Pole))+import qualified Synthesizer.Plain.Filter.Recursive.SecondOrderCascade as Cascade+import qualified Synthesizer.Plain.Filter.Recursive.SecondOrder as Filt2+-- import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder  as Filt1+import qualified Synthesizer.Plain.Signal   as Sig+import qualified Synthesizer.Plain.Modifier as Modifier+import qualified Synthesizer.Causal.Process as Causal+import Control.Arrow ((>>>), )++import qualified Algebra.Module                as Module+import qualified Algebra.Transcendental        as Trans+import qualified Algebra.Field                 as Field+import qualified Algebra.Ring                  as Ring+import qualified Algebra.Additive              as Additive++import qualified Data.StorableVector as SV+import Foreign.Storable (Storable)++import qualified Prelude as P+import PreludeBase+import NumericPrelude++++sineList, sineListSlow, sineListFast :: (Trans.C a) => a -> [a]+sineList = sineListFast++sineListSlow x =+   map sin $ map (x*) $ iterate (2+) 1++sineListFast x =+   let sinx  = sin x+       cos2x = 2 - 4*sinx*sinx+       --cos2x = 2 * cos (2*x)+       sines = (-sinx) : sinx :+                  zipWith (\y1 y0 -> cos2x * y0 - y1) sines (tail sines)+   in  tail sines++makeSines :: (Trans.C a) =>+   Int -> [a]+makeSines order =+   take (checkedHalf "makeSines" order) (sineList (pi / fromIntegral (2*order)))++partialRatio :: (Trans.C a) =>+   Int -> a -> a+partialRatio order ratio =+   (1/ratio^2-1) ** (-1 / fromIntegral (2*order))++++partialParameterInstable, partialParameter :: (Trans.C a) =>+   a -> a -> a -> Filt2.Parameter a++{- must handle infinite values when 'freq' approaches 0.5 -}+partialParameterInstable ratio freq sinw =+   let wc    = ratio * tan (pi*freq)+       sinw2 = 2 * wc * sinw+       wc2   = wc * wc+       denom = wc2 + sinw2 + 1+       c0    = wc2 / denom+   in  Filt2.Parameter c0 (2*c0) c0+          (2*(1-wc2)/denom) ((-wc2+sinw2-1)/denom)++-- using ratio disallows simplification by trigonometric Pythagoras' theorem+partialParameter ratio freq =+   let phi      = pi*freq+       rsin2phi = ratio * sin (2*phi)+       cosphi2  = cos phi ^ 2+       c0d      = (ratio * sin phi) ^ 2+       d1d      = (cosphi2 - c0d) * 2+       ratsin   = cosphi2 + c0d+   in  \sinw ->+          let rsinsin = rsin2phi * sinw+              denom   = rsinsin + ratsin+              d2d     = rsinsin - ratsin+              c0      = c0d / denom+              d1      = d1d / denom+              d2      = d2d / denom+          in  Filt2.Parameter c0 (2*c0) c0 d1 d2+++-- * use second order filter parameters for control++type Parameter a = Cascade.Parameter a++{-# INLINE parameter #-}+parameter ::+   (Trans.C a, Storable a) =>+   Passband -> Int -> Pole a -> Parameter a+parameter kind order =+   -- I hope that the 'let' is floated out of a 'map'+   let sinesVec = SV.pack (makeSines order)+   in  \ (Pole ratio freq) ->+           Cascade.Parameter $+           SV.map (\sinw ->+              Filt2.adjustPassband kind+                 (flip (partialParameter (partialRatio order ratio)) sinw) freq) $+           sinesVec++{-# INLINE modifier #-}+modifier ::+   (Ring.C a, Module.C a v, Storable a, Storable v) =>+   Int ->+   Modifier.Simple (Cascade.Status v) (Parameter a) v v+modifier =+   Cascade.modifier++{-# INLINE causal #-}+causal :: (Ring.C a, Module.C a v, Storable a, Storable v) =>+   Int ->+   Causal.T (Parameter a, v) v+causal order =+   Cascade.causal (checkedHalf "causal" order)+++{-# INLINE checkedHalf #-}+checkedHalf :: String -> Int -> Int+checkedHalf funcName order =+   let (order2,r) = divMod order 2+   in  if r==0+         then order2+         else error $ "Butterworth."++funcName++": order must be even"++{-+lowpassCausal, highpassCausal :: (Trans.C a, Module.C a v) =>+   Int -> Causal.T (Parameter a, v) v+lowpassCausal  = causal Lowpass+highpassCausal = causal Highpass++lowpass, highpass :: (Trans.C a, Module.C a v) =>+   Int -> Sig.T (Parameter a) -> Sig.T v -> Sig.T v+lowpass  = run Lowpass+highpass = run Highpass+-}+++-- * directly use frequency as control parameter++{- |+When called as @runPole kind order ratio freqs@,+the filter amplifies frequency 0 with factor 1+and frequency @freq@ with factor @ratio@.++It uses the frequency and ratio information directly+and thus cannot benefit from efficient parameter interpolation+(asynchronous run of a ControlledProcess.+-}+runPole :: (Trans.C a, Module.C a v) =>+   Passband -> Int -> Sig.T a -> Sig.T a -> Sig.T v -> Sig.T v+runPole kind order ratios freqs =+   let makePartialFilter s =+          Filt2.run (zipWith (\ratio ->+             Filt2.adjustPassband kind $ \freq ->+                partialParameter (partialRatio order ratio) freq s) ratios freqs)+   in  foldl (.) id (map makePartialFilter (makeSines order))++causalPole :: (Trans.C a, Module.C a v) =>+   Passband -> Int -> Causal.T (Pole a, v) v+causalPole kind order =+   let {-# INLINE makePartialFilter #-}+       makePartialFilter s =+          Causal.first (Causal.map (\(Pole ratio freq) ->+             Filt2.adjustPassband kind+                (flip (partialParameter (partialRatio order ratio)) s) freq)) >>>+          Filt2.causal+   in  Causal.chainControlled $ map makePartialFilter $ makeSines order+++lowpassCausalPole, highpassCausalPole :: (Trans.C a, Module.C a v) =>+   Int -> Causal.T (Pole a, v) v+lowpassCausalPole  = causalPole Lowpass+highpassCausalPole = causalPole Highpass++lowpassPole, highpassPole :: (Trans.C a, Module.C a v) =>+   Int -> Sig.T a -> Sig.T a -> Sig.T v -> Sig.T v+lowpassPole  = runPole Lowpass+highpassPole = runPole Highpass
+ src/Synthesizer/Plain/Filter/Recursive/Chebyshev.hs view
@@ -0,0 +1,385 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{- |+Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes++Chebyshev lowpass and highpass+-}+module Synthesizer.Plain.Filter.Recursive.Chebyshev where++import Synthesizer.Plain.Filter.Recursive (Passband(Lowpass,Highpass), Pole(Pole, poleResonance))+import qualified Synthesizer.Plain.Filter.Recursive.SecondOrderCascade as Cascade+import qualified Synthesizer.Plain.Filter.Recursive.SecondOrder as Filt2+-- import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder  as Filt1+import qualified Synthesizer.Plain.Signal   as Sig+-- import qualified Synthesizer.Plain.Modifier as Modifier+import qualified Synthesizer.Causal.Process as Causal+import Control.Arrow ((>>>), (^>>), (&&&), )++-- import qualified Algebra.VectorSpace           as VectorSpace+import qualified Algebra.Module                as Module+import qualified Algebra.Transcendental        as Trans+import qualified Algebra.Field                 as Field+import qualified Algebra.Ring                  as Ring+import qualified Algebra.Additive              as Additive++import Algebra.Module((*>))++import Number.Complex (real, imag, cis, )+import qualified Number.Complex as Complex++-- import Control.Monad.Trans.State (State(..), evalState)++import qualified Data.StorableVector as SV+import Foreign.Storable (Storable)++import qualified Prelude as P+import PreludeBase+import NumericPrelude+++++circleList, circleListSlow, circleListFast :: (Trans.C a) => a -> [Complex.T a]+circleList = circleListSlow++circleListSlow x =+   map cis $ map (x*) $ iterate (2+) 1++circleListFast x =+   let z1 = cis x+       z2 = z1^2+   in  iterate (z2*) z1+++makeCirclePoints :: (Trans.C a) => Int -> [Complex.T a]+makeCirclePoints order =+   take order (circleList (pi / (4 * fromIntegral order)))++-- | compute the partial filter of the second order from the pole information+{-+It's worth to think it over whether this routine could be used for the Butterworth filter.+But whereas this function is specialized to the zeros of the denominator polynomial+for the Butterworth filter the quadratic factors of the polynomial can be determined+more efficiently than the zeros.+-}+partialParameterA, partialParameterB :: (Trans.C a) =>+   Int -> a -> a -> Complex.T a -> Filt2.Parameter a+{-+partialParameterA order ratio freq =+   let {- if ratio == (sqrt 2) then the product of the normalization factors is+          2^(1-2*order) -}+--       bn = asinh (ratio/sqrt(1-ratio^2)) / fromIntegral (2*order)+       bn = (log(1+ratio) - log(1-ratio^2)/2) / fromIntegral (2*order)+       coshbn = cosh bn+       sinhbn = sinh bn++       phi     = pi*freq+       sinphi  = sin phi+       cosphi  = cos phi+       sinphi2 = sinphi^2++   in  \c ->+          let re      =   real c * coshbn; re2 = re^2+              im      = - imag c * sinhbn; im2 = im^2+              cpims   = cosphi + im*sinphi+              cmims   = cosphi - im*sinphi+              resin2  = re2*sinphi2+              denom   = - cmims^2 - resin2+              vol     = sqrt ((1-re2-im2)^2 + 4*im2)+              c0      = vol * sinphi2 / denom+          in  Filt2.Parameter+                 c0 (2*c0) c0+                 (-2*(cpims*cmims - resin2)/denom) ((cpims^2 + resin2)/denom)+-}++partialParameterA order ratio freq =+   let {- if ratio == (sqrt 2) then the product of the normalization factors is+          2^(1-2*order) -}+--       bn = asinh (ratio/sqrt(1-ratio^2)) / fromIntegral (2*order)+       bn = (log(1+ratio) - log(1-ratio^2)/2) / fromIntegral (2*order)+       coshbn = cosh bn+       sinhbn = sinh bn+--       cosh2bn = (cosh(2*bn)-1)/2 = sinhbn2+       coshbn2 = coshbn^2+       sinhbn2 = sinhbn^2++       phi     = pi*freq+       sinphi  = sin phi+       cosphi  = cos phi+       sinphi2 = sinphi^2++       sinhbnsinphi   = sinhbn*sinphi+--       sinhbn2sinphi2 = sinhbn2*sinphi2+       coshbn2sinphi2 = coshbn2*sinphi2++   in  \c ->+          let re      = real c+              im      = imag c+              imss    = im * sinhbnsinphi+              cpims   = cosphi - imss+              cmims   = cosphi + imss+              resin2  = re^2 * coshbn2sinphi2+              denom   = - cmims^2 - resin2+              c0      = (im^2 + sinhbn2)*sinphi2 / denom+          in  Filt2.Parameter+                 c0 (2*c0) c0+                 (-2*(cpims*cmims - resin2)/denom) ((cpims^2 + resin2)/denom)++{-+partialParameterA order ratio freq =+   let {- if ratio == (sqrt 2) then the product of the normalization factors is+          2^(1-2*order) -}+       bn = asinh (ratio/sqrt(1-ratio^2)) / fromIntegral (2*order)+       sinhbnd = 2 * sinh bn+       cosh2bn = (cosh(2*bn)-1)/2++       phi       = pi*freq+       sinphi    = sin phi+       cosphi    = cos phi+       sinphi2   = sinphi^2+--       cosphi2   = cosphi^2+       sincosphi = sinphi*cosphi++   in  \c ->+          let imd     = - imag c * sinhbnd+              re2pim2 = cosh2bn + real c ^ 2+              ri2sp2  = (re2pim2-1)*sinphi2+              cpims2  = 1 + ri2sp2 + imd*sincosphi+              cmims2  = 1 + ri2sp2 - imd*sincosphi+              cpmims  = 1 - (re2pim2+1)*sinphi2+              denom   = - cmims2+              vol     = sqrt (ri2sp2^2 + (imd*sinphi2)^2)+              c0      = vol / denom+          in  Filt2.Parameter+                 c0 (2*c0) c0+                 (-2*cpmims/denom) (cpims2/denom)+-}++{-+partialParameterA order ratio freq =+   let {- if ratio == (sqrt 2) then the product of the normalization factors is+          2^(1-2*order) -}+       bn = asinh (ratio/sqrt(1-ratio^2)) / fromIntegral (2*order)+       coshbn = cosh bn+       sinhbn = sinh bn++       phi       = pi*freq+       sinphi    = sin phi+       cosphi    = cos phi+       sinphi2   = sinphi^2+--       cosphi2   = cosphi^2+       sincosphi = sinphi*cosphi++   in  \c ->+          let re      =   real c * coshbn; re2 = re^2+              im      = - imag c * sinhbn; im2 = im^2+              re2pim2 = re2+im2+              cpims2  = 1 + (re2pim2-1)*sinphi2 + 2*im*sincosphi+              cmims2  = 1 + (re2pim2-1)*sinphi2 - 2*im*sincosphi+              cpmims  = 1 - (re2pim2+1)*sinphi2+              denom   = - cmims2+              vol     = sqrt ((re2pim2-1)^2 + 4*im2)+              c0      = vol * sinphi2 / denom+          in  Filt2.Parameter+                 c0 (2*c0) c0+                 (-2*cpmims/denom) (cpims2/denom)+-}++{-+partialParameterB order ratio freq =+   let -- bn = asinh (sqrt(1-ratio^2)/ratio) / fromIntegral (2*order)+       bn = (log(1+sqrt(1-ratio^2)) - log ratio) / fromIntegral (2*order)+       coshbn  = cosh bn+       sinhbn  = sinh bn+       coshbn2 = coshbn^2++       phi     = pi*freq+       sinphi  = sin phi+       cosphi  = cos phi+       sinphi2 = sinphi^2+       cosphi2 = cosphi^2++   in  \c ->+          let re      =   real c * coshbn+              im      = - imag c * sinhbn+              spimc   = sinphi + im*cosphi+              smimc   = sinphi - im*cosphi+              recos2  = re^2 * cosphi2+              denom   = smimc^2 + recos2+              a02cosphi2 = real c ^ 2 * cosphi2+              c0      = (sinphi2 + a02cosphi2) / denom+              c1      = (sinphi2 - a02cosphi2) / denom+          in  Filt2.Parameter+                 c0 (2*c1) c0+                 (-2*(spimc*smimc - recos2)/denom) (-(spimc^2 + recos2)/denom)+-}++partialParameterB order ratio freq =+   let -- bn = asinh (sqrt(1-ratio^2)/ratio) / fromIntegral (2*order)+       bn = (log(1+sqrt(1-ratio^2)) - log ratio) / fromIntegral (2*order)+       coshbn  = cosh bn+       sinhbn  = sinh bn+       coshbn2 = coshbn^2++       phi     = pi*freq+       sinphi  = sin phi+       cosphi  = cos phi+       sinphi2 = sinphi^2+       cosphi2 = cosphi^2++       sinhbncosphi = sinhbn*cosphi++   in  \c ->+          let a02cosphi2 = real c ^ 2 * cosphi2+              imsc    = imag c * sinhbncosphi+              spimc   = sinphi - imsc+              smimc   = sinphi + imsc+              recos2  = a02cosphi2 * coshbn2+              denom   = smimc^2 + recos2+              c0      = (sinphi2 + a02cosphi2) / denom+              c1      = (sinphi2 - a02cosphi2) / denom+          in  Filt2.Parameter+                 c0 (2*c1) c0+                 (-2*(spimc*smimc - recos2)/denom) (-(spimc^2 + recos2)/denom)+++-- * use second order filter parameters for control++type ParameterA a = (a, Cascade.Parameter a)++{-# INLINE parameterA #-}+parameterA ::+   (Trans.C a, Storable a) =>+   Passband -> Int -> Pole a -> ParameterA a+parameterA kind order =+   -- I hope that the 'let' is floated out of a 'map'+   let circleVec = SV.pack (makeCirclePoints order)+   in  \ (Pole ratio freq) ->+          (ratio,+           Cascade.Parameter $+           SV.map (\c ->+              Filt2.adjustPassband kind+                 (flip (partialParameterA order ratio) c) freq) $+           circleVec)+++type ParameterB a = Cascade.Parameter a++{-# INLINE parameterB #-}+parameterB ::+   (Trans.C a, Storable a) =>+   Passband -> Int -> Pole a -> ParameterB a+parameterB kind order =+   -- I hope that the 'let' is floated out of a 'map'+   let circleVec = SV.pack (makeCirclePoints order)+   in  \ (Pole ratio freq) ->+           Cascade.Parameter $+           SV.map (\c ->+              Filt2.adjustPassband kind+                 (flip (partialParameterB order ratio) c) freq) $+           circleVec++{-+{-# INLINE modifierB #-}+modifierB ::+   (Ring.C a, Module.C a v, Storable a, Storable v) =>+   Int ->+   Modifier.Simple (Cascade.Status v) (Cascade.Parameter a) v v+modifierB =+   Cascade.modifierB+-}++{-# INLINE causalA #-}+causalA :: (Ring.C a, Module.C a v, Storable a, Storable v) =>+   Int ->+   Causal.T (ParameterA a, v) v+causalA order =+   Causal.map (snd.fst) &&& Causal.map (\((ratio,_), y) -> ratio *> y)+    >>> Cascade.causal order++{-# INLINE causalB #-}+causalB :: (Ring.C a, Module.C a v, Storable a, Storable v) =>+   Int ->+   Causal.T (ParameterB a, v) v+causalB =+   Cascade.causal+++++-- * directly use frequency as control parameter++runAPole, runBPole :: (Trans.C a, Module.C a v) =>+   Passband -> Int -> Sig.T a -> Sig.T a -> Sig.T v -> Sig.T v+runAPole kind order ratios freqs =+   let makePartialFilter c =+          Filt2.run+             (zipWith+                 (\ratio -> Filt2.adjustPassband kind $+                  \freq -> partialParameterA order ratio freq c)+                 ratios freqs)+   in  foldl (.) (zipWith (*>) ratios)+          (map makePartialFilter (makeCirclePoints order))++runBPole kind order ratios freqs =+   let makePartialFilter c =+          Filt2.run+             (zipWith+                 (\ratio -> Filt2.adjustPassband kind $+                  \freq -> partialParameterB order ratio freq c)+                 ratios freqs)+   in  foldl (.) id (map makePartialFilter (makeCirclePoints order))+++causalAPole, causalBPole :: (Trans.C a, Module.C a v) =>+   Passband -> Int -> Causal.T (Pole a, v) v+causalAPole kind order =+   let {-# INLINE makePartialFilter #-}+       makePartialFilter c =+          Causal.first (Causal.map (\(Pole ratio freq) ->+             Filt2.adjustPassband kind+             (flip (partialParameterA order ratio) c) freq)) >>>+          Filt2.causal+   in  (\(p, y) -> (p, poleResonance p *> y)) ^>>+       (Causal.chainControlled $+        map makePartialFilter $+        makeCirclePoints order)++causalBPole kind order =+   let {-# INLINE makePartialFilter #-}+       makePartialFilter c =+          Causal.first (Causal.map (\(Pole ratio freq) ->+             Filt2.adjustPassband kind+             (flip (partialParameterB order ratio) c) freq)) >>>+          Filt2.causal+   in  Causal.chainControlled $+       map makePartialFilter $+       makeCirclePoints order+++lowpassACausalPole, highpassACausalPole,+ lowpassBCausalPole, highpassBCausalPole ::+   (Trans.C a, Module.C a v) =>+   Int -> Causal.T (Pole a, v) v+lowpassACausalPole  = causalAPole Lowpass+highpassACausalPole = causalAPole Highpass++lowpassBCausalPole  = causalBPole Lowpass+highpassBCausalPole = causalBPole Highpass+++lowpassAPole, highpassAPole, lowpassBPole, highpassBPole ::+   (Trans.C a, Module.C a v) =>+   Int -> Sig.T a -> Sig.T a -> Sig.T v -> Sig.T v+lowpassAPole  = runAPole Lowpass+highpassAPole = runAPole Highpass++lowpassBPole  = runBPole Lowpass+highpassBPole = runBPole Highpass
+ src/Synthesizer/Plain/Filter/Recursive/Comb.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{- |+Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes++Comb filters, useful for emphasis of tones with harmonics+and for repeated echos.+-}+module Synthesizer.Plain.Filter.Recursive.Comb where++import Synthesizer.Plain.Filter.NonRecursive (delay, )+import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1+import qualified Synthesizer.Plain.Signal   as Sig+-- import qualified Synthesizer.Plain.Modifier as Modifier+import qualified Synthesizer.Plain.Control as Ctrl++import qualified Algebra.Module                as Module+-- import qualified Algebra.Field                 as Field+import qualified Algebra.Ring                  as Ring+import qualified Algebra.Additive              as Additive++import Algebra.Module((*>))++import qualified Prelude as P+import PreludeBase+import NumericPrelude+++{- |+The most simple version of the Karplus-Strong algorithm+which is suitable to simulate a plucked string.+It is similar to the 'runProc' function.+-}+karplusStrong :: (Ring.C a, Module.C a v) =>+   Filt1.Parameter a -> Sig.T v -> Sig.T v+karplusStrong c wave =+    let y = wave ++ Filt1.lowpass (Ctrl.constant c) y+    in  y+++{- |+Infinitely many equi-delayed exponentially decaying echos.+The echos are clipped to the input length.+We think it is easier (and simpler to do efficiently)+to pad the input with zeros or whatever+instead of cutting the result according to the input length.+-}+run :: (Module.C a v) => Int -> a -> Sig.T v -> Sig.T v+run time gain x =+    let y = zipWith (+) x (delay time (gain *> y))+    in  y++{- | Echos of different delays. -}+runMulti :: (Ring.C a, Module.C a v) => [Int] -> a -> Sig.T v -> Sig.T v+runMulti time gain x =+    let y = foldl (zipWith (+)) x (map (flip delay (gain *> y)) time)+    in  y++{- | Echos can be piped through an arbitrary signal processor. -}+runProc :: Additive.C v => Int -> (Sig.T v -> Sig.T v) -> Sig.T v -> Sig.T v+runProc time feedback x =+    let y = zipWith (+) x (delay time (feedback y))+    in  y
+ src/Synthesizer/Plain/Filter/Recursive/FirstOrder.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{- |+Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes++First order low pass and high pass filter.+-}+module Synthesizer.Plain.Filter.Recursive.FirstOrder where++import qualified Synthesizer.Plain.Signal   as Sig+import qualified Synthesizer.Plain.Modifier as Modifier+import qualified Synthesizer.Causal.Process as Causal+import qualified Synthesizer.Interpolation.Class as Interpol++import qualified Algebra.Module                as Module+import qualified Algebra.Transcendental        as Trans+-- import qualified Algebra.Field                 as Field+import qualified Algebra.Ring                  as Ring+import qualified Algebra.Additive              as Additive++import Algebra.Module((*>))++-- import qualified Number.Complex as Complex++import Control.Monad.Trans.State (State, state, )++import PreludeBase+import NumericPrelude++++newtype Parameter a = Parameter {getParameter :: a}+   deriving Show+++instance Interpol.C a v => Interpol.C a (Parameter v) where+   {-# INLINE scaleAndAccumulate #-}+   scaleAndAccumulate = Interpol.makeMac Parameter getParameter+++{-| Convert cut-off frequency to feedback factor. -}+{-# INLINE parameter #-}+parameter :: Trans.C a => a -> Parameter a+parameter freq = Parameter (exp (-2*pi*freq))+++{-# INLINE lowpassStep #-}+lowpassStep :: (Ring.C a, Module.C a v) =>+   Parameter a -> v -> State v v+lowpassStep (Parameter c) x =+   state (\s -> let y = x + c *> (s-x) in (y,y))++{-# INLINE lowpassModifierInit #-}+lowpassModifierInit :: (Ring.C a, Module.C a v) =>+   Modifier.Initialized v v (Parameter a) v v+lowpassModifierInit =+   Modifier.Initialized id lowpassStep++{-# INLINE lowpassModifier #-}+lowpassModifier :: (Ring.C a, Module.C a v) =>+   Modifier.Simple v (Parameter a) v v+lowpassModifier =+   Sig.modifierInitialize lowpassModifierInit zero++{-# INLINE lowpassCausal #-}+lowpassCausal ::+   (Ring.C a, Module.C a v) =>+   Causal.T (Parameter a, v) v+lowpassCausal =+   Causal.fromSimpleModifier lowpassModifier+++{-# INLINE lowpassInit #-}+lowpassInit :: (Ring.C a, Module.C a v) =>+   v -> Sig.T (Parameter a) -> Sig.T v -> Sig.T v+lowpassInit =+   Sig.modifyModulatedInit lowpassModifierInit++{-# INLINE lowpass #-}+lowpass :: (Ring.C a, Module.C a v) =>+   Sig.T (Parameter a) -> Sig.T v -> Sig.T v+lowpass = lowpassInit zero+++{-# INLINE highpassStep #-}+highpassStep :: (Ring.C a, Module.C a v) =>+   Parameter a -> v -> State v v+highpassStep c x =+   fmap (x-) (lowpassStep c x)++{-# INLINE highpassModifierInit #-}+highpassModifierInit :: (Ring.C a, Module.C a v) =>+   Modifier.Initialized v v (Parameter a) v v+highpassModifierInit =+   Modifier.Initialized negate highpassStep++{-# INLINE highpassModifier #-}+highpassModifier :: (Ring.C a, Module.C a v) =>+   Modifier.Simple v (Parameter a) v v+highpassModifier =+   Sig.modifierInitialize highpassModifierInit zero++{-# INLINE highpassInit #-}+highpassInit :: (Ring.C a, Module.C a v) =>+   v -> Sig.T (Parameter a) -> Sig.T v -> Sig.T v+highpassInit =+   Sig.modifyModulatedInit highpassModifierInit++highpassInitAlt :: (Ring.C a, Module.C a v) =>+   v -> Sig.T (Parameter a) -> Sig.T v -> Sig.T v+highpassInitAlt y0 control x =+   x - lowpassInit (-y0) control x++{-# INLINE highpass #-}+highpass :: (Ring.C a, Module.C a v) =>+   Sig.T (Parameter a) -> Sig.T v -> Sig.T v+highpass = highpassInit zero++++data Result a =+        Result {highpass_, lowpass_ :: !a}++instance Additive.C v => Additive.C (Result v) where+   {-# INLINE zero #-}+   {-# INLINE (+) #-}+   {-# INLINE (-) #-}+   {-# INLINE negate #-}+   zero = Result zero zero+   (+) (Result xhp xlp) (Result yhp ylp) = Result (xhp + yhp) (xlp + ylp)+   (-) (Result xhp xlp) (Result yhp ylp) = Result (xhp - yhp) (xlp - ylp)+   negate               (Result xhp xlp) = Result (negate xhp) (negate xlp)+++instance Module.C a v => Module.C a (Result v) where+   {-# INLINE (*>) #-}+   s *> (Result hp lp) = Result (s *> hp) (s *> lp)+++{-# INLINE step #-}+step :: (Ring.C a, Module.C a v) =>+   Parameter a -> v -> State v (Result v)+step c x =+   fmap (\lp -> Result (x-lp) lp) (lowpassStep c x)
+ src/Synthesizer/Plain/Filter/Recursive/FirstOrderComplex.hs view
@@ -0,0 +1,238 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{- |+Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes++First order lowpass and highpass with complex valued feedback.+The complex feedback allows resonance.+-}+module Synthesizer.Plain.Filter.Recursive.FirstOrderComplex (+   Parameter,+   parameter,+   parameterFromPeakWidth,+   parameterFromPeakToDCRatio,+   step,+   modifierInit,+   modifier,+   causal,+   runInit,+   run,+   ) where++import Synthesizer.Plain.Filter.Recursive (Pole(..))+import qualified Synthesizer.Plain.Signal   as Sig+import qualified Synthesizer.Plain.Modifier as Modifier+import qualified Synthesizer.Causal.Process as Causal++import qualified Synthesizer.Interpolation.Class as Interpol++import qualified Number.Complex as Complex+import Number.Complex ((+:))++import qualified Algebra.Module                as Module+import qualified Algebra.Transcendental        as Trans+import qualified Algebra.Algebraic             as Algebraic+import qualified Algebra.Field                 as Field+import qualified Algebra.Ring                  as Ring+import qualified Algebra.Additive              as Additive++import Algebra.Module((*>))++import Control.Monad.Trans.State (State, state, )++import qualified Prelude as P+import PreludeBase+import NumericPrelude+++data Parameter a =+        Parameter {c, amp :: !(Complex.T a)}+++instance Interpol.C a v => Interpol.C a (Parameter v) where+   {-# INLINE scaleAndAccumulate #-}+   scaleAndAccumulate = Interpol.makeMac2 Parameter c amp++++{-+y0 = u0 + k * cis w * y1++transfer function:+   1/(1 - k * cis w * z)++frequency 0 amplified by @recip (1 - k * cis w)@.+resonance frequency amplified by 1+k+k^2+..., which equals @recip (1-k)@.+resonance frequency + half sample rate is amplified by @recip (1+k)@.+-}+++{-|+The internal parameters are computed such that:++* At the resonance frequency+  the filter amplifies by the factor @resonance@+  with no phase shift.++* At resonance frequency plus half sample rate+  the filter amplifies by facter @recip $ 2 - recip resonance@+  with no phase shift,+  but you cannot observe this immediately,+  because it is outside the Nyquist band.+-}+{-# INLINE parameter #-}+parameter :: Trans.C a => Pole a -> Parameter a+parameter (Pole resonance frequency) =+    let cisw   = Complex.cis (2*pi*frequency)+        k      = 1 - recip resonance+        kcisw  = Complex.scale k cisw+    in  Parameter kcisw one+++{-+Let resonance be the ratio+of the resonance amplification+to the amplification at another frequency, encoded by z.++resonance = abs(1 - k * cis w * z) / (1 - k)++Solution: Substitute @cis w * z@ by @cis a@+and proceed as in parameterFromPeakToDCRatio.+-}+{-|+The internal parameters are computed such that:++* At the resonance frequency+  the filter amplifies by the factor @resonance@+  with no phase shift.++* At resonance frequency plus and minus band width+  the filter amplifies by facter 1 with a non-zero phase shift.+-}+{-# INLINE parameterFromPeakWidth #-}+parameterFromPeakWidth :: Trans.C a => a -> Pole a -> Parameter a+parameterFromPeakWidth width (Pole resonance frequency) =+    let cisw   = Complex.cis (2*pi*frequency)+        k      = solveRatio resonance (cos (2*pi*width))+        kcisw  = Complex.scale k cisw+        amp_   = Complex.fromReal ((1-k)*resonance)+    in  Parameter kcisw amp_++{-|+The internal parameters are computed such that:++* At the resonance frequency+  the filter amplifies by the factor @resonance@+  with a non-zero phase shift.++* The filter amplifies the direct current (frequency zero) by factor 1+  with no phase shift.++* The real component is a lowpass,+  the imaginary component is a highpass.+  You can interpolate between them using other complex projections.+-}+{-+If we want to interpret the resonance+as ratio of the peak height to direct current amplification,+we get:++resonance = abs ((1 - k * cis w) / (1-k))+resonance^2 * (1-k)^2+   = (1 - k * cis w) * (1 - k * cis (-w))+   = 1 + k^2 - 2*k*cos w+0 = 1-resonance^2 + 2 * (resonance^2 - cos w) * k + (1-resonance^2) * k^2+0 = 1 + 2 * (resonance^2 - cos w) / (1-resonance^2) * k + k^2+-}+{-# INLINE parameterFromPeakToDCRatio #-}+parameterFromPeakToDCRatio :: Trans.C a => Pole a -> Parameter a+parameterFromPeakToDCRatio (Pole resonance frequency) =+    let cisw   = Complex.cis (2*pi*frequency)+        k      = solveRatio resonance (Complex.real cisw)+        kcisw  = Complex.scale k cisw+        amp_   = one - kcisw+    in  Parameter kcisw amp_++solveRatio :: (Algebraic.C a) =>+    a -> a -> a+solveRatio resonance cosine =+    let r2 = resonance^2+        p  = (r2 - cosine) / (r2 - 1)+        {- no cancelation for p close to 1,+           that is, big resonance or cosine close to 1 -}+    in  recip $ p + sqrt (p^2 - 1)++{-+solveRatioAnalytic :: (Algebraic.C a) =>+    a -> a -> a+solveRatioAnalytic resonance cosine =+    let r2 = resonance^2+        p  = (r2 - cosine) / (r2 - 1)+    in  p - sqrt (p^2 - 1)+-}+++{- |+We use complex numbers as result types,+since the particular filter type is determined by the parameter generator.+-}+type Result = Complex.T+++{-| Universal filter: Computes high pass, band pass, low pass in one go -}+{-# INLINE step #-}+step :: (Module.C a v) =>+   Parameter a -> v -> State (Complex.T v) (Result v)+step p u =+   state $ \s ->+      let y = scale (amp p) u + mul (c p) s+      in  (y, y)+--      in (Result (Complex.imag y) (Complex.real y), y)++scale :: (Module.C a v) =>+   Complex.T a -> v -> Complex.T v+scale s x =+   Complex.real s *> x  +:  Complex.imag s *> x++mul :: (Module.C a v) =>+   Complex.T a -> Complex.T v -> Complex.T v+mul x y =+   (Complex.real x *> Complex.real y - Complex.imag x *> Complex.imag y)+   +:+   (Complex.real x *> Complex.imag y + Complex.imag x *> Complex.real y)+++{-# INLINE modifierInit #-}+modifierInit :: (Ring.C a, Module.C a v) =>+   Modifier.Initialized (Complex.T v) (Complex.T v) (Parameter a) v (Result v)+modifierInit =+   Modifier.Initialized id step++{-# INLINE modifier #-}+modifier :: (Ring.C a, Module.C a v) =>+   Modifier.Simple (Complex.T v) (Parameter a) v (Result v)+modifier = Sig.modifierInitialize modifierInit zero++{-# INLINE causal #-}+causal ::+   (Ring.C a, Module.C a v) =>+   Causal.T (Parameter a, v) (Result v)+causal =+   Causal.fromSimpleModifier modifier+++{-# INLINE runInit #-}+runInit :: (Ring.C a, Module.C a v) =>+   Complex.T v -> Sig.T (Parameter a) -> Sig.T v -> Sig.T (Result v)+runInit = Sig.modifyModulatedInit modifierInit++{-# INLINE run #-}+run :: (Ring.C a, Module.C a v) =>+   Sig.T (Parameter a) -> Sig.T v -> Sig.T (Result v)+run = runInit zero
+ src/Synthesizer/Plain/Filter/Recursive/Integration.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE NoImplicitPrelude #-}+{- |+Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes++Filter operators from calculus+-}+module Synthesizer.Plain.Filter.Recursive.Integration where++import qualified Synthesizer.Plain.Signal   as Sig+-- import qualified Synthesizer.Plain.Modifier as Modifier++-- import qualified Algebra.Field                 as Field+-- import qualified Algebra.Ring                  as Ring+import qualified Algebra.Additive              as Additive++import PreludeBase+import NumericPrelude++++{- |+Integrate with initial value zero.+However the first emitted value is the value of the input signal.+It maintains the length of the signal.+-}+{-# INLINE run #-}+run :: Additive.C v => Sig.T v -> Sig.T v+run = scanl1 (+)++{- |+Integrate with initial condition.+First emitted value is the initial condition.+The signal become one element longer.+-}+{-# INLINE runInit #-}+runInit :: Additive.C v => v -> Sig.T v -> Sig.T v+runInit = scanl (+)++{- other quadrature methods may follow -}
+ src/Synthesizer/Plain/Filter/Recursive/Moog.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{- |+Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes++Moog cascade lowpass with resonance.+-}+module Synthesizer.Plain.Filter.Recursive.Moog where++import Synthesizer.Plain.Filter.Recursive (Pole(..))+import Synthesizer.Plain.Filter.NonRecursive (envelopeVector)+import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1+import qualified Synthesizer.Plain.Signal   as Sig+import qualified Synthesizer.Plain.Modifier as Modifier+import qualified Synthesizer.Causal.Process as Causal++import qualified Synthesizer.Interpolation.Class as Interpol++import qualified Algebra.Module                as Module+import qualified Algebra.Transcendental        as Trans+import qualified Algebra.Field                 as Field+import qualified Algebra.Ring                  as Ring+import qualified Algebra.Additive              as Additive++import Algebra.Module((*>))++import Data.Function.HT (nest, )++import Control.Monad.Trans.State (State, state, evalState, gets)+import Control.Arrow ((&&&), (>>^), (^>>), )++import qualified Prelude as P+import PreludeBase+import NumericPrelude+++data Parameter a =+    Parameter+       {feedback :: !a+           {- ^ Feedback of the lowpass cascade -}+       ,lowpassParam :: !(Filt1.Parameter a)+           {- ^ Feedback of each of the lowpasses of 1st order -} }+  deriving Show+++instance Interpol.C a v => Interpol.C a (Parameter v) where+   {-# INLINE scaleAndAccumulate #-}+   scaleAndAccumulate = Interpol.makeMac2 Parameter feedback lowpassParam+++parameter :: Trans.C a => Int -> Pole a -> Parameter a+parameter order (Pole resonance frequency) =+    let beta  = frequency * 2 * pi+        alpha = (pi-beta) / fromIntegral order+        k     = sin alpha / sin (alpha+beta)++        q = ((sin (alpha+beta) - sin alpha) / sin beta) ^ fromIntegral order+        f = (resonance-1) / (resonance*q+1)+    in  Parameter f (Filt1.Parameter k)++{-+Used for lowpassState,+list of internal values may be processed by Applicative.traverse.+-}+lowpassStepStack :: (Ring.C a, Module.C a v) =>+   Parameter a -> v -> State [v] v+lowpassStepStack (Parameter f k) x =+   do y0 <- gets head+      y1 <- Modifier.stackStatesR (Filt1.lowpassStep k) (x - f *> y0)+      return ((1+f) *> y1)++lowpassStepRev :: (Ring.C a, Module.C a v) =>+   Parameter a -> v -> State [v] v+lowpassStepRev (Parameter f k) x = state (\s ->+    let news =+           tail (scanl+              (evalState . Filt1.lowpassStep k)+              -- (\u0 y1 -> let Filt1.Parameter k0 = k in (1-k0) *> u0 + k0 *> y1)+              (x - f *> last s) s)+    in  ((1+f) *> last news, news))+++lowpassModifier :: (Ring.C a, Module.C a v) =>+   Int -> Modifier.Simple [v] (Parameter a) v v+lowpassModifier order =+   Modifier.Simple (replicate order zero) lowpassStepStack+++{-# INLINE lowpassCausal #-}+{-# INLINE lowpassCausalStacked #-}+{-# INLINE lowpassCausalModifier #-}+lowpassCausal, lowpassCausalStacked, lowpassCausalModifier ::+   (Ring.C a, Module.C a v) =>+   Int -> Causal.T (Parameter a, v) v+lowpassCausal = lowpassCausalStacked++lowpassCausalStacked order =+   Causal.map fst &&&+   Causal.feedbackControlled+      ((\(((Parameter f k),x),y0) -> (k, x - f *> y0)) ^>>+       Causal.replicateControlled order Filt1.lowpassCausal)+      (snd ^>> Causal.consInit zero)+    >>^ (\((Parameter f _k),y1) -> (1+f) *> y1)++lowpassCausalModifier order =+   Causal.fromSimpleModifier (lowpassModifier order)+++lowpass, lowpassState, lowpassRecursive ::+   (Ring.C a, Module.C a v) =>+   Int -> Sig.T (Parameter a) -> Sig.T v -> Sig.T v++{-| Choose one of the implementations below -}+lowpass = lowpassRecursive++{-| Simulate the Moog cascade by a list of states of the partial lowpasses -}+lowpassState order =+   Sig.modifyModulated (lowpassModifier order)++{-| The elegant way of implementing the Moog cascade by recursion -}+lowpassRecursive order c x =+   let k = map lowpassParam c+       f = map feedback c+       z = zipWith subtract (envelopeVector f (zero:y)) x+       y = nest order (Filt1.lowpass k) z+   in  zipWith (*>) (map (1+) f) y
+ src/Synthesizer/Plain/Filter/Recursive/MovingAverage.hs view
@@ -0,0 +1,141 @@+{-# LANGUAGE NoImplicitPrelude #-}+{- |+Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes+-}+module Synthesizer.Plain.Filter.Recursive.MovingAverage+   (sumsStaticInt,+    modulatedFrac,+    ) where++import qualified Synthesizer.Plain.Signal   as Sig+-- import qualified Synthesizer.Plain.Modifier as Modifier+import qualified Synthesizer.Plain.Filter.Recursive.Integration as Integration++import Synthesizer.Plain.Filter.NonRecursive (delay, )++import qualified Algebra.Module                as Module+import qualified Algebra.RealField             as RealField++-- import qualified Algebra.Field                 as Field+-- import qualified Algebra.Ring                  as Ring+import qualified Algebra.Additive              as Additive++import Control.Monad.Fix (fix)+import Data.List (tails)++import PreludeBase+import NumericPrelude++++{- |+Like 'Synthesizer.Plain.Filter.NonRecursive.sums' but in a recursive form.+This needs only linear time (independent of the window size)+but may accumulate rounding errors.++@+ys = xs * (1,0,0,0,-1) \/ (1,-1)+ys * (1,-1) = xs * (1,0,0,0,-1)+ys = xs * (1,0,0,0,-1) + ys * (0,1)+@+-}+sumsStaticInt :: (Additive.C v) => Int -> Sig.T v -> Sig.T v+sumsStaticInt n xs =+   fix (\ys -> let (xs0,xs1) = splitAt n xs+               in  (xs0 ++ (xs1-xs)) + (zero:ys))++{-+staticInt :: (Module.C a v, Additive.C v) => Int -> Sig.T v -> Sig.T v+staticInt n xs =+-}+++{-+Sum of a part of a vector with negative sign for reverse order.+It adds from @from@ (inclusively) to @to@ (exclusively),+that is, it sums up @abs (to-from)@ values+-}+sumFromTo :: (Additive.C v) => Int -> Int -> Sig.T v -> v+sumFromTo from to =+   if from <= to+     then          sum . take (to-from) . drop from+     else negate . sum . take (from-to) . drop to++{-+It would be a nice approach to interpolate not just linearly at the borders+but in a way that the cut-off frequency is perfectly suppressed.+However suppression depends on the phase shift of the wave.+Actually, we could use a complex factor, but does this help?+-}+sumFromToFrac :: (RealField.C a, Module.C a v) => a -> a -> Sig.T v -> v+sumFromToFrac from to xs =+   let (fromInt, fromFrac) = splitFraction from+       (toInt,   toFrac)   = splitFraction to+   in  case compare fromInt toInt of+          EQ -> (to-from) *> (xs !! fromInt)+          LT ->+            sum $+            zipWith id+               (((1-fromFrac) *>) :+                replicate (toInt-fromInt-1) id +++                (toFrac *>) :+                []) $+            drop fromInt xs+          GT ->+            negate $ sum $+            zipWith id+               (((1-toFrac) *>) :+                replicate (fromInt-toInt-1) id +++                (fromFrac *>) :+                []) $+            drop toInt xs++++{- |+Sig.T a must contain only non-negative elements.+-}+sumDiffsModulated :: (RealField.C a, Module.C a v) =>+   a -> Sig.T a -> Sig.T v -> Sig.T v+sumDiffsModulated d ds =+   -- prevent negative d's since 'drop' cannot restore past values+   zipWith3 sumFromToFrac ((d+1) : ds) (map (1+) ds) .+   init . init . tails . (zero:)+{-+   zipWith3 sumFromToFrac (d : map (subtract 1) ds) ds .+   init . tails+-}++sumsModulated :: (RealField.C a, Module.C a v) =>+   Int -> Sig.T a -> Sig.T v -> Sig.T v+sumsModulated maxDInt ds xs =+   let maxD  = fromIntegral maxDInt+       posXs = sumDiffsModulated 0 ds xs+       negXs = sumDiffsModulated maxD (map (maxD-) ds) (delay maxDInt xs)+   in  Integration.run (posXs - negXs)++{- |+Shift sampling points by a half sample period+in order to preserve signals for window widths below 1.+-}+sumsModulatedHalf :: (RealField.C a, Module.C a v) =>+   Int -> Sig.T a -> Sig.T v -> Sig.T v+sumsModulatedHalf maxDInt ds xs =+   let maxD  = fromIntegral maxDInt+       d0    = maxD+0.5+       delXs = delay maxDInt xs+       posXs = sumDiffsModulated d0 (map (d0+) ds) delXs+       negXs = sumDiffsModulated d0 (map (d0-) ds) delXs+   in  Integration.run (posXs - negXs)++modulatedFrac :: (RealField.C a, Module.C a v) =>+   Int -> Sig.T a -> Sig.T v -> Sig.T v+modulatedFrac maxDInt ds xs =+   zipWith (\d y -> recip (2*d) *> y) ds $+   sumsModulatedHalf maxDInt ds xs+
+ src/Synthesizer/Plain/Filter/Recursive/SecondOrder.hs view
@@ -0,0 +1,182 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{- |+Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes++All recursive filters with real coefficients+can be decomposed into first order and second order filters with real coefficients.+This follows from the Fundamental theorem of algebra.+-}+module Synthesizer.Plain.Filter.Recursive.SecondOrder where++import Synthesizer.Plain.Filter.Recursive (Passband(Lowpass,Highpass))+import qualified Synthesizer.Plain.Signal   as Sig+import qualified Synthesizer.Plain.Modifier as Modifier+-- import qualified Synthesizer.Plain.Control as Ctrl++import qualified Synthesizer.Interpolation.Class as Interpol+import Synthesizer.ApplicativeUtility (liftA4, liftA5, )++import qualified Synthesizer.Causal.Process as Causal++-- import qualified Algebra.VectorSpace           as VectorSpace+import qualified Algebra.Module                as Module+-- import qualified Algebra.Transcendental        as Trans+import qualified Algebra.Field                 as Field+import qualified Algebra.Ring                  as Ring+import qualified Algebra.Additive              as Additive++import Algebra.Module((*>))++import Data.List (zipWith6)++import Control.Monad.Trans.State (State, state, )++import Foreign.Storable (Storable(..))+import qualified Foreign.Storable.Record as Store++import qualified Prelude as P+import PreludeBase+import NumericPrelude+++{- | Parameters for a general recursive filter of 2nd order. -}+data Parameter a =+   Parameter {c0, c1, c2, d1, d2 :: !a}+       deriving Show++data Status a =+   Status {u1, u2, y1, y2 :: !a}+       deriving Show++zeroStatus :: Additive.C a => Status a+zeroStatus =+   Status+      {u1 = zero, u2 = zero,+       y1 = zero, y2 = zero}+++instance Interpol.C a v => Interpol.C a (Parameter v) where+   {-# INLINE scaleAndAccumulate #-}+   scaleAndAccumulate =+      Interpol.runMac $+         liftA5 Parameter+            (Interpol.element c0)+            (Interpol.element c1)+            (Interpol.element c2)+            (Interpol.element d1)+            (Interpol.element d2)++++instance Storable a => Storable (Parameter a) where+   sizeOf    = Store.sizeOf storeParameter+   alignment = Store.alignment storeParameter+   peek      = Store.peek storeParameter+   poke      = Store.poke storeParameter++storeParameter ::+   Storable a => Store.Dictionary (Parameter a)+storeParameter =+   Store.run $+   liftA5 Parameter+      (Store.element c0)+      (Store.element c1)+      (Store.element c2)+      (Store.element d1)+      (Store.element d2)+++instance Storable a => Storable (Status a) where+   sizeOf    = Store.sizeOf storeStatus+   alignment = Store.alignment storeStatus+   peek      = Store.peek storeStatus+   poke      = Store.poke storeStatus++storeStatus ::+   Storable a => Store.Dictionary (Status a)+storeStatus =+   Store.run $+   liftA4 Status+      (Store.element u1)+      (Store.element u2)+      (Store.element y1)+      (Store.element y2)+++{- |+Given a function which computes the filter parameters of a lowpass filter+for a given frequency,+turn that into a function which generates highpass parameters,+if requested filter type is Highpass.+-}+{-# INLINE adjustPassband #-}+adjustPassband :: (Field.C a) =>+   Passband -> (a -> Parameter a) -> (a -> Parameter a)+adjustPassband kind comp f =+   case kind of+      Lowpass  -> comp f+      Highpass ->+         let p = comp (0.5-f)+         in  Parameter (c0 p) (- c1 p) (c2 p) (- d1 p) (d2 p)++{-# INLINE step #-}+step :: (Ring.C a, Module.C a v) =>+   Parameter a -> v -> State (Status v) v+step c u0 = state $ \s ->+   let y0 =+          c0 c *> u0   ++          c1 c *> u1 s + d1 c *> y1 s ++          c2 c *> u2 s + d2 c *> y2 s+   in  (y0, Status+               {u1 = u0, u2 = u1 s,+                y1 = y0, y2 = y1 s})+++{-# INLINE modifierInit #-}+modifierInit :: (Ring.C a, Module.C a v) =>+   Modifier.Initialized (Status v) (Status v) (Parameter a) v v+modifierInit =+   Modifier.Initialized id step++{-# INLINE modifier #-}+modifier :: (Ring.C a, Module.C a v) =>+   Modifier.Simple (Status v) (Parameter a) v v+modifier =+   Sig.modifierInitialize modifierInit zeroStatus++{-# INLINE causal #-}+causal :: (Ring.C a, Module.C a v) =>+   Causal.T (Parameter a, v) v+causal =+   Causal.fromSimpleModifier modifier+++{-# INLINE runInit #-}+runInit :: (Ring.C a, Module.C a v) =>+   Status v -> Sig.T (Parameter a) -> Sig.T v -> Sig.T v+runInit sInit control input =+   let u0s = input+       u1s = u1 sInit : u0s+       u2s = u2 sInit : u1s+       y1s = y1 sInit : y0s+       y2s = y2 sInit : y1s+       y0s = zipWith6+          (\c u0_ u1_ u2_ y1_ y2_ ->+              c0 c *> u0_ ++              c1 c *> u1_ + d1 c *> y1_ ++              c2 c *> u2_ + d2 c *> y2_)+          control u0s u1s u2s y1s y2s+   in  y0s++{-# INLINE run #-}+run :: (Ring.C a, Module.C a v) =>+   Sig.T (Parameter a) -> Sig.T v -> Sig.T v+run =+   runInit zeroStatus
+ src/Synthesizer/Plain/Filter/Recursive/SecondOrderCascade.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{- |+Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes++All recursive filters with real coefficients+can be decomposed into first order and second order filters with real coefficients.+This follows from the Fundamental theorem of algebra.++This implements a cascade of second order filters+using StorableVectors for state and filter parameters.+-}+module Synthesizer.Plain.Filter.Recursive.SecondOrderCascade where++import qualified Synthesizer.Plain.Filter.Recursive.SecondOrder as Filt2+-- import Synthesizer.Plain.Filter.Recursive (Passband(Lowpass,Highpass))+import qualified Synthesizer.Plain.Signal   as Sig+import qualified Synthesizer.Plain.Modifier as Modifier+-- import qualified Synthesizer.Plain.Control as Ctrl+import qualified Synthesizer.Interpolation.Class as Interpol++import qualified Synthesizer.Causal.Process as Causal++-- import qualified Algebra.VectorSpace           as VectorSpace+import qualified Algebra.Module                as Module+-- import qualified Algebra.Transcendental        as Trans+-- import qualified Algebra.Field                 as Field+import qualified Algebra.Ring                  as Ring+-- import qualified Algebra.Additive              as Additive++-- import Algebra.Module((*>))++import Control.Monad.Trans.State (State, )++import qualified Data.StorableVector as SV+import Foreign.Storable (Storable(..))++import qualified Prelude as P+import PreludeBase+import NumericPrelude+++{-+Maybe there is no need to make the parameter vector+a StorableVector or an Array.+We could also make Paramter a State.Signal,+which reads from a StorableVector or Array buffer.+This way we would not need to create many StorableVectors+when interpolating filter parameters.+-}+newtype Parameter a =+   Parameter (SV.Vector (Filt2.Parameter a))++{-+If Causal.Process would support ST operations,+then we could use a writeable storable vector for the status.+This would save us many allocations.+-}+type Status a =+   SV.Vector (Filt2.Status a)+++{-# INLINE checkSizes #-}+checkSizes :: String -> SV.Vector a -> SV.Vector b -> c -> c+checkSizes opName x y act =+   if SV.length x == SV.length y+     then act+     else error $ opName ++ ": incompatible sizes of cascades of second order filters"++{-# INLINE withSizeCheck #-}+withSizeCheck ::+   String ->+   (SV.Vector a -> SV.Vector b -> c) ->+   (SV.Vector a -> SV.Vector b -> c)+withSizeCheck opName f x y =+   checkSizes opName x y (f x y)+++instance (Interpol.C a v, Storable v) => Interpol.C a (Parameter v) where+   {-# INLINE scaleAndAccumulate #-}+   scaleAndAccumulate (a, Parameter x) =+      (Parameter $ SV.map (curry Interpol.scale a) x,+       \ (Parameter y) ->+          Parameter $ withSizeCheck "mac"+             (SV.zipWith (curry Interpol.scaleAccumulate a)) x y)+++{-# INLINE step #-}+step ::+   (Ring.C a, Module.C a v, Storable a, Storable v) =>+   Parameter a -> v -> State (Status v) v+step (Parameter p) =+   Modifier.stackStatesStorableVaryL Filt2.step p++{-# INLINE modifierInit #-}+modifierInit ::+   (Ring.C a, Module.C a v, Storable a, Storable v) =>+   Modifier.Initialized (Status v) (Status v) (Parameter a) v v+modifierInit =+   Modifier.Initialized id step+++{-# INLINE modifier #-}+modifier ::+   (Ring.C a, Module.C a v, Storable a, Storable v) =>+   Int ->+   Modifier.Simple (Status v) (Parameter a) v v+modifier order =+   Sig.modifierInitialize modifierInit+      (SV.replicate order Filt2.zeroStatus)++{-# INLINE causal #-}+causal :: (Ring.C a, Module.C a v, Storable a, Storable v) =>+   Int ->+   Causal.T (Parameter a, v) v+causal order =+   Causal.fromSimpleModifier (modifier order)+
+ src/Synthesizer/Plain/Filter/Recursive/Test.hs view
@@ -0,0 +1,155 @@+{-# LANGUAGE NoImplicitPrelude #-}+module Synthesizer.Plain.Filter.Recursive.Test where++import qualified Synthesizer.Plain.Oscillator as Osci+import qualified Synthesizer.Plain.Filter.Recursive.SecondOrder as Filt2+import qualified Synthesizer.Plain.Filter.Recursive.Butterworth as Butter+import qualified Synthesizer.Plain.Filter.Recursive.Chebyshev   as Cheby+import qualified Synthesizer.Plain.Filter.Recursive.Moog        as Moog+import qualified Synthesizer.Plain.Filter.Recursive.Universal   as Uni+import qualified Synthesizer.Plain.Filter.Recursive.FirstOrderComplex as C1+import qualified Synthesizer.Basic.Wave as Wave++import Synthesizer.Plain.Filter.Recursive (Pole(..))++import Number.Complex ((+:), real, imag, )+import qualified Number.Complex as Complex++import qualified Algebra.Transcendental      as Trans+import qualified Algebra.Ring                as Ring++import PreludeBase+import NumericPrelude+++sampleRate :: Ring.C a => a+--sampleRate = 44100+sampleRate = 22050+--sampleRate = 11025+++chirp :: Double -> [Double]+chirp len = Osci.freqModSine 0 (iterate (+0.5/len) 0)++filter2ndOrderTest :: [Double]+filter2ndOrderTest =+   take 10+      (Filt2.run+          (repeat (Filt2.Parameter 1 0 0 0 (1::Double)))+          (1 : repeat 0))+++butterworthLowpassTest0 :: [Double]+butterworthLowpassTest0 =+   take 30 (Butter.lowpassPole 2 (repeat 0.2) (repeat (0.1::Double)) (repeat 1))++butterworthLowpassTest1 :: Double+butterworthLowpassTest1 =+   maximum (take 300 (drop 500+         (Butter.lowpassPole 6 (repeat 0.1) (repeat (0.05::Double))+               (map sin (iterate (+2*pi*0.05) 0)))))++butterworthLowpassTest2 :: [Double]+butterworthLowpassTest2 =+   let len = 1*sampleRate+   in  take (round len) (Butter.lowpassPole 20 (repeat 0.3) (repeat (0.2::Double)) (chirp len))++chebyParameterA, chebyParameterB :: (Trans.C a) =>+   a -> Complex.T a -> a -> Filt2.Parameter a+chebyParameterA vol z freq =+   let re      = real z+       im      = imag z+       phi     = pi*freq+       sinphi  = sin phi+       cosphi  = cos phi+       cpims   = cosphi + im*sinphi+       cmims   = cosphi - im*sinphi+       resin2  = (re*sinphi)^2+       denom   = - cmims^2 - resin2+       c0      = vol * sinphi^2 / denom+   in  Filt2.Parameter+          c0 (2*c0) c0+          (-2*(cpims*cmims - resin2)/denom) ((cpims^2 + resin2)/denom)++chebyParameterB a0 z freq =+   let re      = real z+       im      = imag z+       phi     = pi*freq+       sinphi  = sin phi+       cosphi  = cos phi+       spimc   = sinphi + im*cosphi+       smimc   = sinphi - im*cosphi+       recos2  = (re*cosphi)^2+       denom   = smimc^2 + recos2+       c0      = (sinphi^2 + a0^2*cosphi^2) / denom+       c1      = (sinphi^2 - a0^2*cosphi^2) / denom+   in  Filt2.Parameter+          c0 (2*c1) c0+          (-2*(spimc*smimc - recos2)/denom) (-(spimc^2 + recos2)/denom)++-- cf. makeZero+chebyshevALowpassTest0 :: Filt2.Parameter Double+chebyshevALowpassTest0 =+   let beta = asinh 1 / 4+   in  chebyParameterA 1 (12/13 * cosh beta +: (-5/13 * sinh beta)) 0.1++chebyshevBLowpassTest0 :: Filt2.Parameter Double+chebyshevBLowpassTest0 =+   let beta = asinh 1 / 4+   in  chebyParameterB (12/13) (12/13 * cosh beta +: (-5/13 * sinh beta)) 0.1++chebyshevLowpassTest1 :: [Double]+chebyshevLowpassTest1 =+   let len = 1*sampleRate+   in  take (round len) (Filt2.run (repeat chebyshevALowpassTest0) (chirp len))++chebyshevALowpassTest2 :: [Double]+chebyshevALowpassTest2 =+   let len = 1*sampleRate+   in  take (round len) $+       Cheby.lowpassAPole 10 (repeat 0.25) (repeat (0.3::Double)) (chirp len)++chebyshevBLowpassTest2 :: [Double]+chebyshevBLowpassTest2 =+   let len = 1*sampleRate+   in  take (round len) $+       Cheby.lowpassBPole 10 (repeat 0.25) (repeat (0.1::Double)) (chirp len)++++moogLowpassTest :: [Double]+moogLowpassTest =+   Moog.lowpass 10+      (repeat (Moog.parameter 10 (Pole 10 (0.05::Double))))+      (1:repeat 0)++universalTest :: [Uni.Result Double]+universalTest =+   let len = 1*sampleRate+   in  take (round len) $+       Uni.run+          (repeat (Uni.parameter (Pole 5 (0.1::Double))))+          (chirp len)+++complexRealTest :: [Complex.T Double]+complexRealTest =+   let len = 1*sampleRate+   in  take (round len) $+       C1.run+          (repeat (C1.parameterFromPeakWidth 0.025 (Pole 5 (0.1::Double))))+          (chirp len)++chirpComplex :: Double -> [Complex.T Double]+chirpComplex len =+   Osci.freqMod Wave.helix 0 (iterate (+0.5/len) 0)++complexTest :: [Complex.T Double]+complexTest =+   let len = 1*sampleRate+   in  take (round len) $+       map+          (\x -> Complex.real x + Complex.quarterLeft (Complex.imag x)) $+       C1.run+          (repeat (C1.parameterFromPeakWidth 0.025 (Pole 5 (0.1::Double))))+          (chirpComplex len)
+ src/Synthesizer/Plain/Filter/Recursive/Universal.hs view
@@ -0,0 +1,192 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{- |+Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes++State variable filter.+One filter that generates lowpass, bandpass, highpass, bandlimit at once.+-}+module Synthesizer.Plain.Filter.Recursive.Universal where++import Synthesizer.Plain.Filter.Recursive (Pole(..))+import qualified Synthesizer.Plain.Signal   as Sig+import qualified Synthesizer.Plain.Modifier as Modifier+import qualified Synthesizer.Causal.Process as Causal++import qualified Synthesizer.Interpolation.Class as Interpol+import Synthesizer.ApplicativeUtility (liftA4, liftA6, )++import Foreign.Storable (Storable(..))+import qualified Foreign.Storable.Record as Store++import qualified Algebra.Module                as Module+import qualified Algebra.Transcendental        as Trans+import qualified Algebra.Field                 as Field+import qualified Algebra.Ring                  as Ring+import qualified Algebra.Additive              as Additive++import Algebra.Module((*>))++import Control.Monad.Trans.State (State, state, )++import qualified Prelude as P+import PreludeBase+import NumericPrelude+++data Parameter a =+        Parameter {k1, k2, ampIn, ampI1, ampI2, ampLimit :: !a}+++instance Interpol.C a v => Interpol.C a (Parameter v) where+   {-# INLINE scaleAndAccumulate #-}+   scaleAndAccumulate =+      Interpol.runMac $ liftA6 Parameter+         (Interpol.element k1)+         (Interpol.element k2)+         (Interpol.element ampIn)+         (Interpol.element ampI1)+         (Interpol.element ampI2)+         (Interpol.element ampLimit)++instance Storable a => Storable (Parameter a) where+   sizeOf    = Store.sizeOf storeParameter+   alignment = Store.alignment storeParameter+   peek      = Store.peek storeParameter+   poke      = Store.poke storeParameter++storeParameter ::+   Storable a => Store.Dictionary (Parameter a)+storeParameter =+   Store.run $+   liftA6 Parameter+      (Store.element k1)+      (Store.element k2)+      (Store.element ampIn)+      (Store.element ampI1)+      (Store.element ampI2)+      (Store.element ampLimit)+++data Result a =+        Result {highpass, bandpass, lowpass, bandlimit :: !a}++instance Additive.C v => Additive.C (Result v) where+   {-# INLINE zero #-}+   {-# INLINE (+) #-}+   {-# INLINE (-) #-}+   {-# INLINE negate #-}+   zero = Result zero zero zero zero+   (+) (Result xhp xbp xlp xbl) (Result yhp ybp ylp ybl) =+      Result (xhp + yhp) (xbp + ybp) (xlp + ylp) (xbl + ybl)+   (-) (Result xhp xbp xlp xbl) (Result yhp ybp ylp ybl) =+      Result (xhp - yhp) (xbp - ybp) (xlp - ylp) (xbl - ybl)+   negate                   (Result xhp xbp xlp xbl) =+      Result (negate xhp) (negate xbp) (negate xlp) (negate xbl)++instance Module.C a v => Module.C a (Result v) where+   {-# INLINE (*>) #-}+   s *> (Result hp bp lp bl) =+      Result (s *> hp) (s *> bp) (s *> lp) (s *> bl)++instance Storable a => Storable (Result a) where+   sizeOf    = Store.sizeOf storeResult+   alignment = Store.alignment storeResult+   peek      = Store.peek storeResult+   poke      = Store.poke storeResult++storeResult ::+   Storable a => Store.Dictionary (Result a)+storeResult =+   Store.run $+   liftA4 Result+      (Store.element highpass)+      (Store.element bandpass)+      (Store.element lowpass)+      (Store.element bandlimit)++++{-|+The computation of the internal parameters is a bit complicated,+but it fulfills the following properties:++* At the resonance frequency the band pass has 180 degree phase shift.+  This is also approximately the frequency+  where the filter has maximum output.+  Even more important, this is the frequency where the band limit filter works.++* At the resonance frequency highpass, lowpass, and bandpass+  amplify by the factor @resonance@.++* The lowpass amplifies the frequency zero by factor 1.++* The highpass amplifies the highest representable (Nyquist) frequency by the factor 1.++* The bandlimit amplifies both frequency zero and Nyquist frequency+  by factor one and cancels the resonance frequency.+-}+{-# INLINE parameter #-}+parameter :: Trans.C a => Pole a -> Parameter a+parameter (Pole resonance frequency) =+    let zr     = cos (2*pi*frequency)+        zr1    = zr-1+        q2     = resonance^2+        sqrtQZ = sqrt (zr1*(-8*q2+zr1-4*q2*zr1))+        pk1    = (-zr1+sqrtQZ) / (2*q2-zr1+sqrtQZ)+        q21zr  = 4*q2*zr+        a      = 2 * (zr1*zr1-q21zr*zr) / (zr1+q21zr+(1+2*zr1)*sqrtQZ)+        pk2    = a+2-pk1+        volHP  = (4-2*pk1-pk2) / 4+        volLP  = pk2+        volBP  = sqrt (volHP*volLP)+    in  Parameter+           (pk1*volHP/volBP)  (pk2*volHP/volLP)+           volHP  (volBP/volHP)  (volLP/volBP)  (recip resonance)++{-| Universal filter: Computes high pass, band pass, low pass in one go -}+{-# INLINE step #-}+step :: (Ring.C a, Module.C a v) =>+   Parameter a -> v -> State (v,v) (Result v)+step p u =+   state $ \(i1,i2) ->+      let newsum = ampIn p *> u + k1 p *> i1 - k2 p *> i2+          newi1  = i1 - ampI1 p *> newsum+          newi2  = i2 - ampI2 p *> newi1+          out    = Result newsum newi1 newi2 (u + ampLimit p *> newi1)+      in  (out, (newi1, newi2))++{-# INLINE modifierInit #-}+modifierInit :: (Ring.C a, Module.C a v) =>+   Modifier.Initialized (v,v) (v,v) (Parameter a) v (Result v)+modifierInit =+   Modifier.Initialized id step++{-# INLINE modifier #-}+modifier :: (Ring.C a, Module.C a v) =>+   Modifier.Simple (v,v) (Parameter a) v (Result v)+modifier = Sig.modifierInitialize modifierInit (zero, zero)++{-# INLINE causal #-}+causal ::+   (Ring.C a, Module.C a v) =>+   Causal.T (Parameter a, v) (Result v)+causal =+   Causal.fromSimpleModifier modifier+++{-# INLINE runInit #-}+runInit :: (Ring.C a, Module.C a v) =>+   (v,v) -> Sig.T (Parameter a) -> Sig.T v -> Sig.T (Result v)+runInit = Sig.modifyModulatedInit modifierInit++{-# INLINE run #-}+run :: (Ring.C a, Module.C a v) =>+   Sig.T (Parameter a) -> Sig.T v -> Sig.T (Result v)+run = runInit (zero, zero)
+ src/Synthesizer/Plain/IO.hs view
@@ -0,0 +1,142 @@+{- |+This is old code, handling Int16 using two characters.+-}+module Synthesizer.Plain.IO+   {-# DEPRECATED "Use Sound.Sox.Signal.List instead." #-}+   (+    writeInt16Stream, readInt16StreamStrict,+    writeLEInt16Stream, readLEInt16Stream,+    putInt16Stream, putInt16StreamChunky,+    -- historical functions+    intToTwoLEChars, twoLECharsToInt,+   ) where++import Foreign (Int16, Ptr, alloca, sizeOf, poke, peek)+import System.IO+          (openBinaryFile, IOMode(WriteMode,ReadMode), hClose,+           Handle, hPutBuf, hGetBuf)+import Control.Exception (bracket, )+import Control.Monad (liftM, )++import Data.Monoid (Monoid, mconcat, )++import qualified Data.ByteString.Lazy as B+import qualified Data.Binary.Builder as Builder++import qualified Algebra.Ring      as Ring++import Data.Char (ord, )++import qualified Prelude as P98++import PreludeBase+import NumericPrelude++++-- | little endian (Intel)+{-# INLINE leCharsToInt16 #-}+leCharsToInt16 :: Char -> Char -> Int16+leCharsToInt16 hi lo =+   P98.fromIntegral $ ord lo + 256 * ord hi++twoLECharsToInt :: Char -> Char -> Int+twoLECharsToInt hi lo =+   let unsigned = ord lo + 256 * ord hi+   in  mod (unsigned + 32768) 65536 - 32768+++-- | little endian (Intel)+{-# INLINE int16ToLEChars #-}+int16ToLEChars :: Int16 -> [Char]+int16ToLEChars x =+   let (hi,lo) = divMod (P98.fromIntegral x) 256+   in  [toEnum lo, toEnum (mod hi 256)]++intToTwoLEChars :: Int -> [Char]+intToTwoLEChars x =+   let (hi,lo) = divMod x 256+   in  [toEnum lo, toEnum (mod hi 256)]++++{-# INLINE binaryToIntsMono16 #-}+binaryToIntsMono16 :: [Char] -> [Int16]+binaryToIntsMono16 sig =+   case sig of+      (lo:hi:xs) ->+         leCharsToInt16 hi lo : binaryToIntsMono16 xs+      (_:[]) ->+         error "binaryToIntsMono16: 16 bit sample files must have even length"+      [] -> []+++{- |+Write a little endian 16 bit integer stream+via String data and 'writeFile'.+-}+writeLEInt16Stream :: FilePath -> [Int16] -> IO ()+writeLEInt16Stream fileName =+   writeFile fileName . concatMap int16ToLEChars++{- |+Uses endianess of the machine, like Sox does.+-}+writeInt16Stream :: FilePath -> [Int16] -> IO ()+writeInt16Stream fileName stream =+   bracket (openBinaryFile fileName WriteMode) hClose+      (flip putInt16Stream stream)++putInt16StreamChunky :: Handle -> [Int16] -> IO ()+putInt16StreamChunky h =+   B.hPut h . Builder.toLazyByteString .+   mconcat . map (Builder.putWord16host . P98.fromIntegral)++putInt16Stream :: Handle -> [Int16] -> IO ()+putInt16Stream h stream =+   alloca $+      \p -> mapM_ (putInt16 h p) stream++putInt16 :: Handle -> Ptr Int16 -> Int16 -> IO ()+putInt16 h p n =+   poke p n >> hPutBuf h p (sizeOf n)+++{- |+The end of the list is undefined,+if the file has odd length.+It would be better if it throws an exception.+-}+readLEInt16Stream :: FilePath -> IO [Int16]+readLEInt16Stream fileName =+   fmap binaryToIntsMono16 (readFile fileName)++{- |+The end of the list is undefined,+if the file has odd length.+It would be better if it throws an exception.+-}+readInt16StreamStrict :: FilePath -> IO [Int16]+readInt16StreamStrict fileName =+   bracket (openBinaryFile fileName ReadMode) hClose+      getInt16StreamStrict++getInt16StreamStrict :: Handle -> IO [Int16]+getInt16StreamStrict h =+   alloca $+      \p -> fmap (map P98.fromIntegral)+                 (unfoldM (getInt16 h p))++-- candidate for Utility+unfoldM :: Monad m => m (Maybe a) -> m [a]+unfoldM act =+   let listM = maybe (return []) (\x -> liftM (x:) listM) =<< act+   in  listM++getInt16 :: Handle -> Ptr Int16 -> IO (Maybe Int16)+getInt16 h p =+   do cnt <- hGetBuf h p (sizeOf (undefined::Int16))+      case cnt of+        0 -> return Nothing+        2 -> fmap Just (peek p)+        _ -> return (error "getInt16: only one byte found")
+ src/Synthesizer/Plain/Instrument.hs view
@@ -0,0 +1,304 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+module Synthesizer.Plain.Instrument where++import Synthesizer.Plain.Displacement (mixMulti, )+import Synthesizer.Plain.Control (exponential2)+import qualified Synthesizer.Plain.Oscillator as Osci+import qualified Synthesizer.Basic.Wave       as Wave+import qualified Synthesizer.Plain.Noise      as Noise+import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1+import qualified Synthesizer.Plain.Filter.Recursive.Allpass    as Allpass+import qualified Synthesizer.Plain.Filter.Recursive.Universal  as UniFilter+import qualified Synthesizer.Plain.Filter.Recursive.Moog       as Moog+import qualified Synthesizer.Plain.Filter.Recursive.Comb       as Comb+import qualified Synthesizer.Plain.Filter.Recursive    as FiltR+import qualified Synthesizer.Plain.Filter.NonRecursive as FiltNR+import qualified Synthesizer.Plain.Interpolation as Interpolation+import Data.List(zipWith4)++import System.Random++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 qualified Algebra.Ring           as Ring++import PreludeBase+import NumericPrelude++++{-| Create a sound of a slightly changed frequency+    just as needed for a simple stereo sound. -}+stereoPhaser :: Ring.C a =>+       (a -> [b])  {- ^ A function mapping a frequency to a signal. -}+    -> a           {- ^ The factor to the frequency, should be close to 1. -}+    -> a           {- ^ The base (undeviated) frequency of the sound. -}+    -> [b]+stereoPhaser sound dif freq = sound (freq*dif)++++allpassPlain :: (RealField.C a, Trans.C a, Module.C a a) =>+                   a -> a -> a -> a -> [a]+allpassPlain sampleRate halfLife k freq =+    Allpass.cascade 10+        (map Allpass.Parameter (exponential2 (halfLife*sampleRate) k))+        (simpleSaw sampleRate freq)++allpassDown :: (RealField.C a, Trans.C a, Module.C a a) =>+                  a -> Int -> a -> a -> a -> [a]+allpassDown sampleRate order halfLife filterfreq freq =+    let x = simpleSaw sampleRate freq+    in  map (0.3*) (zipWith (+) x+            (Allpass.cascade order+                (map (Allpass.flangerParameter order)+                     (exponential2 (halfLife*sampleRate) (filterfreq/sampleRate)))+                x))+++moogDown, moogReso ::+   (RealField.C a, Trans.C a, Module.C a a) =>+      a -> Int -> a -> a -> a -> [a]+moogDown sampleRate order halfLife filterfreq freq =+    Moog.lowpass order+        (map (Moog.parameter order) (map (FiltR.Pole 10)+            (exponential2 (halfLife*sampleRate) (filterfreq/sampleRate))))+        (simpleSaw sampleRate freq)++moogReso sampleRate order halfLife filterfreq freq =+    Moog.lowpass order+        (map (Moog.parameter order) (zipWith FiltR.Pole+            (exponential2 (halfLife*sampleRate) 100)+            (repeat (filterfreq/sampleRate))))+        (simpleSaw sampleRate freq)++bell :: (Trans.C a, RealField.C a) => a -> a -> [a]+bell sampleRate freq =+    let halfLife = 0.5+    in  zipWith3 (\x y z -> (x+y+z)/3)+            (bellHarmonic sampleRate 1 halfLife freq)+            (bellHarmonic sampleRate 4 halfLife freq)+            (bellHarmonic sampleRate 7 halfLife freq)++bellHarmonic :: (Trans.C a, RealField.C a) => a -> a -> a -> a -> [a]+bellHarmonic sampleRate n halfLife freq =+    zipWith (*) (Osci.freqModSine 0 (map (\modu -> freq/sampleRate*n*(1+0.005*modu))+                                    (Osci.staticSine 0 (5.0/sampleRate))))+                (exponential2 (halfLife/n*sampleRate) 1)+++fastBell, squareBell, moogGuitar, moogGuitarSoft, simpleSaw, fatSaw ::+    (RealField.C a, Trans.C a, Module.C a a) => a -> a -> [a]++fastBell sampleRate freq =+    zipWith (*) (Osci.staticSine 0 (freq/sampleRate))+                (exponential2 (0.2*sampleRate) 1)++filterSaw :: (Module.C a a, Trans.C a, RealField.C a) =>+             a -> a -> a -> [a]+filterSaw sampleRate filterFreq freq =+    map (\r -> UniFilter.lowpass r * 0.1)+        (UniFilter.run (map (UniFilter.parameter . FiltR.Pole 10)+                        (exponential2 (0.1*sampleRate) (filterFreq/sampleRate)))+                   (Osci.staticSaw 0 (freq/sampleRate)))++squareBell sampleRate freq = Filt1.lowpass+         (map Filt1.parameter+              (exponential2 (sampleRate/10) (4000/sampleRate)))+--       (Osci.freqModSample Interpolation.cubic [0, 0.7, -0.3, 0.7, 0, -0.7, 0.3, -0.7] 0+         (Osci.freqModSample Interpolation.linear [0, 0.5, 0.6, 0.8, 0, -0.5, -0.6, -0.8] 0+                  (map (\modu -> freq/sampleRate*(1+modu/100))+                       (Osci.staticSine 0 (5.0/sampleRate))))++fmBell :: (RealField.C a, Trans.C a) => a -> a -> a -> a -> [a]+fmBell sampleRate depth freqRatio freq =+   let modul = FiltNR.envelope (exponential2 (0.2*sampleRate) depth)+                        (Osci.staticSine 0 (freqRatio*freq/sampleRate))+       env   = exponential2 (0.5*sampleRate) 1+   in  FiltNR.envelope env (Osci.phaseModSine (freq/sampleRate) modul)++moogGuitar sampleRate freq =+   let moogOrder = 4+       filterControl =+          map (Moog.parameter moogOrder)+              (map (FiltR.Pole 10) (exponential2+                               (0.5*sampleRate)+                               (4000/sampleRate)))+       tone = Osci.freqModSaw 0 (map (\modu -> freq/sampleRate*(1+0.005*modu))+                                (Osci.staticSine 0 (5.0/sampleRate)))+   in  Moog.lowpass moogOrder filterControl tone++moogGuitarSoft sampleRate freq =+   FiltNR.envelope (map (1-) (exponential2 (0.003*sampleRate) 1))+            (moogGuitar sampleRate freq)++++{-| low pass with resonance -}+filterSweep :: (Field.C v, Module.C a v, Trans.C a, RealField.C a) =>+                  a -> a -> [v] -> [v]+filterSweep sampleRate phase =+    map (\r -> UniFilter.lowpass r / 2) .+    UniFilter.run+        (map (\freq ->+                UniFilter.parameter (FiltR.Pole 10 ((1800/sampleRate)*2**freq)))+             (Osci.staticSine phase (1/16/sampleRate))+        )+++fatSawChordFilter, fatSawChord ::+   (RealField.C a, Trans.C a, Module.C a a) => a -> a -> [a]++fatSawChordFilter sampleRate freq =+    map (\r -> UniFilter.lowpass r / 2)+        (UniFilter.run (filterDown sampleRate)+                   (fatSawChord sampleRate freq))++fatSawChord sampleRate freq =+    zipWith3 (\x y z -> (x+y+z)/3)+             (fatSaw sampleRate (1  *freq))+             (fatSaw sampleRate (5/4*freq))+             (fatSaw sampleRate (3/2*freq))++filterDown :: (RealField.C a, Trans.C a) => a -> [UniFilter.Parameter a]++filterDown sampleRate =+    map UniFilter.parameter $+    map (FiltR.Pole 10) $+    exponential2 (sampleRate/3) (4000/sampleRate)++simpleSaw sampleRate freq = +    Osci.staticSaw 0 (freq/sampleRate)++{-| accumulate multiple similar saw sounds and observe the increase of volume+    The oscillator @osc@ must accept relative frequencies. -}+modulatedWave :: (Trans.C a, RealField.C a) =>+   a -> (a -> [a] -> [a]) -> a -> a -> a -> a -> a -> [a]+modulatedWave sampleRate osc freq start depth phase speed =+   osc start (map (\x -> freq/sampleRate*(1+x*depth))+                  (Osci.staticSine phase (speed/sampleRate)))++accumulatedSaws :: (Random a, Trans.C a, RealField.C a) => a -> a -> [[a]]+accumulatedSaws sampleRate freq =+   let starts = randomRs (0,1)     (mkStdGen 48251)+       depths = randomRs (0,0.02)  (mkStdGen 12354)+       phases = randomRs (0,1)     (mkStdGen 74389)+       speeds = randomRs (0.1,0.3) (mkStdGen 03445)+       saws   = zipWith4 (modulatedWave sampleRate Osci.freqModSaw freq)+                         starts depths phases speeds+   in  scanl1 (zipWith (+)) saws++choirWave :: Field.C a => [a]+choirWave =+   [0.702727421560071, 0.7378359559947721, 0.7826845805704197, 0.6755514176072053,+   0.4513448069764686, 0.3272995923197175, 0.3404887595570093, 0.41416011004660863,+   0.44593673999775735, 0.4803528740412951, 0.48761174828621334, 0.44076701468836754,+   0.39642906530439503, 0.35467843549395706, 0.38054627445988315, 0.3888748481589558,+   0.35303993804564215, 0.3725196582177455, 0.44980257249714667, 0.5421204370443772,+   0.627630436752643, 0.6589491426946169, 0.619819155051891, 0.5821754728547365,+   0.5495877076869761, 0.5324446834830168, 0.47242861142812065, 0.3686685958119909,+   0.2781440436733245, 0.2582500464201269, 0.1955614176372372, 0.038373557320540604,+   -0.13132155046556182, -0.21867394831598339, -0.24302145520904606, -0.3096437514614372,+   -0.44774961666697943, -0.5889830267579028, -0.7168993833444837, -0.816723038671071,+   -0.8330283834679535, -0.8384077057999397, -0.8834813451725689, -0.9159391171556484,+   -0.9189751669797644, -0.8932026446626791, -0.8909164153221475, -0.9716732300637536,+   -1, -0.9253833606736654, -0.8568630538844477, -0.863932337623625,+   -0.857811827480001, -0.8131204084064676, -0.7839286071242304, -0.7036632045472225,+   -0.5824648346845637, -0.46123726085299827, -0.41391985851146285, -0.45323938111069567,+   -0.5336689022602625, -0.5831307769323063, -0.5693896103843189, -0.48596981886424745,+   -0.35791155598992863, -0.2661471984133689, -0.24158092840946802, -0.23965213828744264,+   -0.23421368394531547, -0.25130667896294306, -0.3116359503337366, -0.31263345635966144,+   -0.1879031874103659, -0.00020936838180399674, 0.18567090309156153, 0.2713525359068149,+   0.2979908042971701, 0.2957704726566382, 0.28820375086489286, 0.364513508557745,+   0.4520234711163569, 0.43210542988077005, 0.4064955825278379, 0.4416784798648095,+   0.5240917981530765, 0.6496469543088884, 0.7658103369723797, 0.8012776441058732,+   0.7824042138292476, 0.752678361663059, 0.760211176708886, 0.7308266231622353]+++choir :: (Random a, Trans.C a, RealField.C a) => a -> a -> [a]+choir sampleRate freq =+   let starts = randomRs (0,1)     (mkStdGen 48251)+       depths = randomRs (0,0.02)  (mkStdGen 12354)+       phases = randomRs (0,1)     (mkStdGen 74389)+       speeds = randomRs (0.1,0.3) (mkStdGen 03445)+       voices = zipWith4 (modulatedWave sampleRate+                            (Osci.freqModSample Interpolation.constant choirWave) freq)+                         starts depths phases speeds+   in  map (*0.2) ((scanl1 (zipWith (+)) voices) !! 10)+++fatSaw sampleRate freq =+    {- a simplified version of modulatedWave -}+    let partial depth modPhase modFreq =+           osciDoubleSaw sampleRate+              (map (\x -> freq*(1+x*depth))+                   (Osci.staticSine modPhase (modFreq/sampleRate)))+    in  zipWith3 (((((/3).).(+)).).(+))+            (partial 0.00311 0.0 20)+            (partial 0.00532 0.3 17)+            (partial 0.00981 0.9  6)++osciDoubleSaw :: (RealField.C a, Module.C a a) => a -> [a] -> [a]+osciDoubleSaw sampleRate =+    Osci.freqModSample Interpolation.linear [-1, -0.2, 0.5, -0.5, 0.2, 1.0] 0+      . map (/sampleRate)+++{-| A tone with a waveform with roughly the dependency x -> x**p,+    where the waveform is normalized to constant quadratic norm -}+osciSharp :: (RealField.C a, Trans.C a) => a -> a -> [a]+osciSharp sampleRate freq =+   let --control = iterate (+ (-1/sampleRate)) 4+       control = exponential2 (0.01*sampleRate) 10+   in  Osci.shapeMod Wave.powerNormed 0 (freq/sampleRate) control++{-| Build a saw sound from its harmonics and modulate it.+    Different to normal modulation+    I modulate each harmonic with the same depth rather than a proportional one. -}+osciAbsModSaw :: (RealField.C a, Trans.C a) => a -> a -> [a]+osciAbsModSaw sampleRate freq =+   let ratios     = map fromIntegral [(1::Int)..20]+       harmonic n = FiltNR.amplify (0.25/n)+          (Osci.freqModSine 0 (map (\x -> (n+0.03*x)*freq/sampleRate)+                              (Osci.staticSine 0 (1/sampleRate))))+   in  mixMulti (map harmonic ratios)++{-| Short pulsed Noise.white,+    i.e. Noise.white amplified with pulses of varying H\/L ratio. -}+pulsedNoise :: (Ring.C a, Random a, RealField.C a, Trans.C a) =>+       a+   ->  a   {-^ frequency of the pulses, interesting ones are around 100 Hz and below -}+   -> [a]+pulsedNoise sampleRate freq =+   zipWith3 (\thr0 thr1 x -> if thr0+1 < (thr1+1)*0.2 then x else 0)+            (Osci.staticSine 0 (freq/sampleRate)) (Osci.staticSine 0 (0.1/sampleRate)) Noise.white++noiseBass :: (Ring.C a, Random a, RealField.C a, Trans.C a, Module.C a a) =>+       a+   ->  a+   -> [a]+noiseBass sampleRate freq =+   let y  = FiltNR.envelope (exponential2 (0.1*sampleRate) 1) Noise.white+       ks = Comb.runProc (round (sampleRate/freq))+               (Filt1.lowpass+                   (repeat (Filt1.parameter (2000/sampleRate)))) y+   in  ks++{-| Drum sound using the Karplus-Strong-Algorithm+    This is a Noise.white enveloped by an exponential2+    which is piped through the Karplus-Strong machine+    for generating some frequency.+    The whole thing is then frequency modulated+    to give a falling frequency. -}+electroTom :: (Ring.C a, Random a, RealField.C a, Trans.C a, Module.C a a) =>+   a -> [a]+electroTom sampleRate =+   let y  = FiltNR.envelope (exponential2 (0.1*sampleRate) 1) Noise.white+       ks = Comb.runProc (round (sampleRate/30))+                     (Filt1.lowpass+                         (repeat $ Filt1.parameter (1000/sampleRate))) y+   in  Interpolation.multiRelativeZeroPadLinear 0 (exponential2 (0.3*sampleRate) 1) ks
+ src/Synthesizer/Plain/Interpolation.hs view
@@ -0,0 +1,180 @@+{-# LANGUAGE NoImplicitPrelude #-}+module Synthesizer.Plain.Interpolation (+   T, func, offset, number,+   zeroPad, constantPad, cyclicPad, extrapolationPad,+   single,+   multiRelative,+   multiRelativeZeroPad, multiRelativeConstantPad,+   multiRelativeCyclicPad, multiRelativeExtrapolationPad,+   multiRelativeZeroPadConstant, multiRelativeZeroPadLinear,+   multiRelativeZeroPadCubic,++   constant, linear, cubic,+   piecewise, function,++   Interpolation.Margin, Interpolation.margin,++   singleRec, -- for testing+   ) where++import qualified Synthesizer.Interpolation as Interpolation+import Synthesizer.Interpolation (T, offset, number, )+import Synthesizer.Interpolation.Module+          (constant, linear, cubic, piecewise, function, )++import qualified Synthesizer.State.Signal       as SigS++import qualified Synthesizer.Plain.Signal  as Sig+import qualified Synthesizer.Plain.Filter.NonRecursive as FiltNR++import qualified Algebra.Module    as Module+import qualified Algebra.RealField as RealField+import qualified Algebra.Ring      as Ring+import qualified Algebra.Additive  as Additive++import Algebra.Additive(zero)+import Data.Maybe (fromMaybe)+import qualified Data.List.HT as ListHT++import Control.Monad (guard, )++import PreludeBase+import NumericPrelude+++{-* Interpolation with various padding methods -}++zeroPad :: (RealField.C t) =>+   (T t y -> t -> Sig.T y -> a) ->+   y -> T t y -> t -> Sig.T y -> a+zeroPad interpolate z ip phase x =+   let (phInt, phFrac) = splitFraction phase+   in  interpolate ip phFrac+          (FiltNR.delayPad z (offset ip - phInt) (x ++ repeat z))++constantPad :: (RealField.C t) =>+   (T t y -> t -> Sig.T y -> a) ->+   T t y -> t -> Sig.T y -> a+constantPad interpolate ip phase x =+   let (phInt, phFrac) = splitFraction phase+       xPad =+          do (xFirst,_) <- ListHT.viewL x+             (xBody,xLast) <- ListHT.viewR x+             return (FiltNR.delayPad xFirst (offset ip - phInt) (xBody ++ repeat xLast))+   in  interpolate ip phFrac+          (fromMaybe [] xPad)+++{- |+Only for finite input signals.+-}+cyclicPad :: (RealField.C t) =>+   (T t y -> t -> Sig.T y -> a) ->+   T t y -> t -> Sig.T y -> a+cyclicPad interpolate ip phase x =+   let (phInt, phFrac) = splitFraction phase+   in  interpolate ip phFrac+          (drop (mod (phInt - offset ip) (length x)) (cycle x))++{- |+The extrapolation may miss some of the first and some of the last points+-}+extrapolationPad :: (RealField.C t) =>+   (T t y -> t -> Sig.T y -> a) ->+   T t y -> t -> Sig.T y -> a+extrapolationPad interpolate ip phase =+   interpolate ip (phase - fromIntegral (offset ip))+{-+  This example shows pikes, although there shouldn't be any:+   plotList (take 100 $ interpolate (Zero (0::Double)) ipCubic (-0.9::Double) (repeat 0.03) [1,0,1,0.8])+-}+++{-* Interpolation of multiple values with various padding methods -}++func ::+   T t y -> t -> Sig.T y -> y+func ip phase =+   Interpolation.func ip phase . SigS.fromList++skip :: (RealField.C t) =>+   T t y -> (t, Sig.T y) -> (t, Sig.T y)+skip ip (phase0, x0) =+   let (n, frac) = splitFraction phase0+       (m, x1) = Sig.dropMarginRem (number ip) n x0+   in  (fromIntegral m + frac, x1)++single :: (RealField.C t) =>+   T t y -> t -> Sig.T y -> y+single ip phase0 x0 =+   uncurry (func ip) $ skip ip (phase0, x0)+--   curry (uncurry (func ip) . skip ip)+{-+GNUPlot.plotFunc [] (GNUPlot.linearScale 1000 (0,2)) (\t -> single linear (t::Double) [0,4,1::Double])+-}++-- | alternative implementation of 'single'+singleRec :: (Ord t, Ring.C t) =>+   T t y -> t -> Sig.T y -> y+singleRec ip phase x =+   -- check if we are leaving the current interval+   maybe+      (func ip phase x)+      (singleRec ip (phase - 1))+      (do (_,xs) <- ListHT.viewL x+          guard (phase >= 1 && Sig.lengthAtLeast (number ip) xs)+          return xs)+++{-* Interpolation of multiple values with various padding methods -}++{- | All values of frequency control must be non-negative. -}+multiRelative :: (RealField.C t) =>+   T t y -> t -> Sig.T y -> Sig.T t -> Sig.T y+multiRelative ip phase0 x0 =+   map (uncurry (func ip)) .+   scanl+      (\(phase,x) freq -> skip ip (phase + freq, x))+      (skip ip (phase0,x0))+++multiRelativeZeroPad :: (RealField.C t) =>+   y -> T t y -> t -> Sig.T t -> Sig.T y -> Sig.T y+multiRelativeZeroPad z ip phase fs x =+   zeroPad multiRelative z ip phase x fs++multiRelativeConstantPad :: (RealField.C t) =>+   T t y -> t -> Sig.T t -> Sig.T y -> Sig.T y+multiRelativeConstantPad ip phase fs x =+   constantPad multiRelative ip phase x fs++multiRelativeCyclicPad :: (RealField.C t) =>+   T t y -> t -> Sig.T t -> Sig.T y -> Sig.T y+multiRelativeCyclicPad ip phase fs x =+   cyclicPad multiRelative ip phase x fs++{- |+The extrapolation may miss some of the first and some of the last points+-}+multiRelativeExtrapolationPad :: (RealField.C t) =>+   T t y -> t -> Sig.T t -> Sig.T y -> Sig.T y+multiRelativeExtrapolationPad ip phase fs x =+   extrapolationPad multiRelative ip phase x fs+{-+  This example shows pikes, although there shouldn't be any:+   plotList (take 100 $ interpolate (Zero (0::Double)) ipCubic (-0.9::Double) (repeat 0.03) [1,0,1,0.8])+-}++{-* All-in-one interpolation functions -}++multiRelativeZeroPadConstant ::+   (RealField.C t, Additive.C y) => t -> Sig.T t -> Sig.T y -> Sig.T y+multiRelativeZeroPadConstant = multiRelativeZeroPad zero constant++multiRelativeZeroPadLinear ::+   (RealField.C t, Module.C t y) => t -> Sig.T t -> Sig.T y -> Sig.T y+multiRelativeZeroPadLinear = multiRelativeZeroPad zero linear++multiRelativeZeroPadCubic ::+   (RealField.C t, Module.C t y) => t -> Sig.T t -> Sig.T y -> Sig.T y+multiRelativeZeroPadCubic = multiRelativeZeroPad zero cubic
+ src/Synthesizer/Plain/LorenzAttractor.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE NoImplicitPrelude #-}+module Synthesizer.Plain.LorenzAttractor where++import qualified Algebra.Module as Module+import qualified Algebra.Ring   as Ring++import PreludeBase+import NumericPrelude+++computeDerivatives :: (Ring.C y) =>+   (y, y, y) -> (y, y, y) -> (y, y, y)+computeDerivatives (a,b,c) (x,y,z) =+   let x' = a*(y-x)+       y' = x*(b-z) - y+       z' = x*y -c*z+   in  (x',y',z')++explicitEuler :: (Module.C a v) =>+   a -> (v -> v) -> v -> [v]+explicitEuler h phi s =+   let ys = s : map (\y -> y + h *> phi y) ys+   in  ys+++equilibrium :: (Double, Double, Double)+equilibrium = (sqrt 72, sqrt 72, 27.001)++example0 :: [(Double, Double, Double)]+example0 =+   explicitEuler (0.01::Double)+      (computeDerivatives (10, 28, 8/3)) equilibrium++example :: [(Double, Double, Double)]+example =+   explicitEuler (0.01::Double)+      (computeDerivatives (10, 28, 8/3)) (8.5, 8.6, 27)
+ src/Synthesizer/Plain/Miscellaneous.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE NoImplicitPrelude #-}+module Synthesizer.Plain.Miscellaneous where++import qualified Algebra.NormedSpace.Euclidean as Euc+import qualified Algebra.Field                 as Field+-- import qualified Algebra.Ring                  as Ring+-- import qualified Algebra.Additive              as Additive++import qualified Prelude as P+import PreludeBase+import NumericPrelude+++{- * Spatial effects -}++{-| simulate an moving sounding object+   convert the way of the object through 3D space+   into a delay and attenuation information,+   sonicDelay is the reciprocal of the sonic velocity -}+receive3Dsound :: (Field.C a, Euc.C a v) => a -> a -> v -> [v] -> ([a],[a])+receive3Dsound att sonicDelay ear way =+   let dists   = map (Euc.norm) (map (subtract ear) way)+       phase   = map (sonicDelay*) dists+       volumes = map (\x -> 1/(att+x)^2) dists+   in  (phase, volumes)
+ src/Synthesizer/Plain/Modifier.hs view
@@ -0,0 +1,134 @@+{- |+Support for stateful modifiers like controlled filters.+This is similar to "Synthesizer.Causal.Process"+but we cannot replace the Modifier structure by the Causal structure+because the Modifier structure exhibits the state+which allows stacking of modifiers+using an efficient storage for the stacked state.+More precisely, because Modifiers exhibits the type of the state,+we can ensure that the state type of several modifiers is equal+and thus the individual states can be stored in an array or a StorableVector.+-}+module Synthesizer.Plain.Modifier where++import Control.Monad.Trans.State (State, state, runState, evalState, )+import Control.Monad (zipWithM, )++import qualified Data.StorableVector as SV+import Foreign.Storable (Storable(..))++import qualified Data.List as List++import Prelude hiding (init)+++-- Signal.T, re-defined here in order to avoid module cycle+type T a = [a]+++data Simple s ctrl a b =+   Simple {+      init :: s,+      step :: ctrl -> a -> State s b+   }++{-|+modif is a process controlled by values of type c+with an internal state of type s,+it converts an input value of type a into an output value of type b+while turning into a new state++ToDo:+Shall finite signals be padded with zeros?+-}+static ::+   Simple s ctrl a b -> ctrl -> T a -> T b+static modif control x =+   evalState (mapM (step modif control) x) (init modif)++{-| Here the control may vary over the time. -}+modulated ::+   Simple s ctrl a b -> T ctrl -> T a -> T b+modulated modif control x =+   evalState (zipWithM (step modif) control x) (init modif)+++data Initialized s init ctrl a b =+   Initialized {+      initInit :: init -> s,+      initStep :: ctrl -> a -> State s b+   }+++initialize ::+   Initialized s init ctrl a b -> init -> Simple s ctrl a b+initialize modif stateInit =+   Simple (initInit modif stateInit) (initStep modif)++staticInit ::+   Initialized s init ctrl a b -> init -> ctrl -> T a -> T b+staticInit modif state_ =+   static (initialize modif state_)++{-| Here the control may vary over the time. -}+modulatedInit ::+   Initialized s init ctrl a b -> init -> T ctrl -> T a -> T b+modulatedInit modif state_ =+   modulated (initialize modif state_)++++{- |+The number of stacked state monads+depends on the size of the list of state values.+This is like a dynamically nested StateT.+-}+stackStatesR :: (a -> State s a) -> (a -> State [s] a)+stackStatesR m =+   state . List.mapAccumR (runState . m)++stackStatesL :: (a -> State s a) -> (a -> State [s] a)+stackStatesL m =+   state . List.mapAccumL (runState . m)+++{-# INLINE stackStatesStorableR #-}+stackStatesStorableR :: (Storable s) =>+   (a -> State s a) -> (a -> State (SV.Vector s) a)+stackStatesStorableR m =+   state . SV.mapAccumR (runState . m)++{-# INLINE stackStatesStorableL #-}+stackStatesStorableL :: (Storable s) =>+   (a -> State s a) -> (a -> State (SV.Vector s) a)+stackStatesStorableL m =+   state . SV.mapAccumL (runState . m)+++{-+{-# INLINE stackStatesStorableVaryR #-}+stackStatesStorableVaryR :: (Storable s, Storable c) =>+   (c -> a -> State s a) -> (SV.Vector c -> a -> State (SV.Vector s) a)+stackStatesStorableVaryR m cv a =+   State . SV.mapAccumL (runState . m)+-}++{-# INLINE stackStatesStorableVaryL #-}+stackStatesStorableVaryL :: (Storable s, Storable c) =>+   (c -> a -> State s a) -> (SV.Vector c -> a -> State (SV.Vector s) a)+stackStatesStorableVaryL m cv a = state $ \sv ->+   -- emulate SV.zipWith with minimal use of Storable functionality+   let (svFinal, mcsa) =+          SV.unfoldrN (SV.length sv)+             (\(cv0,sv0,a0) ->+                  do (c,cv1) <- SV.viewL cv0+                     (s,sv1) <- SV.viewL sv0+                     let (a1,sNew) = runState (m c a0) s+                     return (sNew,(cv1,sv1,a1)))+             (cv,sv,a)+   in  (case mcsa of+           Just (_, _, aFinal) -> aFinal+           _ -> error $ "Modifier: control vector too short - "+                   ++ "status size " ++ show (SV.length sv) ++ " vs. "+                   ++ "control size " ++ show (SV.length cv),+        svFinal)
+ src/Synthesizer/Plain/Noise.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE NoImplicitPrelude #-}+{- | Noise and random processes. -}+module Synthesizer.Plain.Noise where++import qualified Synthesizer.Plain.Signal as Sig++import qualified Algebra.Real                  as Real+import qualified Algebra.Ring                  as Ring++import System.Random (Random, RandomGen, randomRs, mkStdGen, )++import Data.List.HT (sliceVertical, )++import qualified Prelude as P+import PreludeBase+import NumericPrelude+++{-|+Deterministic white noise, uniformly distributed between -1 and 1.+That is, variance is 1\/3.+-}+white :: (Ring.C y, Random y) =>+   Sig.T y+white = whiteGen (mkStdGen 12354)++whiteGen :: (Ring.C y, Random y, RandomGen g) =>+   g -> Sig.T y+whiteGen = randomRs (-1,1)++{- |+Approximates normal distribution with variance 1+by a quadratic B-spline distribution.+-}+whiteQuadraticBSplineGen :: (Ring.C y, Random y, RandomGen g) =>+   g -> Sig.T y+whiteQuadraticBSplineGen =+   map sum . sliceVertical 3 . randomRs (-1,1)+++randomPeeks :: (Real.C y, Random y) =>+      Sig.T y    {- ^ momentary densities, @p@ means that there is about one peak+                      in the time range of @1\/p@ samples -}+   -> Sig.T Bool {- ^ Every occurence of 'True' represents a peak. -}+randomPeeks =+   randomPeeksGen (mkStdGen 876)++randomPeeksGen :: (Real.C y, Random y, RandomGen g) =>+      g+   -> Sig.T y+   -> Sig.T Bool+randomPeeksGen =+   zipWith (<) . randomRs (0,1)
+ src/Synthesizer/Plain/Oscillator.hs view
@@ -0,0 +1,235 @@+{-# LANGUAGE NoImplicitPrelude #-}+{- |+Copyright   :  (c) Henning Thielemann 2006+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes++Tone generators++Frequencies are always specified in ratios of the sample rate,+e.g. the frequency 0.01 for the sample rate 44100 Hz+means a physical frequency of 441 Hz.+-}+module Synthesizer.Plain.Oscillator where++import qualified Synthesizer.Plain.ToneModulation as ToneMod+import qualified Synthesizer.Basic.Wave as Wave+import qualified Synthesizer.Basic.Phase as Phase+import qualified Synthesizer.Plain.Interpolation as Interpolation+import qualified Synthesizer.Plain.Signal as Sig++import Synthesizer.Plain.ToneModulation (freqsToPhases, )++{-+import qualified Algebra.RealTranscendental    as RealTrans+import qualified Algebra.Module                as Module+import qualified Algebra.VectorSpace           as VectorSpace++import Algebra.Module((*>))+-}+import qualified Algebra.Transcendental        as Trans+import qualified Algebra.RealField             as RealField+-- import qualified Algebra.Field                 as Field+import qualified Algebra.Ring                  as Ring+import qualified Algebra.Additive              as Additive++-- import qualified Number.NonNegative       as NonNeg++import Data.Tuple.HT (mapFst, mapSnd, )++import NumericPrelude++-- import qualified Prelude as P+import PreludeBase+++type Phase a = a+++{- * Oscillators with arbitrary but constant waveforms -}++{- | oscillator with constant frequency -}+static :: (RealField.C a) => Wave.T a b -> (Phase a -> a -> Sig.T b)+static wave phase freq =+    map (Wave.apply wave)+        (iterate (Phase.increment freq) (Phase.fromRepresentative phase))++{- | oscillator with modulated frequency -}+freqMod :: (RealField.C a) => Wave.T a b -> Phase a -> Sig.T a -> Sig.T b+freqMod wave phase freqs =+    map (Wave.apply wave)+        (freqsToPhases (Phase.fromRepresentative phase) freqs)++{- | oscillator with modulated phase -}+phaseMod :: (RealField.C a) => Wave.T a b -> a -> Sig.T (Phase a) -> Sig.T b+phaseMod wave freq phases =+    map (Wave.apply wave) $+    zipWith Phase.increment phases (iterate (Phase.increment freq) zero)++{- | oscillator with modulated shape -}+shapeMod :: (RealField.C a) => (c -> Wave.T a b) -> (Phase a) -> a -> Sig.T c -> Sig.T b+shapeMod wave phase freq parameters =+    zipWith (Wave.apply . wave) parameters $+    iterate (Phase.increment freq) (Phase.fromRepresentative phase)++{- | oscillator with both phase and frequency modulation -}+phaseFreqMod :: (RealField.C a) => Wave.T a b -> Sig.T (Phase a) -> Sig.T a -> Sig.T b+phaseFreqMod wave phases freqs =+    map (Wave.apply wave)+        (zipWith Phase.increment phases (freqsToPhases zero freqs))++{- | oscillator with both shape and frequency modulation -}+shapeFreqMod :: (RealField.C a) => (c -> Wave.T a b) -> Phase a -> Sig.T c -> Sig.T a -> Sig.T b+shapeFreqMod wave phase parameters freqs =+    zipWith (Wave.apply . wave) parameters $+    freqsToPhases (Phase.fromRepresentative phase) freqs+++{- | oscillator with a sampled waveform with constant frequency+     This is essentially an interpolation with cyclic padding. -}+staticSample :: RealField.C a => Interpolation.T a b -> [b] -> Phase a -> a -> Sig.T b+staticSample ip wave phase freq =+    freqModSample ip wave phase (repeat freq)++{- | oscillator with a sampled waveform with modulated frequency+     Should behave homogenously for different types of interpolation. -}+freqModSample :: RealField.C a => Interpolation.T a b -> [b] -> Phase a -> Sig.T a -> Sig.T b+freqModSample ip wave phase freqs =+    let len = fromIntegral (length wave)+    in  Interpolation.multiRelativeCyclicPad+           ip (phase*len) (map (len*) freqs) wave++{- |+Shape control is a list of relative changes,+each of which must be non-negative in order to allow lazy processing.+'1' advances by one wave.+Frequency control can be negative.+If you want to use sampled waveforms as well+then use 'Wave.sample' in the list of waveforms.+With sampled waves this function is identical to HunkTranspose in Assampler.++Example: interpolate different versions+of 'Wave.oddCosine' and 'Wave.oddTriangle'.++You could also chop a tone into single waves+and use the waves as input for this function+but you certainly want to use+'Wave.sampledTone' or 'shapeFreqModFromSampledTone' instead,+because in the wave information for 'shapeFreqModSample'+shape and phase are strictly separated.+-}+shapeFreqModSample :: (RealField.C c, RealField.C b) =>+    Interpolation.T c (Wave.T b a) -> [Wave.T b a] -> c -> Phase b -> Sig.T c -> Sig.T b -> Sig.T a+shapeFreqModSample ip waves shape0 phase shapes freqs =+    zipWith Wave.apply+       (Interpolation.multiRelativeConstantPad ip shape0 shapes waves)+       (freqsToPhases (Phase.fromRepresentative phase) freqs)+{-+GNUPlot.plotList [] $ take 500 $ shapeFreqModSample Interpolation.cubic (map Wave.truncOddCosine [0..3]) (0.1::Double) (0::Double) (repeat 0.005) (repeat 0.02)+-}++shapePhaseFreqModSample :: (RealField.C c, RealField.C b) =>+    Interpolation.T c (Wave.T b a) -> [Wave.T b a] -> c -> Sig.T c -> Sig.T (Phase b) -> Sig.T b -> Sig.T a+shapePhaseFreqModSample ip waves shape0 shapes phases freqs =+    zipWith Wave.apply+       (Interpolation.multiRelativeConstantPad ip shape0 shapes waves)+       (zipWith Phase.increment phases (freqsToPhases zero freqs))++{- |+Time stretching and frequency modulation of a pure tone.++We consider a tone as the result of a shape modulated oscillator,+and virtually reconstruct the waveform function+(a function of time and phase) by interpolation and resample it.+This way we can alter frequency and time progress of the tone independently.++This function is identical to using 'shapeFreqMod'+with a wave function constructed by 'Wave.sampledTone'+but it consumes the sampled source tone lazily+and thus allows only relative shape control with non-negative control steps.++The function is similar to 'shapeFreqModSample' but respects+that in a sampled tone, phase and shape control advance synchronously.+Actually we could re-use 'shapeFreqModSample' with modified phase values.+But we would have to cope with negative shape control jumps,+and waves would be padded locally cyclically.+The latter one is not wanted+since we want padding according to the adjacencies in the source tone.+Note that differently from 'shapeFreqModSample'+the shape control difference @1@ does not mean to skip to the next wave,+since this oscillator has no discrete waveforms.+Instead @1@ means that the shape alters as fast as in the prototype signal.++Although the shape difference values must be non-negative+I hesitate to give them the type @Number.NonNegative.T t@+because then you cannot call this function with other types+of non-negative numbers like 'Number.NonNegativeChunky.T'.++The prototype tone signal is reproduced if+@freqs == repeat (1\/period)@ and @shapes == repeat 1@.+-}+shapeFreqModFromSampledTone :: (RealField.C t) =>+    Interpolation.T t y ->+    Interpolation.T t y ->+    t -> Sig.T y -> t -> t -> Sig.T t -> Sig.T t -> Sig.T y+shapeFreqModFromSampledTone+      ipLeap ipStep period sampledTone+      shape0 phase shapes freqs =+   let periodInt = round period+   in  map+          (uncurry (ToneMod.interpolateCell ipLeap ipStep))+          (ToneMod.oscillatorCells+              (Interpolation.margin ipLeap) (Interpolation.margin ipStep)+              periodInt period sampledTone+              (shape0, shapes) (Phase.fromRepresentative phase, freqs))+{-+GNUPlot.plotList [] $ take 1000 $ shapeFreqModFromSampledTone Interpolation.linear Interpolation.linear (1/0.07::Double) (staticSine (0::Double) 0.07) 0 0 (repeat 0.1) (repeat 0.01)+GNUPlot.plotList [] $ take 1000 $ shapeFreqModFromSampledTone Interpolation.linear Interpolation.linear (1/0.07::Double) (staticSine (0::Double) 0.07) 0 0 (repeat 0.1) (iterate (*(1-2e-3)) 0.01)+GNUPlot.plotList [] $ take 101 $ shapeFreqModFromSampledTone Interpolation.linear Interpolation.linear (1/0.07::Double) (iterate (1+) (0::Double)) 0 0 (repeat 1) (repeat 0.7)+-}++shapePhaseFreqModFromSampledTone :: (RealField.C t) =>+    Interpolation.T t y ->+    Interpolation.T t y ->+    t -> Sig.T y -> t -> t -> Sig.T t -> Sig.T t -> Sig.T t -> Sig.T y+shapePhaseFreqModFromSampledTone+      ipLeap ipStep period sampledTone+      shape0 phase shapes phases freqs =+   let periodInt = round period+       marginLeap = Interpolation.margin ipLeap+       marginStep = Interpolation.margin ipStep+   in  map+          (uncurry (ToneMod.interpolateCell ipLeap ipStep) .+           ToneMod.seekCell periodInt period) $+       zipWith (\p -> mapFst (mapSnd (Phase.increment p))) phases $+       ToneMod.oscillatorSuffixes+          marginLeap marginStep+          periodInt period sampledTone+          (shape0, shapes)+          (Phase.fromRepresentative phase, freqs)+++{- * Oscillators with specific waveforms -}++{- | sine oscillator with static frequency -}+staticSine :: (Trans.C a, RealField.C a) => a -> a -> Sig.T a+staticSine = static Wave.sine++{- | sine oscillator with modulated frequency -}+freqModSine :: (Trans.C a, RealField.C a) => a -> Sig.T a -> Sig.T a+freqModSine = freqMod Wave.sine++{- | sine oscillator with modulated phase, useful for FM synthesis -}+phaseModSine :: (Trans.C a, RealField.C a) => a -> Sig.T a -> Sig.T a+phaseModSine = phaseMod Wave.sine++{- | saw tooth oscillator with modulated frequency -}+staticSaw :: RealField.C a => a -> a -> Sig.T a+staticSaw = static Wave.saw++{- | saw tooth oscillator with modulated frequency -}+freqModSaw :: RealField.C a => a -> Sig.T a -> Sig.T a+freqModSaw = freqMod Wave.saw
+ src/Synthesizer/Plain/Play.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE NoImplicitPrelude #-}+module Synthesizer.Plain.Play where++import qualified Synthesizer.Plain.Builder as Builder+import qualified Synthesizer.Basic.Binary as BinSmp++import qualified Sound.Sox.Frame as Frame+import qualified Sound.Sox.Frame.Stereo as Stereo+import qualified Sound.Sox.Option.Format as SoxOpt+import qualified Sound.Sox.Play as Play+import qualified Sound.Sox.Signal.List as SoxList++import Foreign.Storable (Storable, )+import Data.Int (Int16, )++import Data.Monoid (mconcat, )++-- import qualified Synthesizer.Frame.Stereo as Stereo++import qualified Algebra.ToInteger as ToInteger+import qualified Algebra.RealField as RealField++import System.Exit (ExitCode, )++import PreludeBase+import NumericPrelude+++{- |+See 'Synthesizer.Plain.File.write'.+-}+render ::+   (Storable int, Frame.C int, ToInteger.C int, Bounded int,+    RealField.C a, BinSmp.C v) =>+   Builder.Put int -> a -> (a -> [v]) -> IO ExitCode+render put sampleRate renderer =+   auto put sampleRate (renderer sampleRate)++renderToInt16 :: (RealField.C a, BinSmp.C v) => a -> (a -> [v]) -> IO ExitCode+renderToInt16 sampleRate renderer =+   toInt16 sampleRate (renderer sampleRate)++renderMonoToInt16 :: (RealField.C a) => a -> (a -> [a]) -> IO ExitCode+renderMonoToInt16 sampleRate renderer =+   monoToInt16 sampleRate (renderer sampleRate)++renderStereoToInt16 :: (RealField.C a) => a -> (a -> [(a,a)]) -> IO ExitCode+renderStereoToInt16 sampleRate renderer =+   stereoToInt16 sampleRate (renderer sampleRate)+++{- |+See 'Synthesizer.Plain.File.write'.+-}+auto ::+   (Storable int, Frame.C int, ToInteger.C int, Bounded int,+    RealField.C a, BinSmp.C v) =>+   Builder.Put int -> a -> [v] -> IO ExitCode+auto put sampleRate signal =+   raw+      (SoxOpt.numberOfChannels (BinSmp.numberOfSignalChannels signal))+      sampleRate+      (Builder.run . mconcat . map (BinSmp.outputFromCanonical put) $+       signal)++toInt16 :: (RealField.C a, BinSmp.C v) => a -> [v] -> IO ExitCode+toInt16 =+   auto (Builder.put :: Builder.Put Int16)++monoToInt16 :: (RealField.C a) => a -> [a] -> IO ExitCode+monoToInt16 sampleRate signal =+   raw SoxOpt.none sampleRate+      (map BinSmp.int16FromCanonical signal)++stereoToInt16 :: (RealField.C a) => a -> [(a,a)] -> IO ExitCode+stereoToInt16 sampleRate signal =+   raw SoxOpt.none sampleRate+      (map (fmap BinSmp.int16FromCanonical . uncurry Stereo.cons) signal)+++raw :: (RealField.C a, Frame.C v, Storable v) =>+   SoxOpt.T -> a -> [v] -> IO ExitCode+raw opts sampleRate signal =+   Play.extended SoxList.put opts SoxOpt.none (round sampleRate) signal+++exampleMono :: IO ExitCode+exampleMono =+   monoToInt16 (11025::Double) (map sin [0::Double,0.2..])++exampleStereo :: IO ExitCode+exampleStereo =+   stereoToInt16 (11025::Double) $+      zip+         (map sin [0::Double,0.199..])+         (map sin [0::Double,0.201..])
+ src/Synthesizer/Plain/Signal.hs view
@@ -0,0 +1,208 @@+{-# OPTIONS_GHC -fglasgow-exts #-}+{- glasgow-exts are for the rules -}+{- |+Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  portable+-}+module Synthesizer.Plain.Signal where++import qualified Number.Peano as Peano++import qualified Synthesizer.Plain.Modifier as Modifier++import qualified Data.List.Match as ListMatch+import qualified Data.List       as List++import Data.Tuple.HT (forcePair, mapFst, mapSnd, )+++type T a = [a]+++{- * Generic routines that are useful for filters -}++type Modifier s ctrl a b = Modifier.Simple s ctrl a b++{-|+modif is a process controlled by values of type c+with an internal state of type s,+it converts an input value of type a into an output value of type b+while turning into a new state++ToDo:+Shall finite signals be padded with zeros?+-}+modifyStatic ::+   Modifier s ctrl a b -> ctrl -> T a -> T b+modifyStatic = Modifier.static++{-| Here the control may vary over the time. -}+modifyModulated ::+   Modifier s ctrl a b -> T ctrl -> T a -> T b+modifyModulated = Modifier.modulated+++type ModifierInit s init ctrl a b = Modifier.Initialized s init ctrl a b+++modifierInitialize ::+   ModifierInit s init ctrl a b -> init -> Modifier s ctrl a b+modifierInitialize = Modifier.initialize++modifyStaticInit ::+   ModifierInit s init ctrl a b -> init -> ctrl -> T a -> T b+modifyStaticInit = Modifier.staticInit++{-| Here the control may vary over the time. -}+modifyModulatedInit ::+   ModifierInit s init ctrl a b -> init -> T ctrl -> T a -> T b+modifyModulatedInit = Modifier.modulatedInit++++unfoldR :: (acc -> Maybe (y, acc)) -> acc -> (acc, T y)+unfoldR f =+   let recourse acc0 =+          forcePair $+          maybe+             (acc0,[])+             (\(y,acc1) ->+                mapSnd (y:) $ recourse acc1)+             (f acc0)+   in  recourse++reduceL :: (x -> acc -> Maybe acc) -> acc -> T x -> acc+reduceL f =+   let recourse a xt =+          case xt of+             [] -> a+             (x:xs) ->+                maybe a+                   (\ a' -> seq a' (recourse a' xs))+                   (f x a)+   in  recourse++mapAccumL :: (x -> acc -> Maybe (y, acc)) -> acc -> T x -> (acc, T y)+mapAccumL f =+   let recourse acc0 xt =+          forcePair $+          case xt of+             [] -> (acc0,[])+             (x:xs) ->+                 maybe+                    (acc0,[])+                    (\(y,acc1) ->+                       mapSnd (y:) $ recourse acc1 xs)+                    (f x acc0)+   in  recourse++crochetL :: (x -> acc -> Maybe (y, acc)) -> acc -> T x -> T y+crochetL f a = snd . mapAccumL f a+++{- |+Feed back signal into signal processor,+and apply a delay by one value.+'fix1' is a kind of 'Signal.generate'.+-}+fix1 :: y -> (T y -> T y) -> T y+fix1 pad f =+   let y = f (pad:y)+   in  y++{-# RULES+  "fix1/crochetL" forall f a b.+     fix1 a (crochetL f b) =+        snd $ unfoldR (\(a0,b0) ->+            do yb1@(y0,_) <- f a0 b0+               return (y0, yb1)) (a,b) ;+  #-}++++{-+instance SigG.Data [] y where++instance SigG.C [] where+   add = (Additive.+)+   map = List.map+   zipWith = List.zipWith+-}+++{- |+@dropMarginRem n m xs@+drops at most the first @m@ elements of @xs@+and ensures that @xs@ still contains @n@ elements.+Additionally returns the number of elements that could not be dropped+due to the margin constraint.+That is @dropMarginRem n m xs == (k,ys)@ implies @length xs - m == length ys - k@.+Requires @length xs >= n@.+-}+dropMarginRem :: Int -> Int -> T a -> (Int, T a)+dropMarginRem n m =+   head .+   dropMargin n m .+   zipWithTails (,) (iterate pred m)++dropMargin :: Int -> Int -> T a -> T a+dropMargin n m xs =+   ListMatch.drop (take m (drop n xs)) xs+++{- |+Test whether a list has at least @n@ elements.+-}+lengthAtLeast :: Int -> T a -> Bool+lengthAtLeast n xs =+   n<=0 || not (null (drop (n-1) xs))+++{- |+Can be implemented more efficiently+than just by 'zipWith' and 'List.tails'+for other data structures.+-}+zipWithTails ::+   (y0 -> T y1 -> y2) -> T y0 -> T y1 -> T y2+zipWithTails f xs =+   zipWith f xs . init . List.tails++zipWithRest ::+   (y0 -> y0 -> y1) ->+   T y0 -> T y0 ->+   (T y1, (Bool, T y0))+zipWithRest f xs ys =+   let len = min (List.genericLength xs) (List.genericLength ys) :: Peano.T+       (prefixX,suffixX) = List.genericSplitAt len xs+       (prefixY,suffixY) = List.genericSplitAt len ys+       second = null suffixX+   in  (zipWith f prefixX prefixY,+        (second, if second then suffixY else suffixX))++zipWithRest' ::+   (y0 -> y0 -> y1) ->+   T y0 -> T y0 ->+   (T y1, (Bool, T y0))+zipWithRest' f =+   let recourse xt yt =+          forcePair $+          case (xt,yt) of+             (x:xs, y:ys) ->+                mapFst (f x y :) (recourse xs ys)+             ([], _) -> ([], (True,  yt))+             (_, []) -> ([], (False, xt))+   in  recourse+{-+Test.QuickCheck.test (\xs ys -> zipWithRest (,) xs ys == zipWithRest' (,) xs (ys::[Int]))+-}++zipWithAppend ::+   (y -> y -> y) ->+   T y -> T y -> T y+zipWithAppend f xs ys =+   uncurry (++) $ mapSnd snd $ zipWithRest f xs ys
+ src/Synthesizer/Plain/ToneModulation.hs view
@@ -0,0 +1,413 @@+{-# LANGUAGE NoImplicitPrelude #-}+{- |+Copyright   :  (c) Henning Thielemann 2006+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes+++Avoid importing this module.+Better use functions from+"Synthesizer.Plain.Oscillator" and+"Synthesizer.Basic.Wave"++Input data is interpreted as samples of data on a cylinder+in the following form:++> |*          |+> |   *       |+> |      *    |+> |         * |+> | *         |+> |    *      |+> |       *   |+> |          *|+> |  *        |+> |     *     |+> |        *  |+++> -----------+> *+>     *+>         *+>  *+>      *+>          *+>   *+>       *+>           *+>    *+>        *+> -----------++We have to interpolate in the parallelograms.++-}+module Synthesizer.Plain.ToneModulation where++import qualified Synthesizer.Basic.ToneModulation as ToneMod+import qualified Synthesizer.Basic.Phase as Phase++import qualified Synthesizer.Plain.Signal as Sig+import qualified Synthesizer.Plain.Interpolation as Interpolation+import Synthesizer.Interpolation (Margin, )+-- import qualified Data.Array as Array+import Data.Array (Array, (!), listArray, )++-- import qualified Algebra.Transcendental        as Trans+import qualified Algebra.RealField             as RealField+import qualified Algebra.Field                 as Field+-- import qualified Algebra.Real                  as Real+import qualified Algebra.Ring                  as Ring+import qualified Algebra.Additive              as Additive++import qualified Number.NonNegative       as NonNeg+import qualified Number.NonNegativeChunky as Chunky++import Control.Monad (guard, )++import qualified Data.List       as List+import qualified Data.List.HT    as ListHT+import qualified Data.List.Match as ListMatch+import Data.Ord.HT (limit, )+import Data.Tuple.HT (mapPair, mapSnd, forcePair, )++import NumericPrelude++-- import qualified Prelude as P+import PreludeBase++++-- * general helpers++type Cell y = Sig.T (Sig.T y)++interpolateCell ::+   Interpolation.T a y ->+   Interpolation.T b y ->+   (a, b) ->+   Cell y -> y+interpolateCell ipLeap ipStep (qLeap,qStep) =+   Interpolation.func ipStep qStep .+   map (Interpolation.func ipLeap qLeap)+++-- * array based shape variable wave++data Prototype t y =+   Prototype {+      protoMarginLeap,+      protoMarginStep  :: Margin,+      protoIpOffset    :: Int,+      protoPeriod      :: t,+      protoPeriodInt   :: Int,+      protoShapeLimits :: (t,t),+      protoArray       :: Array Int y+   }+++makePrototype :: (RealField.C t) =>+   Margin ->+   Margin ->+   Int -> t -> Sig.T y -> Prototype t y+makePrototype marginLeap marginStep periodInt period tone =+   let ipOffset =+          ToneMod.interpolationOffset marginLeap marginStep periodInt+       len = length tone+       (lower,upper) =+          ToneMod.shapeLimits marginLeap marginStep periodInt len+       limits =+          if lower > upper+            then error "min>max"+            else+              (fromIntegral lower, fromIntegral upper)++       arr = listArray (0, pred len) tone++   in  Prototype {+          protoMarginLeap  = marginLeap,+          protoMarginStep  = marginStep,+          protoIpOffset    = ipOffset,+          protoPeriod      = period,+          protoPeriodInt   = periodInt,+          protoShapeLimits = limits,+          protoArray       = arr+       }++sampledToneCell :: (RealField.C t) =>+   Prototype t y -> t -> Phase.T t -> ((t,t), Cell y)+sampledToneCell p shape phase =+   let (n, q) =+          ToneMod.flattenShapePhase (protoPeriodInt p) (protoPeriod p)+             (limit (protoShapeLimits p) shape, phase)+   in  (q,+        map (map (protoArray p ! ) . iterate (protoPeriodInt p +)) $+        enumFrom (n - protoIpOffset p))+++{-+  M = ((1,1)^T, (periodRound, period-periodRound)^T)++  equation for the line+   0 = (nStep - offset ipStep) ++       (nLeap - offset ipLeap) * periodInt++   <(1,periodInt), (offset ipStep, offset ipLeap)>+        = <(1,periodInt), (nStep,nLeap)>+   d = <a,x>+     = <a,M^-1*M*x>+     = <(M^-T)*a,M*x>+     = <(M^-T)*a,y>+   b = (M^-T)*a+   required:+      y0 such that y1=0+      y0 such that y1=period++   The line {x : d = <a,x>} converted to (shape,phase) coordinates+   has constant shape and meets all phases.+-}++++-- * lazy oscillator+++oscillatorCells :: (RealField.C t) =>+    Margin ->+    Margin ->+    Int -> t ->+    Sig.T y -> (t, Sig.T t) -> (Phase.T t, Sig.T t) -> Sig.T ((t,t), Cell y)+oscillatorCells+       marginLeap marginStep periodInt period sampledTone shapes freqs =+    map (seekCell periodInt period) $+    oscillatorSuffixes+        marginLeap marginStep periodInt period sampledTone shapes freqs++seekCell :: (RealField.C t) =>+    Int -> t ->+    ((t, Phase.T t), Cell y) -> ((t,t), Cell y)+seekCell periodInt period =+    {- n will be zero within the data.+       We would need it only for extrapolation at the end.+       But this does not happen, since we limit the shape control parameter accordingly.+    -}+    (\(coords, ptr) ->+       let (k,q) = ToneMod.flattenShapePhase periodInt period coords+       in  if k>0+             then error "ToneModulation.oscillatorCells: k>0"+             else (q, drop (periodInt+k) ptr))++oscillatorSuffixes :: (RealField.C t) =>+    Margin ->+    Margin ->+    Int -> t -> Sig.T y ->+    (t, Sig.T t) -> (Phase.T t, Sig.T t) ->+    Sig.T ((t, Phase.T t), Cell y)+oscillatorSuffixes+       marginLeap marginStep periodInt period sampledTone shapes freqs =+    let ptrs =+           List.transpose $+           takeWhile (not . null) $+           iterate (drop periodInt) sampledTone+        ipOffset =+           periodInt ++           ToneMod.interpolationOffset marginLeap marginStep periodInt+{- I tried to switch integrateFractional and limitRelativeShapes+   in order to have a position where I can easily add phase distortion.+   However, limitting skip values after integrateFractional+   does not work this way, since once we start setting skip values to zero,+   we had to clear the fractional parts of the shape coordinate, too.+        (firstSkip:allSkips,coords) =+           unzip $+           integrateFractional period shapes freqs+        (skip,skips) =+           limitRelativeShapes marginLeap marginStep+              periodInt sampledTone (firstSkip,allSkips)+-}+        (skip:skips,coords) =+           unzip $+           integrateFractional period+              (limitRelativeShapes marginLeap marginStep periodInt sampledTone shapes)+              freqs+    in  zip coords $+        map (\(n,ptr) ->+               if n>0+                 then error $ "ToneModulation.oscillatorCells: " +++                              "limit of shape parameter is buggy"+                 else ptr) $+        tail $+        scanl+           {- since we clip the coordinates before calling oscillatorCells+              we do not need 'dropRem', since 'drop' would never go beyond the list end -}+           (\ (n,ptr0) d0 -> dropRem (n+d0) ptr0)+           (0,ptrs)+           ((skip - ipOffset) : skips)++dropFrac :: RealField.C i => i -> Sig.T a -> (Int, i, Sig.T a)+dropFrac =+   let recourse acc n xt =+          if n>=1+            then+               case xt of+                  _:xs -> recourse (succ acc) (n-1) xs+                  [] -> (acc, n, [])+            else (acc,n,xt)+   in  recourse 0++dropFrac' :: RealField.C i => i -> Sig.T a -> (Int, i, Sig.T a)+dropFrac' =+   let recourse acc n xt =+          maybe+             (acc,n,xt)+             (recourse (succ acc) (n-1) . snd)+             (guard (n>=1) >> ListHT.viewL xt)+   in  recourse 0++propDropFrac :: (RealField.C i, Eq a) => i -> Sig.T a -> Bool+propDropFrac n xs =+   dropFrac n xs == dropFrac' n xs++++dropRem :: Int -> Sig.T a -> (Int, Sig.T a)+dropRem =+   let recourse n xt =+          if n>0+            then+               case xt of+                  _:xs -> recourse (pred n) xs+                  [] -> (n, [])+            else (n,xt)+   in  recourse++dropRem' :: Int -> Sig.T a -> (Int, Sig.T a)+dropRem' =+   let recourse n xt =+          maybe+             (n,xt)+             (recourse (pred n) . snd)+             (guard (n>0) >> ListHT.viewL xt)+   in  recourse++propDropRem :: (Eq a) => Int -> Sig.T a -> Bool+propDropRem n xs =+   dropRem n xs == dropRem' n xs++{-+*Synthesizer.Plain.ToneModulation> Test.QuickCheck.quickCheck (\n xs -> propDropRem n (xs::[Int]))+OK, passed 100 tests.+*Synthesizer.Plain.ToneModulation> Test.QuickCheck.quickCheck (\n xs -> propDropFrac (n::Rational) (xs::[Int]))+OK, passed 100 tests.+-}+++oscillatorCoords :: (RealField.C t) =>+    Int -> t -> (t, Sig.T t) -> (Phase.T t, Sig.T t) -> Sig.T (ToneMod.Coords t)+oscillatorCoords periodInt period shapes freqs =+   map (mapSnd (ToneMod.flattenShapePhase periodInt period)) $+   integrateFractional period shapes freqs+{-+mapM print $ take 30 $ let period = 1/0.07::Double in oscillatorCoords (round period) period 0 0 (repeat 0.1) (repeat 0.01)++*Synthesizer.Plain.Oscillator> mapM print $ take 30 $ let period = 1/0.07::Rational in oscillatorCoords (round period) period 0 0 (repeat 1) (repeat 0.07)++*Synthesizer.Plain.Oscillator> mapM print $ take 30 $ let period = 1/0.07::Rational in oscillatorCoords (round period) period 0 0 (repeat 0.25) (repeat 0.0175)+-}+++integrateFractional :: (RealField.C t) =>+    t -> (t, Sig.T t) -> (Phase.T t, Sig.T t) -> Sig.T (ToneMod.Skip t)+integrateFractional period (shape0, shapes) (phase, freqs) =+    let shapeOffsets =+           scanl+              (\(_,s) c -> splitFraction (s+c))+              (splitFraction shape0) shapes+        phases =+           let (s:ss) = map (\(n,_) -> fromIntegral n / period) shapeOffsets+           in  freqsToPhases+                  (Phase.decrement s phase)  -- phase - s+                  (zipWith (-) freqs ss)+    in  zipWith+           (\(d,s) p -> (d, (s,p)))+           shapeOffsets+           phases+++-- this function fits better in the Oscillator module+{- |+Convert a list of phase steps into a list of momentum phases+phase is a number in the interval [0,1)+freq contains the phase steps+-}+freqsToPhases :: RealField.C a => Phase.T a -> Sig.T a -> Sig.T (Phase.T a)+freqsToPhases phase freq = scanl (flip Phase.increment) phase freq++++limitRelativeShapes :: (Ring.C t, Ord t) =>+    Margin ->+    Margin ->+    Int -> Sig.T y -> (t, Sig.T t) -> (t, Sig.T t)+limitRelativeShapes marginLeap marginStep periodInt sampledTone =+    let -- len = List.genericLength sampledTone+        len = Chunky.fromChunks (ListMatch.replicate sampledTone one)+        (minShape, maxShape) =+           ToneMod.shapeLimits marginLeap marginStep periodInt len+        fromChunky = NonNeg.toNumber   . Chunky.toNumber+        toChunky   = Chunky.fromNumber . NonNeg.fromNumber+    in  mapPair (fromChunky, map fromChunky) .+        uncurry (limitMaxRelativeValuesNonNeg maxShape) .+        mapPair (toChunky, map toChunky) .+        uncurry (limitMinRelativeValues (fromChunky minShape))+{-+*Synthesizer.Plain.Oscillator> let ip = Interpolation.linear in limitRelativeShapes ip ip 13 (take 100 $ iterate (1+) (0::Double)) (0::Double, cycle [0.5,1.5])+(13.0,[0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,1.0,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5*** Exception: Numeric.NonNegative.Chunky.-: negative number+-}+++limitMinRelativeValues :: (Additive.C a, Ord a) =>+   a -> a -> Sig.T a -> (a, Sig.T a)+limitMinRelativeValues xMin x0 xs =+   let (ys,zs) =+          span ((<zero).fst) (zip (scanl (+) (x0-xMin) xs) (x0:xs))+   in  case ys of+          [] -> (x0,xs)+          (_:yr) -> (xMin, ListMatch.replicate yr zero +++              case zs of+                 [] -> []+                 (z:zr) -> fst z : map snd zr)++limitMaxRelativeValues :: (Additive.C a, Ord a) =>+   a -> a -> Sig.T a -> (a, Sig.T a)+limitMaxRelativeValues xMax x0 xs =+   let (ys,zs) =+          span (>zero) (scanl (-) (xMax-x0) xs)+   in  forcePair $+       ListHT.switchR+          (xMax, ListMatch.replicate xs zero)+          (\ yl yr -> (x0, ListMatch.take yl xs ++ ListMatch.take zs (yr : repeat zero)))+          ys++{- |+Avoids negative numbers and thus can be used with Chunky numbers.+-}+limitMaxRelativeValuesNonNeg :: (Additive.C a, Ord a) =>+   a -> a -> Sig.T a -> (a, Sig.T a)+limitMaxRelativeValuesNonNeg xMax x0 xs =+   let (ys,zs) =+          span fst (scanl (\(_,acc) d -> safeSub acc d) (safeSub xMax x0) xs)+   in  forcePair $+       ListHT.switchR+          (xMax, ListMatch.replicate xs zero)+          (\ yl ~(_,yr) -> (x0, ListMatch.take yl xs ++ ListMatch.take zs (yr : repeat zero)))+          ys+{-+*Synthesizer.Plain.Oscillator> limitMaxRelativeValuesNonNeg (let inf = 1+inf in inf) (0::Chunky.T NonNeg.Rational) (repeat 2.5)+-}++safeSub :: (Additive.C a, Ord a) => a -> a -> (Bool, a)+safeSub a b = (a>=b, a-b)
+ src/Synthesizer/Plain/Tutorial.hs view
@@ -0,0 +1,208 @@+{- |+This module gives some introductory examples to signal processing+with plain Haskell lists.+For more complex examples+see "Synthesizer.Plain.Instrument"+and "Synthesizer.Plain.Effect".+The examples require a basic understanding of audio signal processing.++In the Haddock documentation you will only see the API.+In order to view the example code,+please use the \"Source code\" links beside the function documentation.+This requires however,+that the Haddock was executed with @hyperlink-source@ option.++Using plain lists is not very fast,+particularly not fast enough for serious real-time applications.+It is however the most flexible data structure,+which you can also use without knowledge of low level programming.+For real-time applications see "Synthesizer.Generic.Tutorial".+-}+module Synthesizer.Plain.Tutorial+{-# DEPRECATED "do not import that module, it is only intended for demonstration" #-}+ where++import qualified Synthesizer.Plain.Play as Play+import qualified Synthesizer.Plain.File as File+import qualified Synthesizer.Plain.Signal as Sig+import qualified Synthesizer.Plain.Control as Ctrl+import qualified Synthesizer.Plain.Oscillator as Osci+import qualified Synthesizer.Plain.Filter.NonRecursive as Filt+import qualified Synthesizer.Plain.Filter.Recursive as FiltRec+import qualified Synthesizer.Plain.Filter.Recursive.Universal as UniFilter+import qualified Synthesizer.Basic.Wave as Wave++import qualified Algebra.Module as Module -- needed for Haddock++import System.Exit (ExitCode, )+import NumericPrelude+import PreludeBase+import Prelude ()+++{- |+Play a simple sine tone at 44100 sample rate and 16 bit.+These are the parameters used for compact disks.+The period of the tone is @2*pi*10@.+Playing at sample rate 44100 Hz results in a tone of @44100 / (20*pi) Hz@,+that is about @702 Hz@.+This is simple enough to be performed in real-time,+at least on my machine.+For playback we use @SoX@.+-}+sine :: IO ExitCode+sine =+   Play.monoToInt16 (44100::Double) (map sin [0::Double,0.1..])++{- |+Now the same for a stereo signal.+Both stereo channels are slightly detuned+in order to achieve a stereophonic phasing effect.+In principle there is no limit of the number of channels,+but with more channels playback becomes difficult.+Many signal processes in our package+support any tuple and even nested tuples+using the notion of an algebraic @module@ (see 'Module.C').+A module is a vector space where the scalar numbers+do not need to support division.+A vector space is often also called a linear space,+because all we require of vectors is that they can be added and scaled+and these two operations fulfill some natural laws.+-}+sineStereo :: IO ExitCode+sineStereo =+   Play.stereoToInt16 (44100::Double) $ zip (map sin [0::Double,0.0998..]) (map sin [0::Double,0.1002..])++{- |+Of course we can also write a tone to disk using @sox@.+-}+writeSine :: IO ExitCode+writeSine =+   File.writeToInt16 "sine.aiff" (44100::Double) (take 50000 $ map sin [0::Double,0.1..])+++{- |+For the following examples we will stick to monophonic sounds played at 44100 Hz.+Thus we define a function for convenience.+-}+play :: Sig.T Double -> IO ExitCode+play = Play.monoToInt16 (44100::Double)++{- |+Now, let's repeat the 'sine' example in a higher level style.+We use the oscillator 'Osci.static' that does not allow any modulation.+We can however use any waveform.+The waveform is essentially a function+which maps from the phase to the displacement.+Functional programming proves to be very useful here,+since anonymous functions as waveforms are optimally supported by the language.+We can also expect, that in compiled form+the oscillator does not have to call back the waveform function+by an expensive explicit function call,+but that the compiler will inline both oscillator and waveform+such that the oscillator is turned into a simple loop+which handles both oscillation and waveform computation.++Using the oscillator with 'Wave.sine' also has the advantage+that we do not have to cope with 'pi's any longer.+The frequency is given as ratio of the sample rate.+That is, @0.01@ at @44100 Hz@ sample rate means @441 Hz@.+This way all frequencies are given in the low-level signal processing.++It is not optimal to handle frequencies this way,+since all frequency values are bound to the sample rate.+For overcoming this problem, see the high level routines using physical dimensions.+For examples see "Synthesizer.Dimensional.RateAmplitude.Demonstration".+-}+oscillator :: IO ExitCode+oscillator =+   play (Osci.static Wave.sine 0 (0.01::Double))++{- |+It is very simple to switch to another waveform like a saw tooth wave.+Instead of a sharp saw tooth,+we use an extreme asymmetric triangle.+This is a poor man's band-limiting approach+that shall reduce aliasing at high oscillation frequencies.+We should really work on band-limited oscillators,+but this is hard in the general case.+-}+saw :: IO ExitCode+saw =+   play (Osci.static (Wave.triangleAsymmetric 0.9) 0 (0.01::Double))++{- |+When we apply a third power to each value of the saw tooths+we get an oscillator with cubic polynomial functions as waveform.+The distortion function applied to a saw wave can be used+to turn every function on the interval [-1,1] into a waveform.+-}+cubic :: IO ExitCode+cubic =+   play (Osci.static (Wave.distort (^3) Wave.saw) 0 (0.01::Double))++{- |+Now let's start with modulated tones.+The first simple example is changing the degree of asymmetry+according to a slow oscillator (LFO = low frequency oscillator).+-}+sawMorph :: IO ExitCode+sawMorph =+   play (Osci.shapeMod Wave.triangleAsymmetric 0 (0.01::Double) (Osci.static Wave.sine 0 (0.00001::Double)))++{- |+It's also very common to modulate the frequency of a tone.+-}+laser :: IO ExitCode+laser =+   play (Osci.freqMod Wave.saw 0 $ map (\f -> 0.02+0.01*f) $ Osci.static Wave.saw 0 (0.0001::Double))++pingSig :: Sig.T Double+pingSig =+   Filt.envelope (Ctrl.exponential 50000 1) (Osci.static Wave.sine 0 (0.01::Double))++{- |+A simple sine wave with exponentially decaying amplitude.+-}+ping :: IO ExitCode+ping =+   play pingSig++{- |+The 'ping' sound can also be used+to modulate the phase another oscillator.+This is a well-known effect used excessively in FM synthesis,+that was introduced by the Yamaha DX-7 synthesizer.+-}+fmPing :: IO ExitCode+fmPing =+   play (Osci.phaseMod Wave.sine (0.01::Double) $ map (2*) pingSig)++{- |+One of the most impressive sounds effects is certainly frequency filtering,+especially when the filter parameters are modulated.+In this example we use a resonant lowpass+whose resonance frequency is controlled by a slow sine wave.+The frequency filters usually use internal filter parameters+that are not very intuitive to use directly.+Thus we apply a function (here 'UniFilter.parameter')+in order to turn the intuitive parameters \"resonance frequency\" and \"resonance\"+(resonance frequency amplification while frequency zero is left unchanged)+into internal filter parameters.+We have not merged these two steps+since the computation of internal filter parameters+is more expensive then the filtering itself+and you may want to reduce the computation+by computing the internal filter parameters at a low sample rate+and interpolate them.+However, in the list implementation+this will not save you much time, if at all,+since the list operations are too expensive.++Now this is the example where my machine is no longer able to produce+a constant audio stream in real-time.+For tackling this problem, please continue with "Synthesizer.Generic.Tutorial".+-}+filterSaw :: IO ExitCode+filterSaw =+   play (map UniFilter.lowpass $ UniFilter.run (map (\f -> UniFilter.parameter $ FiltRec.Pole 10 (0.04+0.02*f)) $ Osci.static Wave.sine 0 (0.00001::Double)) $ Osci.static Wave.saw 0 (0.002::Double))
+ src/Synthesizer/Plain/Wave.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+module Synthesizer.Plain.Wave where++import qualified Synthesizer.Basic.Wave as Wave++import qualified Synthesizer.Plain.ToneModulation as ToneMod+import qualified Synthesizer.Plain.Interpolation  as Interpolation+import qualified Synthesizer.Plain.Signal as Sig+import Data.Array ((!), listArray)++-- import qualified Synthesizer.Basic.Phase as Phase++import qualified Algebra.RealField             as RealField+import qualified Algebra.Ring                  as Ring+import qualified Algebra.Additive              as Additive++import NumericPrelude++-- import qualified Prelude as P+import PreludeBase+++sample :: (RealField.C a) =>+   Interpolation.T a v -> Sig.T v -> Wave.T a v+sample ip wave =+   let len = length wave+       arr = listArray (0, pred len) wave+   in  Wave.fromFunction $ \ phase ->+           let (n,q) = splitFraction (phase * fromIntegral len)+               xs = map (arr!) (map (flip mod len)+                      (enumFrom (n - Interpolation.offset ip)))+--                map (arr!) (enumFromTo (n - Interpolation.offset ip)) ++ cycle wave+           in  Interpolation.func ip q xs++{- |+We assume that a tone was generated by a shape modulated oscillator.+We try to reconstruct the wave function+(with parameters shape control and phase)+from a tone by interpolation.++The unit for the shape control parameter is the sampling period.+That is the shape parameter is a time parameter+pointing to a momentary shape of the prototype signal.+Of course this momentary shape does not exist+and we can only guess it using interpolation.++At the boundaries we repeat the outermost shapes+that can be reconstructed entirely from interpolated data+(that is, no extrapolation is needed).+This way we cannot reproduce the shape at the boundaries+because we have no data for cyclically extending it.+On the other hand this method guarantees a nice wave shape+with the required fractional period.++It must be+   @length tone >=+       Interpolation.number ipStep ++       Interpolation.number ipLeap * ceiling period@.+-}+sampledTone :: (RealField.C a) =>+   Interpolation.T a v ->+   Interpolation.T a v ->+   a -> Sig.T v -> a -> Wave.T a v+sampledTone ipLeap ipStep period tone shape = Wave.Cons $ \phase ->+   uncurry (ToneMod.interpolateCell ipLeap ipStep) $+   ToneMod.sampledToneCell+      (ToneMod.makePrototype+          (Interpolation.margin ipLeap) (Interpolation.margin ipStep)+          (round period) period tone)+      shape phase+{-+*Synthesizer.Basic.Wave>+GNUPlot.plotFunc [] (GNUPlot.linearScale 1000 (0,12)) (\t -> sampledTone Interpolation.linear Interpolation.linear (6::Double) ([-5,-3,-1,1,3,5,-4,-4,-4,4,4,4]++replicate 20 0) t (t/6))++*Synthesizer.Plain.Oscillator>+let period = 6.3::Double in GNUPlot.plotFunc [] (GNUPlot.linearScale 1000 (-10,20)) (\t -> Wave.sampledTone Interpolation.linear Interpolation.cubic period (take 20 $ staticSine 0 (1/period)) t (t/period))+-}+
+ src/Synthesizer/RandomKnuth.hs view
@@ -0,0 +1,52 @@+{- |+Very simple random number generator+which should be fast and should suffice for generating just noise.+<http://www.softpanorama.org/Algorithms/random_generators.shtml>+-}+module Synthesizer.RandomKnuth (T, cons, ) where++import qualified System.Random as R+++newtype T = Cons Int+   deriving Show+++{-# INLINE cons #-}+cons :: Int -> T+cons = Cons+++{-# INLINE factor #-}+factor :: Int+factor = 40692++{-# INLINE modulus #-}+modulus :: Int+modulus = 2147483399 -- 2^31-249++-- we have to split the 32 bit integer in order to avoid overflow on multiplication+{-# INLINE split #-}+split :: Int+split = succ $ div modulus factor++{-# INLINE splitRem #-}+splitRem :: Int+splitRem = split * factor - modulus+++instance R.RandomGen T where+   {-# INLINE next #-}+   next (Cons s) =+      -- efficient computation of @mod (s*factor) modulus@ without Integer+      let (sHigh, sLow) = divMod s split+      in  (s, Cons $ flip mod modulus $+                   splitRem*sHigh + factor*sLow)+   {-# INLINE split #-}+   split (Cons s) = (Cons (s*s), Cons (13+s))+   {-# INLINE genRange #-}+   genRange _ = (1, pred modulus)+{-+*Main> let s = 10000000000 in (next (Cons s), mod (fromIntegral s * fromIntegral factor) (fromIntegral modulus) :: Integer)+((1410065408,Cons 1920127854),1920127854)+-}
+ src/Synthesizer/State/Analysis.hs view
@@ -0,0 +1,375 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+module Synthesizer.State.Analysis where++import qualified Synthesizer.State.Control as Ctrl+import qualified Synthesizer.State.Signal  as Sig++-- import qualified Algebra.Module                as Module+-- import qualified Algebra.Transcendental        as Trans+import qualified Algebra.Algebraic             as Algebraic+import qualified Algebra.RealField             as RealField+import qualified Algebra.Field                 as Field+import qualified Algebra.Real                  as Real+import qualified Algebra.Ring                  as Ring+import qualified Algebra.Additive              as Additive++import qualified Algebra.NormedSpace.Maximum   as NormedMax+import qualified Algebra.NormedSpace.Euclidean as NormedEuc+import qualified Algebra.NormedSpace.Sum       as NormedSum++import qualified Data.Array as Array++import qualified Data.IntMap as IntMap++-- import Algebra.Module((*>))++import Data.Array (accumArray)+-- import Data.List (foldl', )++import qualified Prelude as P+import PreludeBase+import NumericPrelude+++{- * Notions of volume -}++{- |+Volume based on Manhattan norm.+-}+{-# INLINE volumeMaximum #-}+volumeMaximum :: (Real.C y) => Sig.T y -> y+volumeMaximum =+   Sig.foldL max zero . rectify+--   maximum . rectify++{- |+Volume based on Energy norm.+-}+{-# INLINE volumeEuclidean #-}+volumeEuclidean :: (Algebraic.C y) => Sig.T y -> y+volumeEuclidean =+   Algebraic.sqrt . volumeEuclideanSqr++{-# INLINE volumeEuclideanSqr #-}+volumeEuclideanSqr :: (Field.C y) => Sig.T y -> y+volumeEuclideanSqr =+   average . Sig.map sqr++{- |+Volume based on Sum norm.+-}+{-# INLINE volumeSum #-}+volumeSum :: (Field.C y, Real.C y) => Sig.T y -> y+volumeSum = average . rectify++++{- |+Volume based on Manhattan norm.+-}+{-# INLINE volumeVectorMaximum #-}+volumeVectorMaximum :: (NormedMax.C y yv, Ord y) => Sig.T yv -> y+volumeVectorMaximum =+   Sig.foldL max zero . Sig.map NormedMax.norm+--   NormedMax.norm+--   maximum . Sig.map NormedMax.norm++{- |+Volume based on Energy norm.+-}+{-# INLINE volumeVectorEuclidean #-}+volumeVectorEuclidean :: (Algebraic.C y, NormedEuc.C y yv) => Sig.T yv -> y+volumeVectorEuclidean =+   Algebraic.sqrt . volumeVectorEuclideanSqr++{-# INLINE volumeVectorEuclideanSqr #-}+volumeVectorEuclideanSqr :: (Field.C y, NormedEuc.Sqr y yv) => Sig.T yv -> y+volumeVectorEuclideanSqr =+   average . Sig.map NormedEuc.normSqr++{- |+Volume based on Sum norm.+-}+{-# INLINE volumeVectorSum #-}+volumeVectorSum :: (NormedSum.C y yv, Field.C y) => Sig.T yv -> y+volumeVectorSum =+   average . Sig.map NormedSum.norm+++++{- |+Compute minimum and maximum value of the stream the efficient way.+Input list must be non-empty and finite.+-}+{-# INLINE bounds #-}+bounds :: (Ord y) => Sig.T y -> (y,y)+bounds =+   Sig.switchL+      (error "Analysis.bounds: List must contain at least one element.")+      (\x xs ->+          Sig.foldL (\(minX,maxX) y -> (min y minX, max y maxX)) (x,x) xs)++++{- * Miscellaneous -}++{-+histogram:+    length x = sum (histogramDiscrete x)++    units:+    1) histogram (amplify k x) = timestretch k (amplify (1/k) (histogram x))+    2) histogram (timestretch k x) = amplify k (histogram x)+    timestretch: k -> (s -> V) -> (k*s -> V)+    amplify:     k -> (s -> V) -> (s -> k*V)+    histogram:   (a -> b) -> (a^ia*b^ib -> a^ja*b^jb)+    x:           (s -> V)+    1) => (s^ia*(k*V)^ib -> s^ja*(k*V)^jb)+              = (s^ia*V^ib*k -> s^ja*V^jb/k)+       => ib=1, jb=-1+    2) => ((k*s)^ia*V^ib -> (k*s)^ja*V^jb)+              = (s^ia*V^ib -> s^ja*V^jb*k)+       => ia=0, ja=1+    histogram:   (s -> V) -> (V -> s/V)+histogram':+    integral (histogram' x) = integral x+    histogram' (amplify k x) = timestretch k (histogram' x)+    histogram' (timestretch k x) = amplify k (histogram' x)+     -> this does only apply if we slice the area horizontally+        and sum the slice up at each level,+        we must also restrict to the positive values,+        this is not quite the usual histogram+-}++{- |+Input list must be finite.+List is scanned twice, but counting may be faster.+-}+{-# INLINE histogramDiscreteArray #-}+histogramDiscreteArray :: Sig.T Int -> (Int, Sig.T Int)+histogramDiscreteArray =+   withAtLeast1 "histogramDiscreteArray" $ \ x ->+   let hist =+          accumArray (+) zero+             (bounds x) (attachOne x)+   in  (fst (Array.bounds hist), Sig.fromList (Array.elems hist))+++{- |+Input list must be finite.+If the input signal is empty, the offset is @undefined@.+List is scanned twice, but counting may be faster.+The sum of all histogram values is one less than the length of the signal.+-}+{-# INLINE histogramLinearArray #-}+histogramLinearArray :: RealField.C y => Sig.T y -> (Int, Sig.T y)+histogramLinearArray =+   withAtLeast2 "histogramLinearArray" $ \ x ->+   let (xMin,xMax) = bounds x+       hist =+          accumArray (+) zero+             (floor xMin, floor xMax)+             (meanValues x)+   in  (fst (Array.bounds hist), Sig.fromList (Array.elems hist))++{- |+Input list must be finite.+If the input signal is empty, the offset is @undefined@.+List is scanned once, counting may be slower.+-}+{-# INLINE histogramDiscreteIntMap #-}+histogramDiscreteIntMap :: Sig.T Int -> (Int, Sig.T Int)+histogramDiscreteIntMap =+   withAtLeast1 "histogramDiscreteIntMap" $ \ x ->+   let hist = IntMap.fromListWith (+) (attachOne x)+   in  case IntMap.toAscList hist of+          [] -> error "histogramDiscreteIntMap: the list was non-empty before processing ..."+          fAll@((fIndex,fHead):fs) -> (fIndex,+              Sig.fromList $+              fHead :+              concat (zipWith+                 (\(i0,_) (i1,f1) -> replicate (i1-i0-1) zero ++ [f1])+                 fAll fs))++{-# INLINE histogramLinearIntMap #-}+histogramLinearIntMap :: RealField.C y => Sig.T y -> (Int, Sig.T y)+histogramLinearIntMap =+   withAtLeast2 "histogramLinearIntMap" $ \ x ->+   let hist = IntMap.fromListWith (+) (meanValues x)+   -- we can rely on the fact that the keys are contiguous+       (startKey:_, elems) = unzip (IntMap.toAscList hist)+   in  (startKey, Sig.fromList elems)+   -- This doesn't work, due to a bug in IntMap of GHC-6.4.1+   -- in  (head (IntMap.keys hist), IntMap.elems hist)++{-# INLINE withAtLeast1 #-}+withAtLeast1 ::+   String ->+   (Sig.T y -> (Int, Sig.T y)) ->+   Sig.T y ->+   (Int, Sig.T y)+withAtLeast1 name f x =+   maybe+      (error (name ++ ": no bounds found"), Sig.empty)+      (const (f x)) $+   Sig.viewL x++{-# INLINE withAtLeast2 #-}+withAtLeast2 :: (RealField.C y) =>+   String ->+   (Sig.T y -> (Int, Sig.T y)) ->+   Sig.T y ->+   (Int, Sig.T y)+withAtLeast2 name f x =+   maybe+      (error (name ++ ": no bounds found"), Sig.empty)+      (\(y,ys) ->+           if Sig.null ys+             then (floor y, Sig.empty)+             else f x) $+   Sig.viewL x++{-+The bug in IntMap GHC-6.4.1 is:++*Synthesizer.Plain.Analysis> IntMap.keys $ IntMap.fromList $ [(0,0),(-1,-1::Int)]+[0,-1]+*Synthesizer.Plain.Analysis> IntMap.elems $ IntMap.fromList $ [(0,0),(-1,-1::Int)]+[0,-1]+*Synthesizer.Plain.Analysis> IntMap.assocs $ IntMap.fromList $ [(0,0),(-1,-1::Int)]+[(0,0),(-1,-1)]++The bug has gone in IntMap as shipped with GHC-6.6.+-}++{-# INLINE histogramIntMap #-}+histogramIntMap :: (RealField.C y) => y -> Sig.T y -> (Int, Sig.T Int)+histogramIntMap binsPerUnit =+   histogramDiscreteIntMap . quantize binsPerUnit++{-# INLINE quantize #-}+quantize :: (RealField.C y) => y -> Sig.T y -> Sig.T Int+quantize binsPerUnit = Sig.map (floor . (binsPerUnit*))++{-# INLINE attachOne #-}+attachOne :: Sig.T i -> [(i,Int)]+attachOne = Sig.toList . Sig.map (\i -> (i,one))++{-# INLINE meanValues #-}+meanValues :: RealField.C y => Sig.T y -> [(Int,y)]+meanValues x = concatMap spread (Sig.toList (Sig.zapWith (,) x))++{-# INLINE spread #-}+spread :: RealField.C y => (y,y) -> [(Int,y)]+spread (l0,r0) =+   let (l,r) = if l0<=r0 then (l0,r0) else (r0,l0)+       (li,lf) = splitFraction l+       (ri,rf) = splitFraction r+       k = recip (r-l)+       nodes =+          (li,k*(1-lf)) :+          zip [li+1 ..] (replicate (ri-li-1) k) +++          (ri, k*rf) :+          []+   in  if li==ri+         then [(li,one)]+         else nodes++{- |+Requires finite length.+This is identical to the arithmetic mean.+-}+{-# INLINE directCurrentOffset #-}+directCurrentOffset :: Field.C y => Sig.T y -> y+directCurrentOffset = average+++{-# INLINE scalarProduct #-}+scalarProduct :: Ring.C y => Sig.T y -> Sig.T y -> y+scalarProduct xs ys =+   Sig.sum (Sig.zipWith (*) xs ys)++{- |+'directCurrentOffset' must be non-zero.+-}+{-# INLINE centroid #-}+centroid :: Field.C y => Sig.T y -> y+centroid =+   uncurry (/) .+   Sig.sum .+   Sig.zipWith+      (\k x -> (k*x, x))+      (Sig.iterate (one+) zero)++centroidRecompute :: Field.C y => Sig.T y -> y+centroidRecompute xs =+   firstMoment xs / Sig.sum xs++{-# INLINE firstMoment #-}+firstMoment :: Field.C y => Sig.T y -> y+firstMoment xs =+   scalarProduct (Sig.iterate (one+) zero) xs+++{-# INLINE average #-}+average :: Field.C y => Sig.T y -> y+average =+   uncurry (/) .+   Sig.sum .+   Sig.map (flip (,) one)++averageRecompute :: Field.C y => Sig.T y -> y+averageRecompute x =+   Sig.sum x / fromIntegral (Sig.length x)++{-# INLINE rectify #-}+rectify :: Real.C y => Sig.T y -> Sig.T y+rectify = Sig.map abs++{- |+Detects zeros (sign changes) in a signal.+This can be used as a simple measure of the portion+of high frequencies or noise in the signal.+It ca be used as voiced\/unvoiced detector in a vocoder.++@zeros x !! n@ is @True@ if and only if+@(x !! n >= 0) \/= (x !! (n+1) >= 0)@.+The result will be one value shorter than the input.+-}+{-# INLINE zeros #-}+zeros :: (Ord y, Additive.C y) => Sig.T y -> Sig.T Bool+zeros =+   Sig.zapWith (/=) . Sig.map (>=zero)++++{- |+Detect thresholds with a hysteresis.+-}+{-# INLINE flipFlopHysteresis #-}+flipFlopHysteresis :: (Ord y) =>+   (y,y) -> Bool -> Sig.T y -> Sig.T Bool+flipFlopHysteresis (lower,upper) =+   Sig.scanL+      (\state x ->+          if state+            then not(x<lower)+            else x>upper)++{- |+Almost naive implementation of the chirp transform,+a generalization of the Fourier transform.++More sophisticated algorithms like Rader, Cooley-Tukey, Winograd, Prime-Factor may follow.+-}+{-# INLINE chirpTransform #-}+chirpTransform :: Ring.C y =>+   y -> Sig.T y -> Sig.T y+chirpTransform z xs =+   let powers = Ctrl.curveMultiscaleNeutral (*) z one+       powerPowers =+          Sig.map (\zn -> Ctrl.curveMultiscaleNeutral (*) zn one) powers+   in  Sig.map (scalarProduct xs) powerPowers
+ src/Synthesizer/State/Control.hs view
@@ -0,0 +1,266 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{- |+Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes+-}+module Synthesizer.State.Control where++import qualified Synthesizer.Plain.Control as Ctrl+import qualified Synthesizer.Piecewise as Piecewise+import Synthesizer.State.Displacement (raise)++import qualified Synthesizer.State.Signal as Sig++import qualified Algebra.Module                as Module+import qualified Algebra.Transcendental        as Trans+import qualified Algebra.RealField             as RealField+import qualified Algebra.Field                 as Field+import qualified Algebra.Ring                  as Ring+import qualified Algebra.Additive              as Additive++import Algebra.Module((*>))++-- import Number.Complex (cis,real)+-- import qualified Number.Complex as Complex++import qualified Prelude as P+import PreludeBase+import NumericPrelude+++{- * Control curve generation -}++{-# INLINE constant #-}+constant :: a -> Sig.T a+constant = Sig.repeat++{-# INLINE linear #-}+linear :: Additive.C a =>+      a   {-^ steepness -}+   -> a   {-^ initial value -}+   -> Sig.T a+          {-^ linear progression -}+linear d y0 = Sig.iterate (d+) y0++{- |+As stable as the addition of time values.+-}+{-# INLINE linearMultiscale #-}+linearMultiscale :: Additive.C y =>+      y+   -> y+   -> Sig.T y+linearMultiscale = curveMultiscale (+)++{- |+Linear curve starting at zero.+-}+{-# INLINE linearMultiscaleNeutral #-}+linearMultiscaleNeutral :: Additive.C y =>+      y+   -> Sig.T y+linearMultiscaleNeutral slope =+   curveMultiscaleNeutral (+) slope zero++{- |+Linear curve of a fixed length.+The final value is not actually reached,+instead we stop one step before.+This way we can concatenate several lines+without duplicate adjacent values.+-}+{-# INLINE line #-}+line :: Field.C y =>+      Int     {-^ length -}+   -> (y,y)   {-^ initial and final value -}+   -> Sig.T y {-^ linear progression -}+line n (y0,y1) =+   Sig.take n $ linear ((y1-y0) / fromIntegral n) y0+++{-# INLINE exponential #-}+{-# INLINE exponentialMultiscale #-}+exponential, exponentialMultiscale :: Trans.C a =>+      a   {-^ time where the function reaches 1\/e of the initial value -}+   -> a   {-^ initial value -}+   -> Sig.T a+          {-^ exponential decay -}+exponential time =+   Sig.iterate (exp (- recip time) *)++exponentialMultiscale time = curveMultiscale (*) (exp (- recip time))++{-# INLINE exponentialMultiscaleNeutral #-}+exponentialMultiscaleNeutral :: Trans.C y =>+      y   {-^ time where the function reaches 1\/e of the initial value -}+   -> Sig.T y {-^ exponential decay -}+exponentialMultiscaleNeutral time =+   curveMultiscaleNeutral (*) (exp (- recip time)) one+++{-# INLINE exponential2 #-}+{-# INLINE exponential2Multiscale #-}+exponential2, exponential2Multiscale :: Trans.C a =>+      a   {-^ half life -}+   -> a   {-^ initial value -}+   -> Sig.T a+          {-^ exponential decay -}+exponential2 halfLife =+   Sig.iterate (((Ring.one+Ring.one) ** (- recip halfLife)) *)+--   Sig.iterate (((Ring.one/(Ring.one+Ring.one)) ** recip halfLife) *)++exponential2Multiscale halfLife = curveMultiscale (*) (0.5 ** recip halfLife)++{- the 0.5 constant seems to block fusion+   Sig.iterate ((0.5 ** recip halfLife) *)+-}+{- dito fromInteger+   Sig.iterate ((fromInteger 2 ** (- recip halfLife)) *)+-}++{-# INLINE exponential2MultiscaleNeutral #-}+exponential2MultiscaleNeutral :: Trans.C y =>+      y   {-^ half life -}+   -> Sig.T y {-^ exponential decay -}+exponential2MultiscaleNeutral halfLife =+   curveMultiscaleNeutral (*) (0.5 ** recip halfLife) one+++{-# INLINE exponentialFromTo #-}+{-# INLINE exponentialFromToMultiscale #-}+exponentialFromTo, exponentialFromToMultiscale :: Trans.C y =>+      y   {-^ time where the function reaches 1\/e of the initial value -}+   -> y   {-^ initial value -}+   -> y   {-^ value after given time -}+   -> Sig.T y {-^ exponential decay -}+exponentialFromTo time y0 y1 =+   Sig.iterate (*  (y1/y0) ** recip time) y0+exponentialFromToMultiscale time y0 y1 =+   curveMultiscale (*) ((y1/y0) ** recip time) y0+++++{-| This is an extension of 'exponential' to vectors+    which is straight-forward but requires more explicit signatures.+    But since it is needed rarely I setup a separate function. -}+{-# INLINE vectorExponential #-}+vectorExponential :: (Trans.C a, Module.C a v) =>+       a  {-^ time where the function reaches 1\/e of the initial value -}+   ->  v  {-^ initial value -}+   -> Sig.T v+          {-^ exponential decay -}+vectorExponential time y0 =+   Sig.iterate (exp (-1/time) *>) y0++{-# INLINE vectorExponential2 #-}+vectorExponential2 :: (Trans.C a, Module.C a v) =>+       a  {-^ half life -}+   ->  v  {-^ initial value -}+   -> Sig.T v+          {-^ exponential decay -}+vectorExponential2 halfLife y0 =+   Sig.iterate (0.5**(1/halfLife) *>) y0++++{-# INLINE cosine #-}+cosine :: Trans.C a =>+       a  {-^ time t0 where  1 is approached -}+   ->  a  {-^ time t1 where -1 is approached -}+   -> Sig.T a+          {-^ a cosine wave where one half wave is between t0 and t1 -}+cosine = Ctrl.cosineWithSlope $+   \d x -> Sig.map cos (linear d x)++++{-# INLINE cubicHermite #-}+cubicHermite :: Field.C a => (a, (a,a)) -> (a, (a,a)) -> Sig.T a+cubicHermite node0 node1 =+   Sig.map (Ctrl.cubicFunc node0 node1) (linear 1 0)++++-- * piecewise curves+++splitDurations :: (RealField.C t) =>+   [t] -> [(Int, t)]+splitDurations ts0 =+   let (ds,ts) =+           unzip $ scanl+              (\(_,fr) d -> splitFraction (fr+d))+              (0,1) ts0+   in  zip (tail ds) (map (subtract 1) ts)++{-# INLINE piecewise #-}+piecewise :: (RealField.C a) =>+   Piecewise.T a a (a -> Sig.T a) -> Sig.T a+piecewise xs =+   Sig.concat $ zipWith+      (\(n, t) (Piecewise.PieceData c yi0 yi1 d) ->+           Sig.take n $ Piecewise.computePiece c yi0 yi1 d t)+      (splitDurations $ map Piecewise.pieceDur xs)+      xs+++type Piece a =+   Piecewise.Piece a a+      (a {- fractional start time -} -> Sig.T a)+++{-# INLINE stepPiece #-}+stepPiece :: Piece a+stepPiece =+   Piecewise.pieceFromFunction $ \ y0 _y1 _d _t0 ->+      constant y0++{-# INLINE linearPiece #-}+linearPiece :: (Field.C a) => Piece a+linearPiece =+   Piecewise.pieceFromFunction $ \ y0 y1 d t0 ->+      let s = (y1-y0)/d in linear s (y0-t0*s)++{-# INLINE exponentialPiece #-}+exponentialPiece :: (Trans.C a) => a -> Piece a+exponentialPiece saturation =+   Piecewise.pieceFromFunction $ \ y0 y1 d t0 ->+      let y0' = y0-saturation+          y1' = y1-saturation+          yd  = y0'/y1'+      in  raise saturation+             (exponential (d / log yd) (y0' * yd**(t0/d)))++{-# INLINE cosinePiece #-}+cosinePiece :: (Trans.C a) => Piece a+cosinePiece =+   Piecewise.pieceFromFunction $ \ y0 y1 d t0 ->+      Sig.map+         (\y -> (1+y)*(y0/2)+(1-y)*(y1/2))+         (cosine t0 (t0+d))++{-# INLINE cubicPiece #-}+cubicPiece :: (Field.C a) => a -> a -> Piece a+cubicPiece yd0 yd1 =+   Piecewise.pieceFromFunction $ \ y0 y1 d t0 ->+      cubicHermite (t0,(y0,yd0)) (t0+d,(y1,yd1))+++-- * auxiliary functions++{-# INLINE curveMultiscale #-}+curveMultiscale :: (y -> y -> y) -> y -> y -> Sig.T y+curveMultiscale op d y0 =+   Sig.cons y0 (Sig.map (op y0) (Sig.iterateAssociative op d))++{-# INLINE curveMultiscaleNeutral #-}+curveMultiscaleNeutral :: (y -> y -> y) -> y -> y -> Sig.T y+curveMultiscaleNeutral op d neutral =+   Sig.cons neutral (Sig.iterateAssociative op d)
+ src/Synthesizer/State/Cut.hs view
@@ -0,0 +1,157 @@+{-# LANGUAGE NoImplicitPrelude #-}+{- |+Copyright   :  (c) Henning Thielemann 2006+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes+-}+module Synthesizer.State.Cut (+   {- * dissection -}+   takeUntilPause,+   takeUntilInterval,++   {- * glueing -}+   selectBool,+   select,+   arrange,+   arrangeList,+   ) where++import qualified Synthesizer.State.Signal as Sig++import qualified Data.EventList.Relative.TimeBody as EventList++import qualified MathObj.LaurentPolynomial as Laurent+import qualified Algebra.Real     as Real+import qualified Algebra.Additive as Additive++import qualified Data.Array as Array+import Data.Array (Array, Ix, (!), elems, )+import Control.Applicative (Applicative, )+import Data.Traversable (sequenceA, )++import Data.Tuple.HT (mapSnd, )++import qualified Number.NonNegative as NonNeg++import PreludeBase+import NumericPrelude++++{- |+Take signal until it falls short of a certain amplitude for a given time.+-}+{-# INLINE takeUntilPause #-}+takeUntilPause :: (Real.C a) => a -> Int -> Sig.T a -> Sig.T a+takeUntilPause y =+   takeUntilInterval ((<=y) . abs)++{- |+Take values until the predicate p holds for n successive values.+The list is truncated at the beginning of the interval of matching values.+-}+{-# INLINE takeUntilInterval #-}+takeUntilInterval :: (a -> Bool) -> Int -> Sig.T a -> Sig.T a+takeUntilInterval p n xs =+   Sig.map fst $+   Sig.takeWhile ((<n) . snd) $+   Sig.zip xs $+   Sig.drop n $+   Sig.append (Sig.scanL (\acc x -> if p x then succ acc else 0) 0 xs) $+   Sig.repeat 0++++{-# INLINE selectBool #-}+selectBool :: (Sig.T a, Sig.T a) -> Sig.T Bool -> Sig.T a+selectBool =+   Sig.zipWith (\(xf,xt) c -> if c then xt else xf) .+   uncurry Sig.zip+++{-# INLINE select #-}+select :: Ix i => Array i (Sig.T a) -> Sig.T i -> Sig.T a+select =+   Sig.crochetL+      (\xi arr ->+           do arr0 <- sequenceArray (fmap Sig.viewL arr)+              return (fst (arr0!xi), fmap snd arr0))++{-# INLINE sequenceArray #-}+sequenceArray ::+   (Applicative f, Ix i) =>+   Array i (f a) -> f (Array i a)+sequenceArray arr =+   fmap (Array.listArray (Array.bounds arr)) $+   sequenceA (Array.elems arr)+++{- |+Given a list of signals with time stamps,+mix them into one signal as they occur in time.+Ideally for composing music.++Cf. 'MathObj.LaurentPolynomial.series'+-}+{-# INLINE arrangeList #-}+arrangeList :: (Additive.C v) =>+       EventList.T NonNeg.Int (Sig.T v)+            {-^ A list of pairs: (relative start time, signal part),+                The start time is relative to the start time+                of the previous event. -}+    -> Sig.T v+            {-^ The mixed signal. -}+arrangeList evs =+   let xs = map Sig.toList (EventList.getBodies evs)+   in  case map NonNeg.toNumber (EventList.getTimes evs) of+          t:ts -> Sig.replicate t zero `Sig.append`+                  Sig.fromList (Laurent.addShiftedMany ts xs)+          []   -> Sig.empty+++++{-# INLINE arrange #-}+arrange :: (Additive.C v) =>+       EventList.T NonNeg.Int (Sig.T v)+            {-^ A list of pairs: (relative start time, signal part),+                The start time is relative to the start time+                of the previous event. -}+    -> Sig.T v+            {-^ The mixed signal. -}+arrange evs =+   let xs = EventList.getBodies evs+   in  case map NonNeg.toNumber (EventList.getTimes evs) of+          t:ts -> Sig.replicate t zero `Sig.append`+                  addShiftedMany ts xs+          []   -> Sig.empty+++{-# INLINE addShiftedMany #-}+addShiftedMany :: (Additive.C a) => [Int] -> [Sig.T a] -> Sig.T a+addShiftedMany ds xss =+   foldr (uncurry addShifted) Sig.empty (zip (ds++[zero]) xss)++++{-# INLINE addShifted #-}+addShifted :: Additive.C a => Int -> Sig.T a -> Sig.T a -> Sig.T a+addShifted del xs ys =+   if del < 0+     then error "State.Signal.addShifted: negative shift"+     else+       Sig.unfoldR+          (\((d,ys0),xs0) ->+              -- d<0 cannot happen+              if d==zero+                then+                  fmap+                     (mapSnd (\(xs1,ys1) -> ((zero,ys1),xs1)))+                     (Sig.zipStep (+) (xs0, ys0))+                else+                  Just $ mapSnd ((,) (pred d, ys0)) $+                  Sig.switchL (zero, xs0) (,) xs0)+          ((del,ys),xs)
+ src/Synthesizer/State/Displacement.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE NoImplicitPrelude #-}+module Synthesizer.State.Displacement where++import qualified Synthesizer.State.Signal as Sig++-- import qualified Algebra.Module                as Module+-- import qualified Algebra.Transcendental        as Trans+-- import qualified Algebra.Field                 as Field+-- import qualified Algebra.Ring                  as Ring+import qualified Algebra.Additive              as Additive++import qualified Prelude as P+import PreludeBase+import NumericPrelude+++{- * Mixing -}++{-|+Mix two signals.+In opposition to 'zipWith' the result has the length of the longer signal.+-}+{-# INLINE mix #-}+mix :: (Additive.C v) => Sig.T v -> Sig.T v -> Sig.T v+mix = Sig.mix++{-| Mix an arbitrary number of signals. -}+{-# INLINE mixMulti #-}+mixMulti :: (Additive.C v) => [Sig.T v] -> Sig.T v+mixMulti = foldl mix Sig.empty+++{-|+Add a number to all of the signal values.+This is useful for adjusting the center of a modulation.+-}+{-# INLINE raise #-}+raise :: (Additive.C v) => v -> Sig.T v -> Sig.T v+raise x = Sig.map ((+) x)+++{- * Distortion -}+{-|+In "Synthesizer.Basic.Distortion" you find a collection+of appropriate distortion functions.+-}+{-# INLINE distort #-}+distort :: (c -> a -> a) -> Sig.T c -> Sig.T a -> Sig.T a+distort = Sig.zipWith
+ src/Synthesizer/State/Filter/Delay.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE NoImplicitPrelude #-}+module Synthesizer.State.Filter.Delay where++import qualified Synthesizer.Interpolation as Interpolation+import qualified Synthesizer.State.Interpolation as InterpolationS+import qualified Synthesizer.State.Signal as Sig++import qualified Algebra.RealField as RealField+import qualified Algebra.Additive  as Additive++-- import qualified Prelude as P+-- import PreludeBase+import NumericPrelude++++{- * Shift -}++{-# INLINE static #-}+static :: Additive.C y => Int -> Sig.T y -> Sig.T y+static = staticPad zero++{-# INLINE staticPad #-}+staticPad :: y -> Int -> Sig.T y -> Sig.T y+staticPad = InterpolationS.delayPad++{-# INLINE staticPos #-}+staticPos :: Additive.C y => Int -> Sig.T y -> Sig.T y+staticPos n = Sig.append (Sig.replicate n zero)++{-# INLINE staticNeg #-}+staticNeg :: Int -> Sig.T y -> Sig.T y+staticNeg = Sig.drop++++{-# INLINE modulatedCore #-}+modulatedCore :: (RealField.C a, Additive.C v) =>+   Interpolation.T a v -> Int -> Sig.T a -> Sig.T v -> Sig.T v+modulatedCore ip size =+   Sig.zipWithTails+      (\t -> InterpolationS.single ip (fromIntegral size + t))++{-+modulatedCoreSlow :: (RealField.C a, Additive.C v) =>+   Interpolation.T a v -> Int -> Sig.T a -> Sig.T v -> Sig.T v+modulatedCoreSlow ip size ts xs =+   Sig.fromList $ zipWith+      (\t -> Interpolation.single ip (fromIntegral size - t))+      (Sig.toList ts) (Sig.tails xs)+-}++{- |+This is essentially different for constant interpolation,+because this function "looks forward"+whereas the other two variants "look backward".+For the symmetric interpolation functions+of linear and cubic interpolation, this does not really matter.+-}+{-# INLINE modulated #-}+modulated :: (RealField.C a, Additive.C v) =>+   Interpolation.T a v -> Int -> Sig.T a -> Sig.T v -> Sig.T v+modulated ip minDev ts xs =+   let size = Interpolation.number ip - minDev+   in  modulatedCore ip+          (size - Interpolation.offset ip)+          ts+          (staticPos size xs)
+ src/Synthesizer/State/Filter/NonRecursive.hs view
@@ -0,0 +1,291 @@+{-# LANGUAGE NoImplicitPrelude #-}+{- |+Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes+-}+module Synthesizer.State.Filter.NonRecursive where++import qualified Synthesizer.State.Signal as Sig++import qualified Synthesizer.State.Filter.Delay as Delay+import qualified Synthesizer.State.Control as Ctrl++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 qualified Algebra.Ring           as Ring+import qualified Algebra.Additive       as Additive++import Algebra.Module( {- linearComb, -} (*>))++import Data.Function.HT (nest, )++import PreludeBase+import NumericPrelude++++{- * Envelope application -}++{-# INLINE amplify #-}+amplify :: (Ring.C a) => a -> Sig.T a -> Sig.T a+amplify v = Sig.map (v*)++{-# INLINE amplifyVector #-}+amplifyVector :: (Module.C a v) => a -> Sig.T v -> Sig.T v+amplifyVector v = Sig.map (v*>)+++{-# INLINE envelope #-}+envelope :: (Ring.C a) =>+      Sig.T a  {-^ the envelope -}+   -> Sig.T a  {-^ the signal to be enveloped -}+   -> Sig.T a+envelope = Sig.zipWith (*)++{-# INLINE envelopeVector #-}+envelopeVector :: (Module.C a v) =>+      Sig.T a  {-^ the envelope -}+   -> Sig.T v  {-^ the signal to be enveloped -}+   -> Sig.T v+envelopeVector = Sig.zipWith (*>)++++{-# INLINE fadeInOut #-}+fadeInOut :: (Field.C a) =>+   Int -> Int -> Int -> Sig.T a -> Sig.T a+fadeInOut tIn tHold tOut =+   let leadIn  = Sig.take tIn  $ Ctrl.linear (  recip (fromIntegral tIn))  zero+       leadOut = Sig.take tOut $ Ctrl.linear (- recip (fromIntegral tOut)) one+       hold    = Sig.replicate tHold one+   in  envelope (leadIn `Sig.append` hold `Sig.append` leadOut)+++{- * Smoothing -}+++{-| Unmodulated non-recursive filter -}+{-# INLINE generic #-}+generic :: (Module.C a v) =>+   Sig.T a -> Sig.T v -> Sig.T v+generic m x =+   let mr = Sig.reverse m+       xp = Delay.staticPos (pred (Sig.length m)) x+   in  Sig.mapTails (Sig.linearComb mr) xp++{-+genericSlow :: Module.C a v =>+   Sig.T a -> Sig.T v -> Sig.T v+genericSlow m x =+   let mr = Sig.reverse m+       xp = delay (pred (Sig.length m)) x+   in  Sig.fromList (map (Sig.linearComb mr) (init (Sig.tails xp)))+-}++{-+{- |+@eps@ is the threshold relatively to the maximum.+That is, if the gaussian falls below @eps * gaussian 0@,+then the function truncated.+-}+gaussian ::+   (Trans.C a, RealField.C a, Module.C a v) =>+   a -> a -> a -> Sig.T v -> Sig.T v+gaussian eps ratio freq =+   let var    = ratioFreqToVariance ratio freq+       area   = var * sqrt (2*pi)+       gau t  = exp (-(t/var)^2/2) / area+       width  = ceiling (var * sqrt (-2 * log eps))  -- inverse gau+       gauSmp = map (gau . fromIntegral) [-width .. width]+   in  drop width . generic gauSmp+-}++{-+GNUPlot.plotList [] (take 1000 $ gaussian 0.001 0.5 0.04 (Filter.Test.chirp 5000) :: [Double])++The filtered chirp must have amplitude 0.5 at 400 (0.04*10000).+-}++{-+  We want to approximate a Gaussian by a binomial filter.+  The latter one can be implemented by a convolutional power.+  However we still require a number of operations per sample+  which is proportional to the variance.+-}+{-# INLINE binomial #-}+binomial ::+   (Trans.C a, RealField.C a, Module.C a v) =>+   a -> a -> Sig.T v -> Sig.T v+binomial ratio freq =+   let width = ceiling (2 * ratioFreqToVariance ratio freq ^ 2)+   in  Sig.drop width . nest (2*width) ((asTypeOf 0.5 freq *>) . binomial1)++{-+exp (-(t/var)^2/2) / area *> cis (2*pi*f*t)+  == exp (-(t/var)^2/2 +: 2*pi*f*t) / area+  == exp ((-t^2 +: 2*var^2*2*pi*f*t) / (2*var^2)) / area+  == exp ((t^2 - i*2*var^2*2*pi*f*t) / (-2*var^2)) / area+  == exp (((t^2 - i*var^2*2*pi*f)^2 + (var^2*2*pi*f)^2) / (-2*var^2)) / area+  == exp (((t^2 - i*var^2*2*pi*f)^2 / (-2*var^2) - (var*2*pi*f)^2/2)) / area++sumMap (\t -> exp (-(t/var)^2/2) / area *> cis (2*pi*f*t))+       [-infinity..infinity]+  ~ sumMap (\t -> exp (-(t/var)^2/2)) [-infinity..infinity]+       * exp (-(var*2*pi*f)^2/2) / area+  = exp (-(var*2*pi*f)^2/2)+-}+{- |+  Compute the variance of the Gaussian+  such that its Fourier transform has value @ratio@ at frequency @freq@.+-}+{-# INLINE ratioFreqToVariance #-}+ratioFreqToVariance :: (Trans.C a) => a -> a -> a+ratioFreqToVariance ratio freq =+   sqrt (-2 * log ratio) / (2*pi*freq)+           -- inverse of the fourier transformed gaussian++{-# INLINE binomial1 #-}+binomial1 :: (Additive.C v) => Sig.T v -> Sig.T v+binomial1 = Sig.zapWith (+)++++++{- |+Moving (uniformly weighted) average in the most trivial form.+This is very slow and needs about @n * length x@ operations.+-}+{-# INLINE sums #-}+sums :: (Additive.C v) => Int -> Sig.T v -> Sig.T v+sums n = Sig.mapTails (Sig.sum . Sig.take n)+++{-+sumsDownsample2 :: (Additive.C v) => Sig.T v -> Sig.T v+sumsDownsample2 (x0:x1:xs) = (x0+x1) : sumsDownsample2 xs+sumsDownsample2 xs         = xs++downsample2 :: Sig.T a -> Sig.T a+downsample2 (x0:_:xs) = x0 : downsample2 xs+downsample2 xs        = xs+++{- |+Given a list of numbers+and a list of sums of (2*k) of successive summands,+compute a list of the sums of (2*k+1) or (2*k+2) summands.++Eample for 2*k+1++@+ [0+1+2+3, 2+3+4+5, 4+5+6+7, ...] ->+    [0+1+2+3+4, 1+2+3+4+5, 2+3+4+5+6, 3+4+5+6+7, 4+5+6+7+8, ...]+@++Example for 2*k+2++@+ [0+1+2+3, 2+3+4+5, 4+5+6+7, ...] ->+    [0+1+2+3+4+5, 1+2+3+4+5+6, 2+3+4+5+6+7, 3+4+5+6+7+8, 4+5+6+7+8+9, ...]+@+-}+sumsUpsampleOdd :: (Additive.C v) => Int -> Sig.T v -> Sig.T v -> Sig.T v+sumsUpsampleOdd n {- 2*k -} xs ss =+   let xs2k = drop n xs+   in  (head ss + head xs2k) :+          concat (zipWith3 (\s x0 x2k -> [x0+s, s+x2k])+                           (tail ss)+                           (downsample2 (tail xs))+                           (tail (downsample2 xs2k)))++sumsUpsampleEven :: (Additive.C v) => Int -> Sig.T v -> Sig.T v -> Sig.T v+sumsUpsampleEven n {- 2*k -} xs ss =+   sumsUpsampleOdd (n+1) xs (zipWith (+) ss (downsample2 (drop n xs)))++sumsPyramid :: (Additive.C v) => Int -> Sig.T v -> Sig.T v+sumsPyramid n xs =+   let aux 1 ys = ys+       aux 2 ys = ys + tail ys+       aux m ys =+          let ysd = sumsDownsample2 ys+          in  if even m+                then sumsUpsampleEven (m-2) ys (aux (div (m-2) 2) ysd)+                else sumsUpsampleOdd  (m-1) ys (aux (div (m-1) 2) ysd)+   in  aux n xs+++propSums :: Bool+propSums =+   let n  = 1000+       xs = [0::Double ..]+       naive   =              sums        n xs+       rec     = drop (n-1) $ sumsRec     n xs+       pyramid =              sumsPyramid n xs+   in  and $ take 1000 $+         zipWith3 (\x y z -> x==y && y==z) naive rec pyramid++-}++++{- * Filter operators from calculus -}++{- |+Forward difference quotient.+Shortens the signal by one.+Inverts 'Synthesizer.State.Filter.Recursive.Integration.run' in the sense that+@differentiate (zero : integrate x) == x@.+The signal is shifted by a half time unit.+-}+{-# INLINE differentiate #-}+differentiate :: Additive.C v => Sig.T v -> Sig.T v+differentiate x = Sig.zapWith subtract x++{- |+Central difference quotient.+Shortens the signal by two elements,+and shifts the signal by one element.+(Which can be fixed by prepending an appropriate value.)+For linear functions this will yield+essentially the same result as 'differentiate'.+You obtain the result of 'differentiateCenter'+if you smooth the one of 'differentiate'+by averaging pairs of adjacent values.++ToDo: Vector variant+-}+{- We use zapWith in order to avoid recomputation of the input signal -}+{-# INLINE differentiateCenter #-}+differentiateCenter :: Field.C v => Sig.T v -> Sig.T v+differentiateCenter =+   Sig.zapWith (\(x0,_) (_,x1) -> (x1 - x0) * (1/2)) .+   Sig.zapWith (,)+{-+differentiateCenter :: Field.C v => Sig.T v -> Sig.T v+differentiateCenter x =+   Sig.map ((1/2)*) $+   Sig.zipWith subtract x (Sig.tail (Sig.tail x))+-}++{- |+Second derivative.+It is @differentiate2 == differentiate . differentiate@+but 'differentiate2' should be faster.+-}+{-# INLINE differentiate2 #-}+differentiate2 :: Additive.C v => Sig.T v -> Sig.T v+differentiate2 = differentiate . differentiate+{-+differentiate2 :: Additive.C v => Sig.T v -> Sig.T v+differentiate2 xs0 =+   let xs1 = Sig.tail xs0+       xs2 = Sig.tail xs1+   in  Sig.zipWith3 (\x0 x1 x2 -> x0+x2-(x1+x1)) xs0 xs1 xs2+-}
+ src/Synthesizer/State/Filter/Recursive/Comb.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{- |+Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes++Comb filters, useful for emphasis of tones with harmonics+and for repeated echos.+-}+module Synthesizer.State.Filter.Recursive.Comb where++import qualified Synthesizer.State.Signal  as Sig+import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1++import qualified Synthesizer.State.Filter.Delay as Delay++import qualified Algebra.Module                as Module+-- import qualified Algebra.Field                 as Field+import qualified Algebra.Ring                  as Ring+import qualified Algebra.Additive              as Additive++import Algebra.Module((*>))++import qualified Prelude as P+import PreludeBase+import NumericPrelude+++{- |+The most simple version of the Karplus-Strong algorithm+which is suitable to simulate a plucked string.+It is similar to the 'runProc' function.+-}+{-# INLINE karplusStrong #-}+karplusStrong :: (Ring.C a, Module.C a v) =>+   Filt1.Parameter a -> Sig.T v -> Sig.T v+karplusStrong c wave =+   Sig.delayLoop (Sig.modifyStatic Filt1.lowpassModifier c) wave+++{- |+Infinitely many equi-delayed exponentially decaying echos.+The echos are clipped to the input length.+We think it is easier (and simpler to do efficiently)+to pad the input with zeros or whatever+instead of cutting the result according to the input length.+-}+{-# INLINE run #-}+run :: (Module.C a v) => Int -> a -> Sig.T v -> Sig.T v+run time gain = Sig.delayLoopOverlap time (gain *>)++{- | Echos of different delays. -}+{-# INLINE runMulti #-}+runMulti :: (Ring.C a, Module.C a v) => [Int] -> a -> Sig.T v -> Sig.T v+runMulti times gain x =+    let y = Sig.fromList $ Sig.toList $+            foldl+               (Sig.zipWith (+)) x+               (map (flip Delay.staticPos (gain *> y)) times)+    in  y++{- | Echos can be piped through an arbitrary signal processor. -}+{-# INLINE runProc #-}+runProc :: Additive.C v => Int -> (Sig.T v -> Sig.T v) -> Sig.T v -> Sig.T v+runProc = Sig.delayLoopOverlap
+ src/Synthesizer/State/Filter/Recursive/Integration.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE NoImplicitPrelude #-}+{- |+Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes++Filter operators from calculus+-}+module Synthesizer.State.Filter.Recursive.Integration where++import qualified Synthesizer.State.Signal  as Sig+import qualified Synthesizer.Causal.Process as Causal++-- import qualified Algebra.Field                 as Field+-- import qualified Algebra.Ring                  as Ring+import qualified Algebra.Additive              as Additive++import PreludeBase+import NumericPrelude++++{- |+Integrate with initial value zero.+However the first emitted value is the value of the input signal.+It maintains the length of the signal.+-}+{-# INLINE run #-}+run :: Additive.C v => Sig.T v -> Sig.T v+run =+   Sig.crochetL (\x acc -> let y = x+acc in Just (y,y)) zero+   -- scanl1 (+)++{- |+Integrate with initial condition.+First emitted value is the initial condition.+The signal become one element longer.+-}+{-# INLINE runInit #-}+runInit :: Additive.C v => v -> Sig.T v -> Sig.T v+runInit = Sig.scanL (+)+++{-# INLINE causal #-}+causal :: Additive.C v => Causal.T v v+causal = Causal.scanL1 (+)++{- |+Integrate with initial condition.+First emitted value is the initial condition.+The signal become one element longer.+-}+{-# INLINE causalInit #-}+causalInit :: Additive.C v => v -> Causal.T v v+causalInit = Causal.scanL (+)++{- other quadrature methods may follow -}
+ src/Synthesizer/State/Filter/Recursive/MovingAverage.hs view
@@ -0,0 +1,183 @@+{-# LANGUAGE NoImplicitPrelude #-}+{- |+Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes++-}+module Synthesizer.State.Filter.Recursive.MovingAverage+   (sumsStaticInt,+    modulatedFrac,+    ) where++import qualified Synthesizer.State.Signal  as Sig+import qualified Synthesizer.State.Filter.Recursive.Integration as Integration++import qualified Synthesizer.State.Filter.Delay as Delay++import qualified Algebra.Module                as Module+import qualified Algebra.RealField             as RealField++-- import qualified Algebra.Field                 as Field+-- import qualified Algebra.Ring                  as Ring+import qualified Algebra.Additive              as Additive++import PreludeBase+import NumericPrelude++++{- |+Like 'Synthesizer.State.Filter.NonRecursive.sums' but in a recursive form.+This needs only linear time (independent of the window size)+but may accumulate rounding errors.++@+ys = xs * (1,0,0,0,-1) \/ (1,-1)+ys * (1,-1) = xs * (1,0,0,0,-1)+ys = xs * (1,0,0,0,-1) + ys * (0,1)+@+-}+{-# INLINE sumsStaticInt #-}+sumsStaticInt :: (Additive.C v) => Int -> Sig.T v -> Sig.T v+sumsStaticInt n xs =+   Integration.run (xs - Delay.staticPos n xs)++{-+staticInt :: (Module.C a v, Additive.C v) => Int -> Sig.T v -> Sig.T v+staticInt n xs =+-}+++{-+Sum of a part of a vector with negative sign for reverse order.+It adds from @from@ (inclusively) to @to@ (exclusively),+that is, it sums up @abs (to-from)@ values++sumFromTo :: (Additive.C v) => Int -> Int -> Sig.T v -> v+sumFromTo from to =+   if from <= to+     then          Sig.sum . Sig.take (to-from) . Sig.drop from+     else negate . Sig.sum . Sig.take (from-to) . Sig.drop to+-}++{-# INLINE sumFromToFrac #-}+sumFromToFrac :: (RealField.C a, Module.C a v) => a -> a -> Sig.T v -> v+sumFromToFrac from to xs =+   let (fromInt, fromFrac) = splitFraction from+       (toInt,   toFrac)   = splitFraction to+   in  case compare fromInt toInt of+          EQ -> (to-from) *> Sig.index fromInt xs+          LT ->+            Sig.sum $+            Sig.zipWith id+               (((1-fromFrac) *>) `Sig.cons`+                Sig.replicate (toInt-fromInt-1) id `Sig.append`+                Sig.singleton (toFrac *>)) $+            Sig.drop fromInt xs+          GT ->+            negate $ Sig.sum $+            Sig.zipWith id+               (((1-toFrac) *>) `Sig.cons`+                Sig.replicate (fromInt-toInt-1) id `Sig.append`+                Sig.singleton (fromFrac *>)) $+            Sig.drop toInt xs+++{-+            run $+               addNextWeighted (1-toFrac) >>+               replicateM_ (fromInt-toInt-1) addNext >>+               addNextWeighted (fromFrac)++type Accumulator v a =+   WriterT (Dual (Endo v)) (StateT (Sig.T v) Maybe a)++getNext :: Accumulator v a+getNext =+   lift $ StateT $ ListHT.viewL++addAccum :: Additive.C v => v -> Accumulator v ()+addAccum x = tell ((x+) $!)++addNext :: Additive.C v => Accumulator v ()+addNext w =+   addAccum =<< getNext++addNextWeighted :: Module.C a v => a -> Accumulator v ()+addNextWeighted w =+   addAccum . (w *>) =<< getNext+-}++{-+newtype Accumulator v =+   Accumulator ((v, Sig.T v) -> v -> (Sig.T v, v))++addNext :: Additive.C v => Accumulator v+addNext =+   Accumulator $ \(x,xs) s -> (xs, x+s)++addNextWeighted :: Module.C a v => a -> Accumulator v+addNextWeighted a =+   Accumulator $ \(x,xs) s -> (xs, a*>x + s)++bindAccum :: Accumulator v -> Accumulator v -> Accumulator v+bindAccum (Accumulator f) (Accumulator g) =+   Accumulator $ \x s0 ->+      let (ys,s1) = f x s0+      in  maybe s1 () (ListHT.viewL ys)+-}+++{- |+Sig.T a must contain only non-negative elements.+-}+{-# INLINE sumDiffsModulated #-}+sumDiffsModulated :: (RealField.C a, Module.C a v) =>+   a -> Sig.T a -> Sig.T v -> Sig.T v+sumDiffsModulated d ds =+   Sig.init .+   -- prevent negative d's since 'drop' cannot restore past values+   Sig.zipWithTails (uncurry sumFromToFrac)+       (Sig.zip (Sig.cons (d+1) ds) (Sig.map (1+) ds)) .+   Sig.cons zero+{-+   Sig.zipWithTails (uncurry sumFromToFrac)+      (Sig.zip (Sig.cons d (Sig.map (subtract 1) ds)) ds)+-}++{-+sumsModulated :: (RealField.C a, Module.C a v) =>+   Int -> Sig.T a -> Sig.T v -> Sig.T v+sumsModulated maxDInt ds xs =+   let maxD  = fromIntegral maxDInt+       posXs = sumDiffsModulated 0 ds xs+       negXs = sumDiffsModulated maxD (Sig.map (maxD-) ds) (Delay.static maxDInt xs)+   in  Integration.run (posXs - negXs)+-}++{- |+Shift sampling points by a half sample period+in order to preserve signals for window widths below 1.+-}+{-# INLINE sumsModulatedHalf #-}+sumsModulatedHalf :: (RealField.C a, Module.C a v) =>+   Int -> Sig.T a -> Sig.T v -> Sig.T v+sumsModulatedHalf maxDInt ds xs =+   let maxD  = fromIntegral maxDInt+       d0    = maxD+0.5+       delXs = Delay.staticPos maxDInt xs+       posXs = sumDiffsModulated d0 (Sig.map (d0+) ds) delXs+       negXs = sumDiffsModulated d0 (Sig.map (d0-) ds) delXs+   in  Integration.run (posXs - negXs)++{-# INLINE modulatedFrac #-}+modulatedFrac :: (RealField.C a, Module.C a v) =>+   Int -> Sig.T a -> Sig.T v -> Sig.T v+modulatedFrac maxDInt ds xs =+   Sig.zipWith (\d y -> recip (2*d) *> y) ds $+   sumsModulatedHalf maxDInt ds xs+
+ src/Synthesizer/State/Interpolation.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE NoImplicitPrelude #-}+module Synthesizer.State.Interpolation where++import qualified Synthesizer.Interpolation as Interpolation+import Synthesizer.Interpolation+   (T, offset, number, func, )++import qualified Synthesizer.State.Signal  as Sig++-- import qualified Algebra.Module    as Module+import qualified Algebra.RealField as RealField+-- import qualified Algebra.Field     as Field+import qualified Algebra.Ring      as Ring+import qualified Algebra.Additive  as Additive++import Data.Maybe (fromMaybe)++import PreludeBase+import NumericPrelude+++{-* Interpolation with various padding methods -}++{-# INLINE zeroPad #-}+zeroPad :: (RealField.C t) =>+   (T t y -> t -> Sig.T y -> a) ->+   y -> T t y -> t -> Sig.T y -> a+zeroPad interpolate z ip phase x =+   let (phInt, phFrac) = splitFraction phase+   in  interpolate ip phFrac+          (delayPad z (offset ip - phInt) (Sig.append x (Sig.repeat z)))++{-# INLINE constantPad #-}+constantPad :: (RealField.C t) =>+   (T t y -> t -> Sig.T y -> a) ->+   T t y -> t -> Sig.T y -> a+constantPad interpolate ip phase x =+   let (phInt, phFrac) = splitFraction phase+       xPad =+          do (xFirst,_) <- Sig.viewL x+             return (delayPad xFirst (offset ip - phInt) (Sig.extendConstant x))+   in  interpolate ip phFrac+          (fromMaybe Sig.empty xPad)+++{- |+Only for finite input signals.+-}+{-# INLINE cyclicPad #-}+cyclicPad :: (RealField.C t) =>+   (T t y -> t -> Sig.T y -> a) ->+   T t y -> t -> Sig.T y -> a+cyclicPad interpolate ip phase x =+   let (phInt, phFrac) = splitFraction phase+   in  interpolate ip phFrac+          (Sig.drop (mod (phInt - offset ip) (Sig.length x)) (Sig.cycle x))++{- |+The extrapolation may miss some of the first and some of the last points+-}+{-# INLINE extrapolationPad #-}+extrapolationPad :: (RealField.C t) =>+   (T t y -> t -> Sig.T y -> a) ->+   T t y -> t -> Sig.T y -> a+extrapolationPad interpolate ip phase =+   interpolate ip (phase - fromIntegral (offset ip))+{-+  This example shows pikes, although there shouldn't be any:+   plotList (take 100 $ interpolate (Zero (0::Double)) ipCubic (-0.9::Double) (repeat 0.03) [1,0,1,0.8])+-}+++{-* Helper methods for interpolation of multiple nodes -}++{-# INLINE skip #-}+skip :: (RealField.C t) =>+   T t y -> (t, Sig.T y) -> (t, Sig.T y)+skip ip (phase0, x0) =+   let (n, frac) = splitFraction phase0+       (m, x1) = Sig.dropMarginRem (number ip) n x0+   in  (fromIntegral m + frac, x1)++{-# INLINE single #-}+single :: (RealField.C t) =>+   T t y -> t -> Sig.T y -> y+single ip phase0 x0 =+   uncurry (func ip) $ skip ip (phase0, x0)+--   curry (uncurry (func ip) . skip ip)+{-+GNUPlot.plotFunc [] (GNUPlot.linearScale 1000 (0,2)) (\t -> single linear (t::Double) [0,4,1::Double])+-}+++{-* Helper functions -}++{-# INLINE delayPad #-}+delayPad :: y -> Int -> Sig.T y -> Sig.T y+delayPad z n =+   if n<0+     then Sig.drop (negate n)+     else Sig.append (Sig.replicate n z)
+ src/Synthesizer/State/Miscellaneous.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE NoImplicitPrelude #-}+module Synthesizer.State.Miscellaneous where++import qualified Synthesizer.State.Signal as Signal++import qualified Algebra.NormedSpace.Euclidean as Euc+-- import qualified Algebra.Module                as Module+-- import qualified Algebra.Transcendental        as Trans+import qualified Algebra.Field                 as Field+-- import qualified Algebra.Ring                  as Ring+-- import qualified Algebra.Additive              as Additive++-- import qualified Prelude as P+-- import PreludeBase+import NumericPrelude++{- * Spatial effects -}++{-| simulate an moving sounding object+   convert the way of the object through 3D space+   into a delay and attenuation information,+   sonicDelay is the reciprocal of the sonic velocity -}+{-# INLINE receive3Dsound #-}+receive3Dsound :: (Field.C a, Euc.C a v) =>+   a -> a -> v -> Signal.T v -> (Signal.T a,Signal.T a)+receive3Dsound att sonicDelay ear way =+   let dists   = Signal.map Euc.norm (Signal.map (subtract ear) way)+       phase   = Signal.map (sonicDelay*) dists+       volumes = Signal.map (\x -> 1/(att+x)^2) dists+   in  (phase, volumes)
+ src/Synthesizer/State/Noise.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE NoImplicitPrelude #-}+{- | Noise and random processes. -}+module Synthesizer.State.Noise where++import qualified Synthesizer.State.Signal as Sig++import qualified Algebra.Real                  as Real+import qualified Algebra.Ring                  as Ring++import System.Random (Random, RandomGen, randomR, mkStdGen, )+import qualified System.Random as Rnd++import qualified Prelude as P+import PreludeBase+import NumericPrelude+++{-|+Deterministic white noise, uniformly distributed between -1 and 1.+That is, variance is 1\/3.+-}+{-# INLINE white #-}+white :: (Ring.C y, Random y) =>+   Sig.T y+white = whiteGen (mkStdGen 12354)++{-# INLINE whiteGen #-}+whiteGen ::+   (Ring.C y, Random y, RandomGen g) =>+   g -> Sig.T y+whiteGen = randomRs (-1,1)+++{- |+Approximates normal distribution with variance 1+by a quadratic B-spline distribution.+-}+{-# INLINE whiteQuadraticBSplineGen #-}+whiteQuadraticBSplineGen ::+   (Ring.C y, Random y, RandomGen g) =>+   g -> Sig.T y+whiteQuadraticBSplineGen g =+   let (g0,gr) = Rnd.split g+       (g1,g2) = Rnd.split gr+   in  whiteGen g0 `Sig.mix`+       whiteGen g1 `Sig.mix`+       whiteGen g2+++{-# INLINE randomPeeks #-}+randomPeeks :: (Real.C y, Random y) =>+      Sig.T y    {- ^ momentary densities, @p@ means that there is about one peak+                      in the time range of @1\/p@ samples -}+   -> Sig.T Bool {- ^ Every occurence of 'True' represents a peak. -}+randomPeeks =+   randomPeeksGen (mkStdGen 876)++{-# INLINE randomPeeksGen #-}+randomPeeksGen :: (Real.C y, Random y, RandomGen g) =>+      g+   -> Sig.T y+   -> Sig.T Bool+randomPeeksGen =+   Sig.zipWith (<) . randomRs (0,1)++++{-# INLINE randomRs #-}+randomRs ::+   (Ring.C y, Random y, RandomGen g) =>+   (y,y) -> g -> Sig.T y+randomRs bnd = Sig.unfoldR (Just . randomR bnd)
+ src/Synthesizer/State/NoiseCustom.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE NoImplicitPrelude #-}+{- |+Noise and random processes.+This uses a fast reimplementation of 'System.Random.randomR'+since the standard function seems not to be inlined (at least in GHC-6.8.2).+-}+module Synthesizer.State.NoiseCustom where++import qualified Synthesizer.State.Signal as Sig++import qualified Algebra.RealField             as RealField+import qualified Algebra.Field                 as Field++import qualified Synthesizer.RandomKnuth as Knuth++import System.Random (Random, RandomGen, )+import qualified System.Random as Rnd++import qualified Prelude as P+import PreludeBase+import NumericPrelude+++{-|+Deterministic white noise, uniformly distributed between -1 and 1.+That is, variance is 1\/3.+-}+{-# INLINE white #-}+white :: (Field.C y, Random y) =>+   Sig.T y+white = whiteGen (Knuth.cons 12354)++{-# INLINE whiteGen #-}+whiteGen ::+   (Field.C y, Random y, RandomGen g) =>+   g -> Sig.T y+whiteGen = randomRs (-1,1)+++{- |+Approximates normal distribution with variance 1+by a quadratic B-spline distribution.+-}+{-# INLINE whiteQuadraticBSplineGen #-}+whiteQuadraticBSplineGen ::+   (Field.C y, Random y, RandomGen g) =>+   g -> Sig.T y+whiteQuadraticBSplineGen g =+   let (g0,gr) = Rnd.split g+       (g1,g2) = Rnd.split gr+   in  whiteGen g0 `Sig.mix`+       whiteGen g1 `Sig.mix`+       whiteGen g2+++{-# INLINE randomPeeks #-}+randomPeeks :: (RealField.C y, Random y) =>+      Sig.T y    {- ^ momentary densities, @p@ means that there is about one peak+                      in the time range of @1\/p@ samples -}+   -> Sig.T Bool {- ^ Every occurence of 'True' represents a peak. -}+randomPeeks =+   randomPeeksGen (Knuth.cons 876)++{-# INLINE randomPeeksGen #-}+randomPeeksGen :: (RealField.C y, Random y, RandomGen g) =>+      g+   -> Sig.T y+   -> Sig.T Bool+randomPeeksGen =+   Sig.zipWith (<) . randomRs (0,1)+++{-# INLINE randomRs #-}+randomRs ::+   (Field.C y, Random y, RandomGen g) =>+   (y,y) -> g -> Sig.T y+randomRs bnd = Sig.unfoldR (Just . randomR bnd)++{-# INLINE randomR #-}+randomR ::+   (RandomGen g, Field.C y) =>+   (y, y) -> g -> (y, g)+randomR (lower,upper) g0 =+   let (n,g1) = Rnd.next g0+       (l,u) = Rnd.genRange g0+       nd = fromIntegral n+       ld = fromIntegral l+       ud = fromIntegral u+       x01 = (nd-ld)/(ud-ld)+   in  ((1-x01)*lower + x01*upper, g1)
+ src/Synthesizer/State/Oscillator.hs view
@@ -0,0 +1,177 @@+{-# LANGUAGE NoImplicitPrelude #-}+{- |+Copyright   :  (c) Henning Thielemann 2006+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes++Tone generators+-}+module Synthesizer.State.Oscillator where++import qualified Synthesizer.Causal.Oscillator  as Osci+import qualified Synthesizer.Basic.WaveSmoothed as WaveSmooth+import qualified Synthesizer.Basic.Wave         as Wave+import qualified Synthesizer.Basic.Phase        as Phase++import qualified Synthesizer.Causal.Process as Causal+import qualified Synthesizer.State.Signal as Sig++import qualified Synthesizer.Generic.Signal as SigG++import qualified Synthesizer.Interpolation as Interpolation+++import qualified Algebra.Transcendental        as Trans+import qualified Algebra.RealField             as RealField++-- import qualified Prelude as P+-- import NumericPrelude+-- import PreludeBase++++{- * Oscillators with arbitrary but constant waveforms -}++{-# INLINE static #-}+{- |+Oscillator with constant frequency.+It causes aliasing effects for sharp waveforms and high frequencies.+-}+static :: (RealField.C a) => Wave.T a b -> (Phase.T a -> a -> Sig.T b)+static wave phase freq =+    Sig.map (Wave.apply wave) (Osci.freqToPhases phase freq)++{-# INLINE staticAntiAlias #-}+{- |+Oscillator with constant frequency+that suppresses aliasing effects using waveforms with controllable smoothness.+-}+staticAntiAlias :: (RealField.C a) =>+    WaveSmooth.T a b -> (Phase.T a -> a -> Sig.T b)+staticAntiAlias wave phase freq =+    Sig.map (WaveSmooth.apply wave freq) (Osci.freqToPhases phase freq)++{-# INLINE phaseMod #-}+{- | oscillator with modulated phase -}+phaseMod :: (RealField.C a) => Wave.T a b -> a -> Sig.T a -> Sig.T b+phaseMod wave freq =+    Causal.apply (Osci.phaseMod wave freq)++{-# INLINE shapeMod #-}+{- | oscillator with modulated shape -}+shapeMod :: (RealField.C a) =>+    (c -> Wave.T a b) -> Phase.T a -> a -> Sig.T c -> Sig.T b+shapeMod wave phase freq =+    Causal.apply (Osci.shapeMod wave phase freq)++{-# INLINE freqMod #-}+{- | oscillator with modulated frequency -}+freqMod :: (RealField.C a) => Wave.T a b -> Phase.T a -> Sig.T a -> Sig.T b+freqMod wave phase =+    Causal.apply (Osci.freqMod wave phase)++{-# INLINE freqModAntiAlias #-}+{- | oscillator with modulated frequency -}+freqModAntiAlias :: (RealField.C a) =>+    WaveSmooth.T a b -> Phase.T a -> Sig.T a -> Sig.T b+freqModAntiAlias wave phase =+    Causal.apply (Osci.freqModAntiAlias wave phase)++{-# INLINE phaseFreqMod #-}+{- | oscillator with both phase and frequency modulation -}+phaseFreqMod :: (RealField.C a) =>+    Wave.T a b -> Sig.T a -> Sig.T a -> Sig.T b+phaseFreqMod wave =+    Causal.apply2 (Osci.phaseFreqMod wave)++{-# INLINE shapeFreqMod #-}+{- | oscillator with both shape and frequency modulation -}+shapeFreqMod :: (RealField.C a) =>+    (c -> Wave.T a b) -> Phase.T a -> Sig.T c -> Sig.T a -> Sig.T b+shapeFreqMod wave phase =+    Causal.apply2 (Osci.shapeFreqMod wave phase)+++{- | oscillator with a sampled waveform with constant frequency+     This essentially an interpolation with cyclic padding. -}+{-# INLINE staticSample #-}+staticSample :: RealField.C a =>+    Interpolation.T a b -> Sig.T b -> Phase.T a -> a -> Sig.T b+staticSample ip wave phase freq =+    Causal.apply (Osci.freqModSample ip wave phase) (Sig.repeat freq)++{- | oscillator with a sampled waveform with modulated frequency+     Should behave homogenously for different types of interpolation. -}+{-# INLINE freqModSample #-}+freqModSample :: RealField.C a =>+    Interpolation.T a b -> Sig.T b -> Phase.T a -> Sig.T a -> Sig.T b+freqModSample ip wave phase =+    Causal.apply (Osci.freqModSample ip wave phase)++{-# INLINE shapeFreqModSample #-}+shapeFreqModSample :: (RealField.C c, RealField.C a) =>+    Interpolation.T c (Wave.T a b) -> Sig.T (Wave.T a b) ->+    c -> Phase.T a ->+    Sig.T c -> Sig.T a -> Sig.T b+shapeFreqModSample ip waves shape0 phase =+    Causal.apply2 (Osci.shapeFreqModSample ip waves shape0 phase)++{-# INLINE shapeFreqModFromSampledTone #-}+shapeFreqModFromSampledTone ::+    (RealField.C a, SigG.Transform sig b) =>+    Interpolation.T a b ->+    Interpolation.T a b ->+    a -> sig b ->+    a -> Phase.T a ->+    Sig.T a -> Sig.T a -> Sig.T b+shapeFreqModFromSampledTone+      ipLeap ipStep period sampledTone shape0 phase =+    Causal.apply2+       (Osci.shapeFreqModFromSampledTone+          ipLeap ipStep period sampledTone shape0 phase)++{-# INLINE shapePhaseFreqModFromSampledTone #-}+shapePhaseFreqModFromSampledTone ::+    (RealField.C a, SigG.Transform sig b) =>+    Interpolation.T a b ->+    Interpolation.T a b ->+    a -> sig b ->+    a -> Phase.T a ->+    Sig.T a -> Sig.T a -> Sig.T a -> Sig.T b+shapePhaseFreqModFromSampledTone+      ipLeap ipStep period sampledTone shape0 phase =+    Causal.apply3+       (Osci.shapePhaseFreqModFromSampledTone+          ipLeap ipStep period sampledTone shape0 phase)++++{- * Oscillators with specific waveforms -}++{-# INLINE staticSine #-}+{- | sine oscillator with static frequency -}+staticSine :: (Trans.C a, RealField.C a) => Phase.T a -> a -> Sig.T a+staticSine = static Wave.sine++{-# INLINE freqModSine #-}+{- | sine oscillator with modulated frequency -}+freqModSine :: (Trans.C a, RealField.C a) => Phase.T a -> Sig.T a -> Sig.T a+freqModSine = freqMod Wave.sine++{-# INLINE phaseModSine #-}+{- | sine oscillator with modulated phase, useful for FM synthesis -}+phaseModSine :: (Trans.C a, RealField.C a) => a -> Sig.T a -> Sig.T a+phaseModSine = phaseMod Wave.sine++{-# INLINE staticSaw #-}+{- | saw tooth oscillator with modulated frequency -}+staticSaw :: RealField.C a => Phase.T a -> a -> Sig.T a+staticSaw = static Wave.saw++{-# INLINE freqModSaw #-}+{- | saw tooth oscillator with modulated frequency -}+freqModSaw :: RealField.C a => Phase.T a -> Sig.T a -> Sig.T a+freqModSaw = freqMod Wave.saw
+ src/Synthesizer/State/Signal.hs view
@@ -0,0 +1,728 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ExistentialQuantification #-}+{- |+ToDo:+Better name for the module is certainly+  Synthesizer.Generator.Signal+-}+module Synthesizer.State.Signal where++-- import qualified Synthesizer.Plain.Signal   as Sig+import qualified Synthesizer.Plain.Modifier as Modifier+import qualified Data.List as List++import qualified Algebra.Module   as Module+import qualified Algebra.Additive as Additive+import Algebra.Additive (zero)++import Algebra.Module ((*>))++import qualified Synthesizer.Format as Format++import Control.Monad.Trans.State+          (runState, StateT(StateT), runStateT, )+import Control.Monad (Monad, mplus, msum,+           (>>), (>>=), fail, return, (=<<),+           liftM2,+           Functor, fmap, )++import Data.Monoid (Monoid, mappend, mempty, )++import qualified Synthesizer.Storable.Signal as SigSt+import qualified Data.StorableVector.Lazy.Pattern as SVL+import Foreign.Storable (Storable)++import qualified Data.List.HT as ListHT+import Data.Tuple.HT (mapFst, mapSnd, mapPair, fst3, snd3, thd3, )+import Data.Function.HT (nest, )+import Data.Maybe.HT (toMaybe, )+import NumericPrelude (fromInteger, )++import Text.Show (Show(showsPrec), showParen, showString, )+import Data.Maybe (Maybe(Just, Nothing), maybe, fromMaybe, )+import Prelude+   ((.), ($), ($!), id, const, flip, curry, uncurry, fst, snd, error,+    (>), (>=), max, Ord,+    succ, pred, Bool(True,False), not, Int,+--    fromInteger,+    )+++-- | Cf. StreamFusion  Data.Stream+data T a =+   forall s. -- Seq s =>+      Cons !(StateT s Maybe a)  -- compute next value+           !s                   -- initial state+++instance (Show y) => Show (T y) where+   showsPrec p x =+      showParen (p >= 10)+         (showString "StateSignal.fromList " . showsPrec 11 (toList x))++instance Format.C T where+   format = showsPrec++instance Functor T where+   fmap = map++++{-# INLINE generate #-}+generate :: (acc -> Maybe (y, acc)) -> acc -> T y+generate f = Cons (StateT f)++{-# INLINE unfoldR #-}+unfoldR :: (acc -> Maybe (y, acc)) -> acc -> T y+unfoldR = generate++{-# INLINE generateInfinite #-}+generateInfinite :: (acc -> (y, acc)) -> acc -> T y+generateInfinite f = generate (Just . f)++{-# INLINE fromList #-}+fromList :: [y] -> T y+fromList = generate ListHT.viewL++{-# INLINE toList #-}+toList :: T y -> [y]+toList (Cons f x0) =+   List.unfoldr (runStateT f) x0+++{-# INLINE fromStorableSignal #-}+fromStorableSignal ::+   (Storable a) =>+   SigSt.T a -> T a+fromStorableSignal =+   generate SigSt.viewL++{-# INLINE toStorableSignal #-}+toStorableSignal ::+   (Storable a) =>+   SigSt.ChunkSize -> T a -> SigSt.T a+toStorableSignal size (Cons f a) =+   SigSt.unfoldr size (runStateT f) a++-- needed in synthesizer-alsa+{-# INLINE toStorableSignalVary #-}+toStorableSignalVary ::+   (Storable a) =>+   SVL.LazySize -> T a -> SigSt.T a+toStorableSignalVary size (Cons f a) =+   fst $ SVL.unfoldrN size (runStateT f) a++++{-# INLINE iterate #-}+iterate :: (a -> a) -> a -> T a+iterate f = generateInfinite (\x -> (x, f x))++{-# INLINE iterateAssociative #-}+iterateAssociative :: (a -> a -> a) -> a -> T a+iterateAssociative op x = iterate (op x) x -- should be optimized++{-# INLINE repeat #-}+repeat :: a -> T a+repeat = iterate id+++++{-# INLINE crochetL #-}+crochetL :: (x -> acc -> Maybe (y, acc)) -> acc -> T x -> T y+crochetL g b (Cons f a) =+   Cons+      (StateT (\(a0,b0) ->+          do (x0,a1) <- runStateT f a0+             (y0,b1) <- g x0 b0+             Just (y0, (a1,b1))))+      (a,b)+++{-# INLINE scanL #-}+scanL :: (acc -> x -> acc) -> acc -> T x -> T acc+scanL f start =+   cons start .+   crochetL (\x acc -> let y = f acc x in Just (y, y)) start+++{-# INLINE scanLClip #-}+-- | input and output have equal length, that's better for fusion+scanLClip :: (acc -> x -> acc) -> acc -> T x -> T acc+scanLClip f start =+   crochetL (\x acc -> Just (acc, f acc x)) start++{-# INLINE map #-}+map :: (a -> b) -> (T a -> T b)+map f = crochetL (\x _ -> Just (f x, ())) ()+++{- |+This function will recompute the input lists+and is thus probably not what you want.+If you want to avoid recomputation please consider Causal.Process.+-}+{-# INLINE unzip #-}+unzip :: T (a,b) -> (T a, T b)+unzip x = (map fst x, map snd x)++{-# INLINE unzip3 #-}+unzip3 :: T (a,b,c) -> (T a, T b, T c)+unzip3 xs = (map fst3 xs, map snd3 xs, map thd3 xs)+++{-# INLINE delay1 #-}+{- |+This is a fusion friendly implementation of delay.+However, in order to be a 'crochetL'+the output has the same length as the input,+that is, the last element is removed - at least for finite input.+-}+delay1 :: a -> T a -> T a+delay1 = crochetL (flip (curry Just))++{-# INLINE delay #-}+delay :: y -> Int -> T y -> T y+delay z n = append (replicate n z)++{-# INLINE take #-}+take :: Int -> T a -> T a+take = crochetL (\x n -> toMaybe (n>zero) (x, pred n))++{-# INLINE takeWhile #-}+takeWhile :: (a -> Bool) -> T a -> T a+takeWhile p = crochetL (\x _ -> toMaybe (p x) (x, ())) ()++{-# INLINE replicate #-}+replicate :: Int -> a -> T a+replicate n = take n . repeat+++{- * functions consuming multiple lists -}++{-# INLINE zipWith #-}+zipWith :: (a -> b -> c) -> (T a -> T b -> T c)+zipWith h (Cons f a) =+   crochetL+      (\x0 a0 ->+          do (y0,a1) <- runStateT f a0+             Just (h y0 x0, a1))+      a++{-# INLINE zipWithStorable #-}+zipWithStorable :: (Storable b, Storable c) =>+   (a -> b -> c) -> (T a -> SigSt.T b -> SigSt.T c)+zipWithStorable h (Cons f a) =+   SigSt.crochetL+      (\x0 a0 ->+          do (y0,a1) <- runStateT f a0+             Just (h y0 x0, a1))+      a++{-# INLINE zipWith3 #-}+zipWith3 :: (a -> b -> c -> d) -> (T a -> T b -> T c -> T d)+zipWith3 f s0 s1 =+   zipWith (uncurry f) (zip s0 s1)++{-# INLINE zipWith4 #-}+zipWith4 :: (a -> b -> c -> d -> e) -> (T a -> T b -> T c -> T d -> T e)+zipWith4 f s0 s1 =+   zipWith3 (uncurry f) (zip s0 s1)+++{-# INLINE zip #-}+zip :: T a -> T b -> T (a,b)+zip = zipWith (,)++{-# INLINE zip3 #-}+zip3 :: T a -> T b -> T c -> T (a,b,c)+zip3 = zipWith3 (,,)++{-# INLINE zip4 #-}+zip4 :: T a -> T b -> T c -> T d -> T (a,b,c,d)+zip4 = zipWith4 (,,,)+++{- * functions based on 'foldL' -}++{-# INLINE foldL' #-}+foldL' :: (x -> acc -> acc) -> acc -> T x -> acc+foldL' g b =+   switchL b (\ x xs -> foldL' g (g x $! b) xs)++{-# INLINE foldL #-}+foldL :: (acc -> x -> acc) -> acc -> T x -> acc+foldL f = foldL' (flip f)++{-# INLINE length #-}+length :: T a -> Int+length = foldL' (const succ) zero+++{- * functions based on 'foldR' -}++foldR :: (x -> acc -> acc) -> acc -> T x -> acc+foldR g b =+   switchL b (\ x xs -> g x (foldR g b xs))+++{- * Other functions -}++{-# INLINE null #-}+null :: T a -> Bool+null =+   switchL True (const (const False))+   -- foldR (const (const False)) True++{-# INLINE empty #-}+empty :: T a+empty = generate (const Nothing) ()++{-# INLINE singleton #-}+singleton :: a -> T a+singleton =+   generate (fmap (\x -> (x, Nothing))) . Just++{-# INLINE cons #-}+{- |+This is expensive and should not be used to construct lists iteratively!+-}+cons :: a -> T a -> T a+cons x xs =+   generate+      (\(mx0,xs0) ->+          fmap (mapSnd ((,) Nothing)) $+          maybe+             (viewL xs0)+             (\x0 -> Just (x0, xs0))+             mx0) $+   (Just x, xs)++{-# INLINE viewL #-}+viewL :: T a -> Maybe (a, T a)+viewL (Cons f a0) =+   fmap+      (mapSnd (Cons f))+      (runStateT f a0)++{- iterated 'cons' is very inefficient+viewR :: T a -> Maybe (T a, a)+viewR =+   foldR (\x mxs -> Just (maybe (empty,x) (mapFst (cons x)) mxs)) Nothing+-}++{-# INLINE viewR #-}+viewR :: Storable a => T a -> Maybe (T a, a)+viewR = viewRSize SigSt.defaultChunkSize++{-# INLINE viewRSize #-}+viewRSize :: Storable a => SigSt.ChunkSize -> T a -> Maybe (T a, a)+viewRSize size =+   fmap (mapFst fromStorableSignal) .+   SigSt.viewR .+   toStorableSignal size+++{-# INLINE switchL #-}+switchL :: b -> (a -> T a -> b) -> T a -> b+switchL n j =+   maybe n (uncurry j) . viewL++{-# INLINE switchR #-}+switchR :: Storable a => b -> (T a -> a -> b) -> T a -> b+switchR n j =+   maybe n (uncurry j) . viewR+++{- |+This implementation requires+that the input generator has to check repeatedly whether it is finished.+-}+{-# INLINE extendConstant #-}+extendConstant :: T a -> T a+extendConstant xt0 =+   switchL+      empty+      (\ x0 _ ->+          generate+             (\xt1@(x1,xs1) ->+                 Just $ switchL+                    (x1,xt1)+                    (\x xs -> (x, (x,xs)))+                    xs1)+             (x0,xt0)) $+      xt0+++{-+{-# INLINE tail #-}+tail :: T a -> T a+tail = Cons . List.tail . decons++{-# INLINE head #-}+head :: T a -> a+head = List.head . decons+-}++{-# INLINE drop #-}+drop :: Int -> T a -> T a+drop n =+   fromMaybe empty .+   nest n (fmap snd . viewL =<<) .+   Just++{-# INLINE dropMarginRem #-}+{- |+This implementation expects that looking ahead is cheap.+-}+dropMarginRem :: Int -> Int -> T a -> (Int, T a)+dropMarginRem n m =+   switchL (error "StateSignal.dropMaringRem: length xs < n") const .+   dropMargin n m .+   zipWithTails (,) (iterate pred m)++{-# INLINE dropMargin #-}+dropMargin :: Int -> Int -> T a -> T a+dropMargin n m xs =+   dropMatch (take m (drop n xs)) xs+++dropMatch :: T b -> T a -> T a+dropMatch xs ys =+   fromMaybe ys $+   liftM2 dropMatch+      (fmap snd $ viewL xs)+      (fmap snd $ viewL ys)+++index :: Int -> T a -> a+index n =+   switchL (error "State.Signal: index too large") const . drop n+++{-+splitAt :: Int -> T a -> (T a, T a)+splitAt n = mapPair (Cons, Cons) . List.splitAt n . decons+-}++{-# INLINE splitAt #-}+splitAt :: Storable a =>+   Int -> T a -> (T a, T a)+splitAt = splitAtSize SigSt.defaultChunkSize++{-# INLINE splitAtSize #-}+splitAtSize :: Storable a =>+   SigSt.ChunkSize -> Int -> T a -> (T a, T a)+splitAtSize size n =+   mapPair (fromStorableSignal, fromStorableSignal) .+   SigSt.splitAt n .+   toStorableSignal size+++{-# INLINE dropWhile #-}+dropWhile :: (a -> Bool) -> T a -> T a+dropWhile p xt =+   switchL empty (\ x xs -> if p x then dropWhile p xs else xt) xt++{-+span :: (a -> Bool) -> T a -> (T a, T a)+span p = mapPair (Cons, Cons) . List.span p . decons+-}++{-# INLINE span #-}+span :: Storable a =>+   (a -> Bool) -> T a -> (T a, T a)+span = spanSize SigSt.defaultChunkSize++{-# INLINE spanSize #-}+spanSize :: Storable a =>+   SigSt.ChunkSize -> (a -> Bool) -> T a -> (T a, T a)+spanSize size p =+   mapPair (fromStorableSignal, fromStorableSignal) .+   SigSt.span p .+   toStorableSignal size+++{-# INLINE cycle #-}+cycle :: T a -> T a+cycle xs =+   switchL+      (error "StateSignal.cycle: empty input")+      (curry $ \yt -> generate (Just . fromMaybe yt . viewL) xs)+      xs++{-# INLINE mix #-}+mix :: Additive.C a => T a -> T a -> T a+mix = zipWithAppend (Additive.+)+++{-# INLINE sub #-}+sub :: Additive.C a => T a -> T a -> T a+sub xs ys =  mix xs (neg ys)++{-# INLINE neg #-}+neg :: Additive.C a => T a -> T a+neg = map Additive.negate++instance Additive.C y => Additive.C (T y) where+   zero = empty+   (+) = mix+   (-) = sub+   negate = neg++instance Module.C y yv => Module.C y (T yv) where+   (*>) x y = map (x*>) y+++infixr 5 `append`++{-# INLINE append #-}+append :: T a -> T a -> T a+append xs ys =+   generate+      (\(b,xs0) ->+          mplus+             (fmap (mapSnd ((,) b)) $ viewL xs0)+             (if b+                then Nothing+                else fmap (mapSnd ((,) True)) $ viewL ys))+      (False,xs)++{-# INLINE appendStored #-}+appendStored :: Storable a =>+   T a -> T a -> T a+appendStored = appendStoredSize SigSt.defaultChunkSize++{-# INLINE appendStoredSize #-}+appendStoredSize :: Storable a =>+   SigSt.ChunkSize -> T a -> T a -> T a+appendStoredSize size xs ys =+   fromStorableSignal $+   SigSt.append+      (toStorableSignal size xs)+      (toStorableSignal size ys)++{-# INLINE concat #-}+-- | certainly inefficient because of frequent list deconstruction+concat :: [T a] -> T a+concat =+   generate+      (msum .+       List.map+          (\ x -> ListHT.viewL x >>=+           \(y,ys) -> viewL y >>=+           \(z,zs) -> Just (z,zs:ys)) .+       List.init . List.tails)+++{-# INLINE concatStored #-}+concatStored :: Storable a =>+   [T a] -> T a+concatStored = concatStoredSize SigSt.defaultChunkSize++{-# INLINE concatStoredSize #-}+concatStoredSize :: Storable a =>+   SigSt.ChunkSize -> [T a] -> T a+concatStoredSize size =+   fromStorableSignal .+   SigSt.concat .+   List.map (toStorableSignal size)++{-# INLINE reverse #-}+reverse ::+   T a -> T a+reverse =+   fromList . List.reverse . toList++{-# INLINE reverseStored #-}+reverseStored :: Storable a =>+   T a -> T a+reverseStored = reverseStoredSize SigSt.defaultChunkSize++{-# INLINE reverseStoredSize #-}+reverseStoredSize :: Storable a =>+   SigSt.ChunkSize -> T a -> T a+reverseStoredSize size =+   fromStorableSignal .+   SigSt.reverse .+   toStorableSignal size+++{-# INLINE sum #-}+sum :: (Additive.C a) => T a -> a+sum = foldL' (Additive.+) Additive.zero++{-# INLINE maximum #-}+maximum :: (Ord a) => T a -> a+maximum =+   switchL+      (error "StateSignal.maximum: empty list")+      (foldL' max)++{-+{-# INLINE tails #-}+tails :: T y -> [T y]+tails = List.map Cons . List.tails . decons+-}++{-# INLINE init #-}+init :: T y -> T y+init =+   switchL+      (error "StateSignal.init: empty list")+      (crochetL (\x acc -> Just (acc,x)))++{-# INLINE sliceVert #-}+-- inefficient since it computes some things twice+sliceVert :: Int -> T y -> [T y]+sliceVert n =+--   map fromList . Sig.sliceVert n . toList+   List.map (take n) . List.takeWhile (not . null) . List.iterate (drop n)++{-# INLINE zapWith #-}+zapWith :: (a -> a -> b) -> T a -> T b+zapWith f =+   switchL empty+      (crochetL (\y x -> Just (f x y, y)))++zapWithAlt :: (a -> a -> b) -> T a -> T b+zapWithAlt f xs =+   zipWith f xs (switchL empty (curry snd) xs)++{-# INLINE modifyStatic #-}+modifyStatic :: Modifier.Simple s ctrl a b -> ctrl -> T a -> T b+modifyStatic modif control x =+   crochetL+      (\a acc ->+         Just (runState (Modifier.step modif control a) acc))+      (Modifier.init modif) x++{-| Here the control may vary over the time. -}+{-# INLINE modifyModulated #-}+modifyModulated :: Modifier.Simple s ctrl a b -> T ctrl -> T a -> T b+modifyModulated modif control x =+   crochetL+      (\ca acc ->+         Just (runState (uncurry (Modifier.step modif) ca) acc))+      (Modifier.init modif)+      (zip control x)+++-- cf. Module.linearComb+{-# INLINE linearComb #-}+linearComb ::+   (Module.C t y) =>+   T t -> T y -> y+linearComb ts ys =+   sum $ zipWith (*>) ts ys+++-- comonadic 'bind'+-- only non-empty suffixes are processed+{-# INLINE mapTails #-}+mapTails ::+   (T y0 -> y1) -> T y0 -> T y1+mapTails f =+   generate (\xs ->+      do (_,ys) <- viewL xs+         return (f xs, ys))++-- only non-empty suffixes are processed+{-# INLINE zipWithTails #-}+zipWithTails ::+   (y0 -> T y1 -> y2) -> T y0 -> T y1 -> T y2+zipWithTails f =+   curry $ generate (\(xs0,ys0) ->+      do (x,xs) <- viewL xs0+         (_,ys) <- viewL ys0+         return (f x ys0, (xs,ys)))++{-+This can hardly be implemented in an efficient way.+But this means, we cannot implement the Generic.Transform class.++zipWithRest ::+   (y0 -> y0 -> y1) ->+   T y0 -> T y0 ->+   (T y1, (Bool, T y0))+zipWithRest f =+   curry $ generate (\(xs0,ys0) ->+      do (x,xs) <- viewL xs0+         (y,ys) <- viewL ys0+         return (f x y, (xs,ys)))+-}+++{-# INLINE zipWithAppend #-}+zipWithAppend ::+   (y -> y -> y) ->+   T y -> T y -> T y+zipWithAppend f =+   curry (unfoldR (zipStep f))++{-# INLINE zipStep #-}+zipStep ::+   (a -> a -> a) -> (T a, T a) -> Maybe (a, (T a, T a))+zipStep f (xt,yt) =+   case (viewL xt, viewL yt) of+      (Just (x,xs), Just (y,ys)) -> Just (f x y, (xs,ys))+      (Nothing,     Just (y,ys)) -> Just (y,     (xt,ys))+      (Just (x,xs), Nothing)     -> Just (x,     (xs,yt))+      (Nothing,     Nothing)     -> Nothing++++delayLoop ::+      (T y -> T y)+            -- ^ processor that shall be run in a feedback loop+   -> T y   -- ^ prefix of the output, its length determines the delay+   -> T y+delayLoop proc prefix =+   -- the temporary list is need for sharing the output+   let ys = fromList (toList prefix List.++ toList (proc ys))+   in  ys++delayLoopOverlap ::+   (Additive.C y) =>+      Int+   -> (T y -> T y)+            -- ^ processor that shall be run in a feedback loop+   -> T y   -- ^ input+   -> T y   -- ^ output has the same length as the input+delayLoopOverlap time proc xs =+   -- the temporary list is need for sharing the output+   let ys = zipWith (Additive.+) xs (delay zero time (proc (fromList (toList ys))))+   in  ys+++{-+A traversable instance is hardly useful,+because 'cons' is so expensive.++instance Traversable T where+-}+{-# INLINE sequence_ #-}+sequence_ :: Monad m => T (m a) -> m ()+sequence_ =+   switchL (return ()) (\x xs -> x >> sequence_ xs)++{-# INLINE mapM_ #-}+mapM_ :: Monad m => (a -> m ()) -> T a -> m ()+mapM_ f = sequence_ . map f+++{- |+Counterpart to 'Data.Monoid.mconcat'.+-}+monoidConcat :: Monoid m => T m -> m+monoidConcat = foldR mappend mempty++monoidConcatMap :: Monoid m => (a -> m) -> T a -> m+monoidConcatMap f = monoidConcat . map f++instance Monoid (T y) where+   mempty = empty+   mappend = append
+ src/Synthesizer/State/ToneModulation.hs view
@@ -0,0 +1,233 @@+module Synthesizer.State.ToneModulation where++import qualified Synthesizer.Basic.ToneModulation as ToneMod++import qualified Synthesizer.Causal.Process as Causal+import qualified Synthesizer.Interpolation as Interpolation++import qualified Synthesizer.Generic.Signal as SigG++import qualified Synthesizer.State.Signal as SigS++import qualified Synthesizer.Basic.Phase as Phase++-- import qualified Algebra.Transcendental        as Trans+import qualified Algebra.RealField             as RealField+-- import qualified Algebra.Field                 as Field+-- import qualified Algebra.Real                  as Real+-- import qualified Algebra.Ring                  as Ring+import qualified Algebra.Additive              as Additive++import Data.Ord.HT (limit, )++import NumericPrelude+-- import qualified Prelude as P+import PreludeBase+import Prelude ()+++type Cell sig y = SigS.T (sig y)++-- cells are organised in a transposed style, when compared with Plain.ToneModulation+interpolateCell ::+   (SigG.Read sig y) =>+   Interpolation.T a y ->+   Interpolation.T b y ->+   (a, b) ->+   Cell sig y -> y+interpolateCell ipLeap ipStep (qLeap,qStep) =+   Interpolation.func ipLeap qLeap .+   SigS.map (Interpolation.func ipStep qStep . SigG.toState)++++data Prototype sig a v =+   Prototype {+      protoMarginLeap,+      protoMarginStep  :: Interpolation.Margin,+      protoIpOffset    :: Int,+      protoPeriod      :: a,+      protoPeriodInt   :: Int,+      protoShapeLimits :: (a,a),+      protoSignal      :: sig v+   }+++makePrototype ::+   (RealField.C a, SigG.Read sig v) =>+   Interpolation.Margin ->+   Interpolation.Margin ->+   a -> sig v -> Prototype sig a v+makePrototype marginLeap marginStep period tone =+   let periodInt = round period+       ipOffset =+          ToneMod.interpolationOffset marginLeap marginStep periodInt+       len = SigG.length tone+       (lower,upper) =+          ToneMod.shapeLimits marginLeap marginStep periodInt len+       limits =+          if lower > upper+            then error "min>max"+            else+              (fromIntegral lower, fromIntegral upper)++   in  Prototype {+          protoMarginLeap  = marginLeap,+          protoMarginStep  = marginStep,+          protoIpOffset    = ipOffset,+          protoPeriod      = period,+          protoPeriodInt   = periodInt,+          protoShapeLimits = limits,+          protoSignal      = tone+       }++sampledToneCell ::+   (RealField.C a, SigG.Transform sig v) =>+   Prototype sig a v -> a -> Phase.T a -> ((a,a), Cell sig v)+sampledToneCell p shape phase =+   let (n, q) =+          ToneMod.flattenShapePhase (protoPeriodInt p) (protoPeriod p)+             (limit (protoShapeLimits p) shape, phase)+   in  (q,+        SigS.iterate (SigG.drop (protoPeriodInt p)) $+        SigG.drop (n - protoIpOffset p) $+        protoSignal p)+++-- * lazy oscillator++{-# DEPRECATED oscillatorCells "This function recomputes the shape and phase signals. Better use Causal.ToneModulation.oscillatorCells" #-}+{- |+This function should not be used,+since it requires recomputation of @shapes@ and @freqs@ lists.+-}+oscillatorCells :: (RealField.C t, SigG.Transform sig y) =>+    Interpolation.Margin ->+    Interpolation.Margin ->+    t -> sig y -> (t, SigS.T t) -> (Phase.T t, SigS.T t) ->+    SigS.T ((t,t), Cell sig y)+oscillatorCells+       marginLeap marginStep period sampledTone shapes freqs =+    let periodInt = round period+        margin =+           ToneMod.interpolationNumber marginLeap marginStep periodInt+        ipOffset =+           ToneMod.interpolationOffset marginLeap marginStep periodInt+        (skips,coords) =+           -- unzip requires recomputation+           SigS.unzip $+           oscillatorCoords periodInt period+              (limitRelativeShapes marginLeap marginStep periodInt shapes)+              freqs+    in  SigS.zipWith+           {-+           n will be zero within the data body.+           It's only needed for extrapolation at the end.+           Is it really needed?+           -}+           (\(k,q) (_n,ptr) ->+               (q, makeCell periodInt $+                      SigG.drop (checkNonNeg $ periodInt+k) ptr))+           coords $+        SigS.switchL (error "list of pointers must not be empty") (flip const) $+        SigS.scanL+           (\ (n,ptr) d -> SigG.dropMarginRem margin (n+d) ptr)+           (0, sampledTone)+           (SigS.switchL skips+               (\s -> SigS.cons (s - (ipOffset + periodInt)))+               skips)+{-+*Synthesizer.Generic.ToneModulation> let shapes = [0.3,0.4,0.2::Double]; phases = [0.43,0.72,0.91::Double]+*Synthesizer.Generic.ToneModulation> let marginLeap = Interpolation.Margin 1 3; marginStep = Interpolation.Margin 2 2+*Synthesizer.Generic.ToneModulation> List.map (Data.Tuple.HT.mapSnd List.transpose) $ ToneMod.oscillatorCells marginLeap marginStep 9 ['a'..'z'] (2.3,shapes) (Phase.fromRepresentative 0.6, phases)+[((0.28888888888888875,0.40000000000000124),["ghijklmnopqrstuvwxyz","pqrstuvwxyz","yz"]),((0.8588888888888888,0.27000000000000046),["bcdefghijklmnopqrstuvwxyz","klmnopqrstuvwxyz","tuvwxyz"]),((0.13888888888888884,0.7500000000000004),["hijklmnopqrstuvwxyz","qrstuvwxyz","z"]),((0.2288888888888887,0.9400000000000017),["ghijklmnopqrstuvwxyz","pqrstuvwxyz","yz"])]+*Synthesizer.Generic.ToneModulation> oscillatorCells marginLeap marginStep 9 ['a'..'z'] (2.3, SigS.fromList shapes) (Phase.fromRepresentative 0.6, SigS.fromList phases)+StateSignal.fromList [((0.4,0.3999999999999999),StateSignal.fromList ["fghijklmnopqrstuvwxyz","opqrstuvwxyz","xyz"]),((0.97,0.2699999999999996),StateSignal.fromList ["abcdefghijklmnopqrstuvwxyz","jklmnopqrstuvwxyz","stuvwxyz"]),((0.25,0.75),StateSignal.fromList ["ghijklmnopqrstuvwxyz","pqrstuvwxyz","yz"])]++They do only match when input list is large enough+-}++checkNonNeg :: (Ord a, Additive.C a, Show a) => a -> a+checkNonNeg x =+   if x<zero+     then error ("unexpected negative number: " ++ show x)+     else x++makeCell :: (SigG.Transform sig y) => Int -> sig y -> Cell sig y+makeCell periodInt =+   SigS.takeWhile (not . SigG.null) .+   SigS.iterate (SigG.drop periodInt)+++oscillatorCoords :: (RealField.C t) =>+    Int -> t ->+    (t, SigS.T t) -> (Phase.T t, SigS.T t) ->+    SigS.T (ToneMod.Coords t)+oscillatorCoords periodInt period+       (shape0, shapes) (phase, freqs) =+    let shapeOffsets =+           SigS.scanL+              (\(_,s) c -> splitFraction (s+c))+              (splitFraction shape0) shapes+        phases =+           -- FIXME: could be made without the dangerous irrefutable pattern+           let Just (s,ss) =+                  SigS.viewL $+                  SigS.map (\(n,_) -> fromIntegral n / period) $+                  shapeOffsets+           in  freqsToPhases+                  (Phase.decrement s phase)  -- phase - s+               `Causal.apply`+                  (SigS.zipWith (-) freqs ss)+    in  SigS.zipWith+           (\(d,s) p -> (d, ToneMod.flattenShapePhase periodInt period (s,p)))+           shapeOffsets+           phases++limitRelativeShapes :: (RealField.C t) =>+    Interpolation.Margin ->+    Interpolation.Margin ->+    Int -> (t, SigS.T t) -> (t, SigS.T t)+limitRelativeShapes marginLeap marginStep periodInt =+    limitMinRelativeValues $ fromIntegral $+    ToneMod.interpolationOffset marginLeap marginStep periodInt + periodInt++limitMinRelativeValues :: (Additive.C t, Ord t) =>+   t -> (t, SigS.T t) -> (t, SigS.T t)+limitMinRelativeValues xMin (x0, xs) =+   let x1 = xMin-x0+   in  if x1<=zero+         then (x0, xs)+         else (xMin,+               SigS.crochetL+                  (\x lim ->+                     let d = x-lim+                     in  Just $ if d>=zero+                           then (d,zero) else (zero, negate d)) x1 xs)+{-+Test.QuickCheck.test (\x (y,zi) -> let z=List.map abs zi in  Data.Tuple.HT.mapSnd SigS.toList (limitMinRelativeValues x (y, SigS.fromList z)) == ToneMod.limitMinRelativeValues (x::Int) y z)+-}++-- * handling of phases as needed for oscillators++{-# INLINE freqsToPhases #-}+{- |+Convert a list of phase steps into a list of momentum phases.+phase is a number in the interval [0,1).+freq contains the phase steps.+The last element is omitted.+-}+freqsToPhases :: RealField.C a =>+   Phase.T a -> Causal.T a (Phase.T a)+freqsToPhases =+   Causal.scanL (flip Phase.increment)++{- |+Like 'freqsToPhases' but the first element is omitted.+-}+{-# INLINE freqsToPhasesSync #-}+freqsToPhasesSync :: RealField.C a =>+   Phase.T a -> Causal.T a (Phase.T a)+freqsToPhasesSync =+   Causal.crochetL+      (\f p0 -> let p1 = Phase.increment f p0 in Just (p1,p1))
+ src/Synthesizer/Storable/Cut.hs view
@@ -0,0 +1,137 @@+module Synthesizer.Storable.Cut where++import qualified Synthesizer.Storable.Signal as Sig++import qualified Data.StorableVector.Lazy      as SVL+import qualified Data.StorableVector.ST.Strict as SVST++import Control.Monad.ST.Strict (ST, runST, )++import qualified Data.EventList.Relative.TimeBody  as EventList+import qualified Data.EventList.Relative.TimeMixed as EventListTM+import qualified Data.EventList.Absolute.TimeBody  as AbsEventList+import Control.Monad.Trans.State (runState, modify, gets, put, )+-- import Control.Monad (mapM, )+import Data.Tuple.HT (mapSnd, )++-- import qualified Algebra.Real     as Real+import qualified Algebra.Additive as Additive+import qualified Number.NonNegative as NonNeg++import Foreign.Storable (Storable)++import PreludeBase+import NumericPrelude+++{- |+ChunkSize is only required for zero padding.+-}+{-# INLINE arrange #-}+arrange :: (Storable v, Additive.C v) =>+       Sig.ChunkSize+    -> EventList.T NonNeg.Int (Sig.T v)+            {-^ A list of pairs: (relative start time, signal part),+                The start time is relative to the start time+                of the previous event. -}+    -> Sig.T v+            {-^ The mixed signal. -}+arrange size =+   uncurry Sig.append .+   flip runState Sig.empty .+   fmap (Sig.concat . EventList.getTimes) .+   EventList.mapM+      (\timeNN ->+           let time = NonNeg.toNumber timeNN+           in  do (prefix,suffix) <- gets (Sig.splitAtPad size time)+                  put suffix+                  return prefix)+      (\body ->+           modify (Sig.mix body))+++arrangeList :: (Storable v, Additive.C v) =>+       Sig.ChunkSize+    -> EventList.T NonNeg.Int (Sig.T v)+            {-^ A list of pairs: (relative start time, signal part),+                The start time is relative to the start time+                of the previous event. -}+    -> Sig.T v+            {-^ The mixed signal. -}+arrangeList size evs =+   let xs = EventList.getBodies evs+   in  case EventList.getTimes evs of+          t:ts -> Sig.replicate size (NonNeg.toNumber t) zero `Sig.append`+                  addShiftedMany size ts xs+          []   -> Sig.empty+++addShiftedMany :: (Storable a, Additive.C a) =>+   Sig.ChunkSize -> [NonNeg.Int] -> [Sig.T a] -> Sig.T a+addShiftedMany size ds xss =+   foldr (uncurry (addShifted size)) Sig.empty (zip (ds++[0]) xss)+++{-+It is crucial that 'mix' uses the chunk size structure of the second operand.+This way we avoid unnecessary and even infinite look-ahead.+-}+addShifted :: (Storable a, Additive.C a) =>+   Sig.ChunkSize -> NonNeg.Int -> Sig.T a -> Sig.T a -> Sig.T a+addShifted size delNN px py =+   let del = NonNeg.toNumber delNN+   in  uncurry Sig.append $+       mapSnd (flip Sig.mix py) $+       Sig.splitAtPad size del px+++{- |+The result is a Lazy StorableVector with chunks of the given size.+-}+{-# INLINE arrangeEquidist #-}+arrangeEquidist :: (Storable v, Additive.C v) =>+       Sig.ChunkSize+    -> EventList.T NonNeg.Int (Sig.T v)+            {-^ A list of pairs: (relative start time, signal part),+                The start time is relative to the start time+                of the previous event. -}+    -> Sig.T v+            {-^ The mixed signal. -}+arrangeEquidist (SVL.ChunkSize sz) =+   let sznn = NonNeg.fromNumberMsg "arrangeEquidist" sz+       go acc evs =+          let (now,future) = EventListTM.splitAtTime sznn evs+              xs =+                 AbsEventList.toPairList $+                 EventList.toAbsoluteEventList 0 $+                 EventListTM.switchTimeR (const) now+              (chunk,newAcc) =+                 runST+                    (do v <- SVST.new sz zero+                        newAcc0 <- mapM (addToBuffer v 0) acc+--                        newAcc1 <- AbsEventList.mapM (addToBuffer v) xs+                        newAcc1 <-+                           mapM (\(i,s) -> addToBuffer v (NonNeg.toNumber i) s) xs+                        vf <- SVST.freeze v+                        return+                           (vf, filter (not . Sig.null) (newAcc0++newAcc1)))+          in  chunk : go newAcc future+   in  Sig.fromChunks . go []++++addToBuffer :: (Storable a, Additive.C a) =>+   SVST.Vector s a -> Int -> Sig.T a -> ST s (Sig.T a)+addToBuffer v start =+   let n = SVST.length v+       {-# INLINE go #-}+       go i =+          if i>=n+            then return+            else+              Sig.switchL+                 (return Sig.empty)+                 (\x xs ->+                     SVST.modify v i (x Additive.+) >>+                     go (succ i) xs)+   in  go start
+ src/Synthesizer/Storable/Oscillator.hs view
@@ -0,0 +1,157 @@+{-# LANGUAGE NoImplicitPrelude #-}+{- |+Copyright   :  (c) Henning Thielemann 2006+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes++Tone generators+-}+module Synthesizer.Storable.Oscillator where++import qualified Synthesizer.Basic.Wave       as Wave+import qualified Synthesizer.Basic.Phase      as Phase++import qualified Synthesizer.Storable.Signal as Signal+import Synthesizer.Storable.Signal (ChunkSize)+import Foreign.Storable (Storable)++-- import qualified Synthesizer.Plain.Interpolation as Interpolation++{-+import qualified Algebra.RealTranscendental    as RealTrans+import qualified Algebra.Module                as Module+import qualified Algebra.VectorSpace           as VectorSpace++import Algebra.Module((*>))+-}+import qualified Algebra.Transcendental        as Trans+import qualified Algebra.RealField             as RealField+-- import qualified Algebra.Field                 as Field+-- import qualified Algebra.Ring                  as Ring+import qualified Algebra.Additive              as Additive++import NumericPrelude++import qualified Prelude as P+import PreludeBase++++{- * Oscillators with arbitrary but constant waveforms -}++{-# INLINE freqToPhase #-}+{- | Convert a list of phase steps into a list of momentum phases+     phase is a number in the interval [0,1)+     freq contains the phase steps -}+freqToPhase :: (RealField.C a, Storable a) =>+   Phase.T a -> Signal.T a -> Signal.T (Phase.T a)+freqToPhase phase freq = Signal.scanL (flip Phase.increment) phase freq+++{-# INLINE static #-}+{-# SPECULATE static :: Storable b => ChunkSize -> (Double -> b) -> (Double -> Double -> Signal.T b) #-}+{- | oscillator with constant frequency -}+static :: (RealField.C a, Storable a, Storable b) =>+    ChunkSize -> Wave.T a b -> (Phase.T a -> a -> Signal.T b)+static size wave phase freq =+    Signal.map (Wave.apply wave) (Signal.iterate size (Phase.increment freq) phase)++{- | oscillator with modulated phase -}+phaseMod :: (RealField.C a, Storable a, Storable b) =>+    ChunkSize -> Wave.T a b -> a -> Signal.T a -> Signal.T b+phaseMod size wave = shapeMod size (Wave.phaseOffset wave) zero++{-# ONLINE shapeMod #-}+{- | oscillator with modulated shape -}+shapeMod :: (RealField.C a, Storable a, Storable b, Storable c) =>+    ChunkSize -> (c -> Wave.T a b) -> Phase.T a -> a -> Signal.T c -> Signal.T b+shapeMod size wave phase freq parameters =+    Signal.zipWith (Wave.apply . wave) parameters+       (Signal.iterate size (Phase.increment freq) phase)++{- | oscillator with modulated frequency -}+freqMod :: (RealField.C a, Storable a, Storable b) =>+    ChunkSize -> Wave.T a b -> Phase.T a -> Signal.T a -> Signal.T b+freqMod _size wave phase freqs =+    Signal.map (Wave.apply wave) (freqToPhase phase freqs)++{- | oscillator with both phase and frequency modulation -}+phaseFreqMod :: (RealField.C a, Storable a, Storable b) =>+    ChunkSize -> Wave.T a b -> Signal.T a -> Signal.T a -> Signal.T b+phaseFreqMod size wave =+    shapeFreqMod size (Wave.phaseOffset wave) zero++{- | oscillator with both shape and frequency modulation -}+shapeFreqMod :: (RealField.C a, Storable a, Storable b, Storable c) =>+    ChunkSize -> (c -> Wave.T a b) ->+    Phase.T a -> Signal.T c -> Signal.T a -> Signal.T b+shapeFreqMod _size wave phase parameters freqs =+    Signal.zipWith (Wave.apply . wave) parameters (freqToPhase phase freqs)+++{-+{- | oscillator with a sampled waveform with constant frequency+     This essentially an interpolation with cyclic padding. -}+staticSample :: RealField.C a => Interpolation.T a b -> Signal.T b -> a -> a -> Signal.T b+staticSample ip wave phase freq =+    freqModSample ip wave phase (repeat freq)++{- | oscillator with a sampled waveform with modulated frequency+     Should behave homogenously for different types of interpolation. -}+freqModSample :: RealField.C a => Interpolation.T a b -> Signal.T b -> a -> Signal.T a -> Signal.T b+freqModSample ip wave phase freqs =+    let len = fromIntegral (length wave)+    in  Interpolation.multiRelativeCyclicPad+           ip (phase*len) (Signal.map (*len) freqs) wave+-}++++{- * Oscillators with specific waveforms -}++{-# INLINE staticSine #-}+{-# SPECULATE staticSine :: ChunkSize -> Double -> Double -> Signal.T Double #-}+{- | sine oscillator with static frequency -}+staticSine :: (Trans.C a, RealField.C a, Storable a) =>+   ChunkSize -> Phase.T a -> a -> Signal.T a+staticSine size = static size Wave.sine++{-# INLINE freqModSine #-}+{-# SPECULATE freqModSine :: ChunkSize -> Double -> Signal.T Double -> Signal.T Double #-}+{- | sine oscillator with modulated frequency -}+freqModSine :: (Trans.C a, RealField.C a, Storable a) =>+   ChunkSize -> Phase.T a -> Signal.T a -> Signal.T a+freqModSine size = freqMod size Wave.sine++{-# INLINE phaseModSine #-}+{-# SPECULATE phaseModSine :: ChunkSize -> Double -> Signal.T Double -> Signal.T Double #-}+{- | sine oscillator with modulated phase, useful for FM synthesis -}+phaseModSine :: (Trans.C a, RealField.C a, Storable a) =>+   ChunkSize -> a -> Signal.T a -> Signal.T a+phaseModSine size = phaseMod size Wave.sine++{-# INLINE staticSaw #-}+{-# SPECULATE staticSaw :: ChunkSize -> Double -> Double -> Signal.T Double #-}+{- | saw tooth oscillator with modulated frequency -}+staticSaw :: (RealField.C a, Storable a) =>+   ChunkSize -> Phase.T a -> a -> Signal.T a+staticSaw size = static size Wave.saw++{-# INLINE freqModSaw #-}+{-# SPECULATE freqModSaw :: ChunkSize -> Double -> Signal.T Double -> Signal.T Double #-}+{- | saw tooth oscillator with modulated frequency -}+freqModSaw :: (RealField.C a, Storable a) =>+   ChunkSize -> Phase.T a -> Signal.T a -> Signal.T a+freqModSaw size = freqMod size Wave.saw+++{- Test whether Fusion takes place.+For the following code the simplifier can't resist!++testLength :: (Storable a, Enum a) => a -> Int+testLength x =+   Signal.length (Signal.map succ (Signal.fromList (Signal.ChunkSize 100) [x,x,x]))+-}
+ src/Synthesizer/Storable/Signal.hs view
@@ -0,0 +1,1271 @@+{- OPTIONS_GHC -fglasgow-exts -}+{- glasgow-exts are for the rules -}+{- |+Chunky signal stream build on StorableVector.++Hints for fusion:+ - Higher order functions should always be inlined in the end+   in order to turn them into machine loops+   instead of calling a function in an inner loop.+-}+module Synthesizer.Storable.Signal (+      T,+      Vector.hPut,+      ChunkSize, Vector.chunkSize, defaultChunkSize,+      -- for Storable.Oscillator+      scanL,+      Vector.map,+      Vector.iterate,+      Vector.zipWith,+      -- for State.Signal+      Vector.append,+      Vector.concat,+      Vector.span,+      Vector.splitAt,+      Vector.viewL,+      Vector.viewR,+      Vector.switchL,+      Vector.unfoldr,+      Vector.reverse,+      Vector.crochetL,+      -- for Dimensional.File+      Vector.writeFile,+      -- for Storable.Cut+      splitAtPad,+      Vector.null,+      Vector.fromChunks,+      -- for Storable.Filter.Comb+      delay,+      delayLoop,+      delayLoopOverlap,+      -- for FusionTest+      mix, mixSize,+      Vector.empty,+      Vector.replicate,+      Vector.repeat,+      Vector.drop,+      Vector.take,+      takeCrochet,+      fromList,+      appendFromFusionList,+      appendFusionList,+      -- for Generic.Signal+      zipWithRest,+      zipWithAppend,+      -- for Storable.ALSA.MIDI+      Vector.switchR,++      -- just for fun+      fromFusionList,+      genericLength,+   ) where++-- import qualified Sound.Signal as Signal++import qualified Synthesizer.FusionList.Signal as FList++import qualified Data.List as List+import qualified Data.StorableVector.Lazy as Vector+import qualified Data.StorableVector as V+import Data.StorableVector.Lazy (ChunkSize(..))++-- import Data.Maybe (Maybe(Just,Nothing), maybe, fromMaybe)++-- import Data.StorableVector(Vector)+import Foreign.Storable (Storable)++-- import qualified Synthesizer.Format as Format++-- import Control.Arrow ((***))+-- import Control.Monad (liftM, liftM2, {- guard, -} )++import qualified Algebra.Ring      as Ring+import qualified Algebra.Additive  as Additive+import qualified Algebra.ToInteger as ToInteger++import qualified Number.NonNegativeChunky as Chunky+import qualified Number.NonNegative       as NonNeg++import qualified Data.List.HT as ListHT+import Data.Maybe.HT (toMaybe, )+import Data.Tuple.HT (mapFst, mapSnd, mapPair, forcePair, )++-- import qualified Algebra.Additive as Additive+++-- import System.IO (openBinaryFile, hClose, hPutBuf, IOMode(WriteMode), Handle)+++import NumericPrelude+import PreludeBase+import Prelude ()+++{-+import NumericPrelude+   (sum, (+), (-), divMod, fromIntegral, fromInteger, toInteger, isZero, zero, )++import Prelude hiding+   (length, (++), iterate, foldl, map, repeat, replicate, null,+    zip, zipWith, zipWith3, drop, take, splitAt, takeWhile, reverse)+-}++{-+import qualified Prelude as P+import Prelude+   (IO, ($), (.), fst, snd, id,+    Int, Double, Float,+    Char, Num, Show, showsPrec, FilePath,+    Bool(True,False), not,+    flip, curry, uncurry,+    Ord, (<), (>), (<=), {- (>=), (==), -} min, max,+    mapM_, fmap, (=<<), return,+    Enum, succ, pred, )+-}+++-- this form is needed for Storable signal embed in amplitude signal+type T = Vector.Vector+-- type T a = Vector.Vector a++instance (Show a, Storable a) => Show (Vector.Vector a) where+   showsPrec p = showsPrec p . Vector.unpack++{-+instance (Storable a) => Format.C T where+   format = showsPrec+-}+++defaultChunkSize :: ChunkSize+defaultChunkSize = ChunkSize 1024+++{-+{- * Helper functions for StorableVector -}++cancelNullVector :: (Vector a, b) -> Maybe (Vector a, b)+cancelNullVector y =+   toMaybe (not (Vector.null (fst y))) y++viewLVector :: Storable a =>+   Vector a -> Maybe (a, Vector a)+viewLVector = Vector.viewL+{-+   toMaybe+      (not (Vector.null x))+      (Vector.head x, Vector.tail x)+-}++crochetLVector :: (Storable x, Storable y) =>+      (x -> acc -> Maybe (y, acc))+   -> acc+   -> Vector x+   -> (Vector y, Maybe acc)+crochetLVector f acc0 x0 =+   mapSnd (fmap fst) $+   Vector.unfoldrN+      (Vector.length x0)+      (\(acc,xt) ->+         do (x,xs) <- viewLVector xt+            (y,acc') <- f x acc+            return (y, (acc',xs)))+      (acc0, x0)++reduceLVector :: Storable x =>+   (x -> acc -> Maybe acc) -> acc -> Vector x -> (acc, Bool)+reduceLVector f acc0 x =+   let recourse i acc =+          if i < Vector.length x+            then (acc, True)+            else+               maybe+                  (acc, False)+                  (recourse (succ i))+                  (f (Vector.index x i) acc)+   in  recourse 0 acc0+++++{- * Fundamental functions -}++{- |+Sophisticated implementation where chunks always have size bigger than 0.+-}+{-# INLINE [0] unfoldr #-}+unfoldr :: (Storable b) =>+      ChunkSize+   -> (a -> Maybe (b,a))+   -> a+   -> T b+unfoldr (ChunkSize size) f =+   Cons .+   List.unfoldr+      (cancelNullVector . Vector.unfoldrN size f =<<) .+   Just++{- |+Simple implementation where chunks can have size 0 in the first run.+Then they are filtered out.+This separation might reduce laziness.+-}+unfoldr0 :: (Storable b) =>+      ChunkSize+   -> (a -> Maybe (b,a))+   -> a+   -> T b+unfoldr0 (ChunkSize size) f =+   Cons .+   List.filter (not . Vector.null) .+   List.unfoldr (fmap (Vector.unfoldrN size f)) .+   Just+++unfoldr1 :: (Storable b) =>+      ChunkSize+   -> (a -> (b, Maybe a))+   -> Maybe a+   -> T b+unfoldr1 size f = unfoldr size (liftM f)++{-# INLINE [0] crochetL #-}+crochetL :: (Storable x, Storable y) =>+      (x -> acc -> Maybe (y, acc))+   -> acc+   -> T x+   -> T y+crochetL f acc0 =+   Cons . List.unfoldr (\(xt,acc) ->+       do (x,xs) <- ListHT.viewL xt+          acc' <- acc+          return $ mapSnd ((,) xs) $ crochetLVector f acc' x) .+   flip (,) (Just acc0) .+   decons++{-+Usage of 'unfoldr' seems to be clumsy but that covers all cases,+like different block sizes in source and destination list.+-}+crochetLSize :: (Storable x, Storable y) =>+      ChunkSize+   -> (x -> acc -> Maybe (y, acc))+   -> acc+   -> T x+   -> T y+crochetLSize size f =+   curry (unfoldr size (\(acc,xt) ->+      do (x,xs) <- viewL xt+         (y,acc') <- f x acc+         return (y, (acc',xs))))++viewL :: Storable a => T a -> Maybe (a, T a)+viewL (Cons xs0) =+   -- dropWhile would be unnecessary if we require that all chunks are non-empty+   do (x,xs) <- ListHT.viewL (List.dropWhile Vector.null xs0)+      (y,ys) <- viewLVector x+      return (y, append (fromChunk ys) (Cons xs))++viewR :: Storable a => T a -> Maybe (T a, a)+viewR (Cons xs0) =+   -- dropWhile would be unnecessary if we require that all chunks are non-empty+   do (xs,x) <- ListHT.viewR (dropWhileRev Vector.null xs0)+      (ys,y) <- Vector.viewR x+      return (append (Cons xs) (fromChunk ys), y)++crochetListL :: (Storable y) =>+      ChunkSize+   -> (x -> acc -> Maybe (y, acc))+   -> acc+   -> [x]+   -> T y+crochetListL size f =+   curry (unfoldr size (\(acc,xt) ->+      do (x,xs) <- ListHT.viewL xt+         (y,acc') <- f x acc+         return (y, (acc',xs))))+-}+++{-# INLINE fromList #-}+fromList :: (Storable a) => ChunkSize -> [a] -> T a+fromList = Vector.pack+++{-+-- should start fusion+fromListCrochetL :: (Storable a) => ChunkSize -> [a] -> T a+fromListCrochetL size =+   crochetListL size (\x _ -> Just (x, ())) ()++fromListUnfoldr :: (Storable a) => ChunkSize -> [a] -> T a+fromListUnfoldr size = unfoldr size ListHT.viewL++fromListPack :: (Storable a) => ChunkSize -> [a] -> T a+fromListPack (ChunkSize size) =+   Cons .+   List.map Vector.pack .+   sliceVert size++toList :: (Storable a) => T a -> [a]+toList = List.concatMap Vector.unpack . decons++-- if the chunk has length zero, an empty sequence is generated+fromChunk :: (Storable a) => Vector a -> T a+fromChunk x =+   if Vector.null x+     then empty+     else Cons [x]+++++{-# NOINLINE [0] crochetFusionListL #-}+crochetFusionListL :: (Storable y) =>+      ChunkSize+   -> (x -> acc -> Maybe (y, acc))+   -> acc+   -> FList.T x+   -> T y+crochetFusionListL size f =+   curry (unfoldr size (\(acc,xt) ->+      do (x,xs) <- FList.viewL xt+         (y,acc') <- f x acc+         return (y, (acc',xs))))+-}++{-# NOINLINE [0] fromFusionList #-}+fromFusionList :: (Storable a) => ChunkSize -> FList.T a -> T a+fromFusionList size = fromList size . FList.toList+   -- fromFusionListCrochetL++{-+{-# INLINE fromFusionListCrochetL #-}+fromFusionListCrochetL :: (Storable a) => ChunkSize -> FList.T a -> T a+fromFusionListCrochetL size =+   crochetFusionListL size (\x _ -> Just (x, ())) ()++fromFusionListUnfoldr :: (Storable a) => ChunkSize -> FList.T a -> T a+fromFusionListUnfoldr size =+   unfoldr size FList.viewL+++{-# NOINLINE [0] toFusionList #-}+toFusionList :: (Storable a) => T a -> FList.T a+toFusionList = FList.Cons . List.concatMap Vector.unpack . decons+++{- |+Converts from and to 'FList.T'+in order to speedup computation,+especially because it tells the optimizer about the 'Storable' constraint+and thus allows for more fusion,+where fusion would break otherwise.+-}+{-# INLINE chop #-}+chop :: (Storable a) => ChunkSize -> FList.T a -> FList.T a+chop size = toFusionList . fromFusionList size++++{-# INLINE [0] reduceL #-}+reduceL :: Storable x =>+   (x -> acc -> Maybe acc) -> acc -> T x -> acc+reduceL f acc0 =+   let recourse acc xt =+          case xt of+             [] -> acc+             (x:xs) ->+                 let (acc',continue) = reduceLVector f acc x+                 in  if continue+                       then recourse acc' xs+                       else acc'+   in  recourse acc0 . decons++++{- * Basic functions -}++empty :: Storable a => T a+empty = Cons []++null :: Storable a => T a -> Bool+null = List.null . decons+++{-# NOINLINE [0] cons #-}+cons :: Storable a => a -> T a -> T a+cons x = Cons . (Vector.singleton x :) . decons+++length :: T a -> Int+length = sum . List.map Vector.length . decons+++reverse :: Storable a => T a -> T a+reverse =+   Cons . List.reverse . List.map Vector.reverse . decons+++{-# INLINE [0] foldl #-}+foldl :: Storable b => (a -> b -> a) -> a -> T b -> a+foldl f x0 = List.foldl (Vector.foldl f) x0 . decons+++{-# INLINE [0] map #-}+map :: (Storable x, Storable y) =>+      (x -> y)+   -> T x+   -> T y+map f = mapInline f -- Cons . List.map (Vector.map f) . decons++{-# INLINE mapInline #-}+mapInline :: (Storable x, Storable y) =>+      (x -> y)+   -> T x+   -> T y+mapInline f =+   let mapVec = Vector.map f+   in  Cons . List.map mapVec . decons++++{-# NOINLINE [0] drop #-}+drop :: (Storable a) => Int -> T a -> T a+drop _ (Cons []) = empty+drop n (Cons (x:xs)) =+   let m = Vector.length x+   in  if m<=n+         then drop (n-m) (Cons xs)+         else Cons (Vector.drop n x : xs)++{-# NOINLINE [0] take #-}+take :: (Storable a) => Int -> T a -> T a+take _ (Cons []) = empty+take 0 _ = empty+take n (Cons (x:xs)) =+   let m = Vector.length x+   in  if m<=n+         then Cons $ (x:) $ decons $ take (n-m) $ Cons xs+         else fromChunk (Vector.take n x)++++{-# NOINLINE [0] splitAt #-}+splitAt :: (Storable a) => Int -> T a -> (T a, T a)+splitAt n0 =+   let recourse _ [] = ([], [])+       recourse 0 xs = ([], xs)+       recourse n (x:xs) =+          let m = Vector.length x+          in  if m<=n+                then mapFst (x:) $ recourse (n-m) xs+                else mapPair ((:[]), (:xs)) $ Vector.splitAt n x+   in  mapPair (Cons, Cons) . recourse n0 . decons+++dropMarginRem :: (Storable a) => Int -> Int -> T a -> (Int, T a)+dropMarginRem n m xs =+   List.foldl'+      (\(mi,xsi) k -> (mi-k, drop k xsi))+      (m,xs)+      (List.map Vector.length $ decons $ take m $ drop n xs)++{-+This implementation does only walk once through the dropped prefix.+It is maximally lazy and minimally space consuming.+-}+dropMargin :: (Storable a) => Int -> Int -> T a -> T a+dropMargin n m xs =+   List.foldl' (flip drop) xs+      (List.map Vector.length $ decons $ take m $ drop n xs)+++{-# NOINLINE [0] dropWhile #-}+dropWhile :: (Storable a) => (a -> Bool) -> T a -> T a+dropWhile _ (Cons []) = empty+dropWhile p (Cons (x:xs)) =+   let y = Vector.dropWhile p x+   in  if Vector.null y+         then dropWhile p (Cons xs)+         else Cons (y:xs)++{-# NOINLINE [0] takeWhile #-}+takeWhile :: (Storable a) => (a -> Bool) -> T a -> T a+takeWhile _ (Cons []) = empty+takeWhile p (Cons (x:xs)) =+   let y = Vector.takeWhile p x+   in  if Vector.length y < Vector.length x+         then fromChunk y+         else Cons (x : decons (takeWhile p (Cons xs)))+++{-# NOINLINE [0] span #-}+span :: (Storable a) => (a -> Bool) -> T a -> (T a, T a)+span p =+   let recourse [] = ([],[])+       recourse (x:xs) =+          let (y,z) = Vector.span p x+          in  if Vector.null z+                then mapFst (x:) (recourse xs)+                else (decons $ fromChunk y, (z:xs))+   in  mapPair (Cons, Cons) . recourse . decons+{-+span _ (Cons []) = (empty, empty)+span p (Cons (x:xs)) =+   let (y,z) = Vector.span p x+   in  if Vector.length y == 0+         then mapFst (Cons . (x:) . decons) (span p (Cons xs))+         else (Cons [y], Cons (z:xs))+-}++concat :: (Storable a) => [T a] -> T a+concat = Cons . List.concat . List.map decons+++{- |+Ensure a minimal length of the list by appending pad values.+-}+{-# NOINLINE [0] pad #-}+pad :: (Storable a) => ChunkSize -> a -> Int -> T a -> T a+pad size y n0 =+   let recourse n xt =+          if n<=0+            then xt+            else+              case xt of+                 [] -> decons $ replicate size n y+                 x:xs -> x : recourse (n - Vector.length x) xs+   in  Cons . recourse n0 . decons++padAlt :: (Storable a) => ChunkSize -> a -> Int -> T a -> T a+padAlt size x n xs =+   append xs+      (let m = length xs+       in  if n>m+             then replicate size (n-m) x+             else empty)+++infixr 5 `append`++{-# NOINLINE [0] append #-}+append :: T a -> T a -> T a+append (Cons xs) (Cons ys)  =  Cons (xs List.++ ys)+-}++{-# INLINE appendFromFusionList #-}+appendFromFusionList :: Storable a =>+   ChunkSize -> FList.T a -> FList.T a -> T a+appendFromFusionList size xs ys  =+   Vector.append (FList.toStorableSignal size xs) (FList.toStorableSignal size ys)++{- |+Like 'appendFromFusionList' but returns a 'FList.T'+for more flexible following processing.+-}+{-# INLINE appendFusionList #-}+appendFusionList :: Storable a =>+   ChunkSize -> FList.T a -> FList.T a -> FList.T a+appendFusionList size xs ys  =+   FList.fromStorableSignal (appendFromFusionList size xs ys)+++{-+{-# INLINE iterate #-}+iterate :: Storable a => ChunkSize -> (a -> a) -> a -> T a+iterate size f = unfoldr size (\x -> Just (x, f x))++repeat :: Storable a => ChunkSize -> a -> T a+repeat (ChunkSize size) =+   Cons . List.repeat . Vector.replicate size++cycle :: Storable a => T a -> T a+cycle =+   Cons . List.cycle . decons++replicate :: Storable a => ChunkSize -> Int -> a -> T a+replicate (ChunkSize size) n x =+   let (numChunks, rest) = divMod n size+   in  append+          (Cons (List.replicate numChunks (Vector.replicate size x)))+          (fromChunk (Vector.replicate rest x))+-}++{-# INLINE scanL #-}+scanL :: (Storable a, Storable b) =>+   (a -> b -> a) -> a -> T b -> T a+scanL = Vector.scanl+++{-+{-# INLINE [0] mapAccumL #-}+mapAccumL :: (Storable a, Storable b) =>+   (acc -> a -> (acc, b)) -> acc -> T a -> (acc, T b)+mapAccumL f start =+   mapSnd Cons .+   List.mapAccumL (Vector.mapAccumL f) start .+   decons++{-# INLINE [0] mapAccumR #-}+mapAccumR :: (Storable a, Storable b) =>+   (acc -> a -> (acc, b)) -> acc -> T a -> (acc, T b)+mapAccumR f start =+   mapSnd Cons .+   List.mapAccumR (Vector.mapAccumR f) start .+   decons++{-# RULEZ+  "Storable.append/repeat/repeat" forall size x.+      append (repeat size x) (repeat size x) = repeat size x ;++  "Storable.append/repeat/replicate" forall size n x.+      append (repeat size x) (replicate size n x) = repeat size x ;++  "Storable.append/replicate/repeat" forall size n x.+      append (replicate size n x) (repeat size x) = repeat size x ;++  "Storable.append/replicate/replicate" forall size n m x.+      append (replicate size n x) (replicate size m x) =+         replicate size (n+m) x ;++  "Storable.mix/repeat/repeat" forall size x y.+      mix (repeat size x) (repeat size y) = repeat size (x+y) ;++  #-}++{-# RULES+  "Storable.length/cons" forall x xs.+      length (cons x xs) = 1 + length xs ;++  "Storable.length/map" forall f xs.+      length (map f xs) = length xs ;++  "Storable.map/cons" forall f x xs.+      map f (cons x xs) = cons (f x) (map f xs) ;++  "Storable.map/repeat" forall size f x.+      map f (repeat size x) = repeat size (f x) ;++  "Storable.map/replicate" forall size f x n.+      map f (replicate size n x) = replicate size n (f x) ;++  "Storable.map/repeat" forall size f x.+      map f (repeat size x) = repeat size (f x) ;++  {-+  This can make things worse, if 'map' is applied to replicate,+  since this can use of sharing.+  It can also destroy the more important map/unfoldr fusion in+    take n . map f . unfoldr g++  "Storable.take/map" forall n f x.+      take n (map f x) = map f (take n x) ;+  -}++  "Storable.take/repeat" forall size n x.+      take n (repeat size x) = replicate size n x ;++  "Storable.take/take" forall n m xs.+      take n (take m xs) = take (min n m) xs ;++  "Storable.drop/drop" forall n m xs.+      drop n (drop m xs) = drop (n+m) xs ;++  "Storable.drop/take" forall n m xs.+      drop n (take m xs) = take (max 0 (m-n)) (drop n xs) ;++  "Storable.map/mapAccumL/snd" forall g f acc0 xs.+      map g (snd (mapAccumL f acc0 xs)) =+         snd (mapAccumL (\acc a -> mapSnd g (f acc a)) acc0 xs) ;++  #-}++{- GHC says this is an orphaned rule+  "Storable.map/mapAccumL/mapSnd" forall g f acc0 xs.+      mapSnd (map g) (mapAccumL f acc0 xs) =+         mapAccumL (\acc a -> mapSnd g (f acc a)) acc0 xs ;+-}+-}++{-# SPECULATE mix :: T Double -> T Double -> T Double #-}+{-# SPECULATE mix :: T Float -> T Float -> T Float #-}+{-# SPECULATE mix :: T (Double,Double) -> T (Double,Double) -> T (Double,Double) #-}+{-# SPECULATE mix :: T (Float,Float) -> T (Float,Float) -> T (Float,Float) #-}+{-+'mix' is more efficient+since it appends the rest of the longer signal without copying.+It also preserves the chunk structure of the second signal,+which is essential if you want to limit look-ahead.+-}+mix :: (Additive.C x, Storable x) =>+      T x+   -> T x+   -> T x+mix = zipWithAppend (+)+{-+List.map V.unpack $ Vector.chunks $ mix (fromList defaultChunkSize [1,2,3,4,5::P.Double]) (fromList defaultChunkSize [1,2,3,4])+-}++zipWithAppend ::+   (Storable x) =>+   (x -> x -> x) ->+   T x -> T x -> T x+zipWithAppend f xs ys =+   uncurry Vector.append $ mapSnd snd $ zipWithRest f xs ys++zipWithRest ::+   (Storable c, Storable x) =>+   (x -> x -> c) ->+   T x ->+   T x ->+   (Vector.Vector c, (Bool, T x))+zipWithRest f xs ys =+   let len = min (lazyLength xs) (lazyLength ys) :: Chunky.T NonNeg.Int+       (prefixX,suffixX) = genericSplitAt len xs+       (prefixY,suffixY) = genericSplitAt len ys+       second = Vector.null suffixX+   in  (Vector.zipWith f prefixX prefixY,+        (second, if second then suffixY else suffixX))++{-+We should move that to StorableVector package,+but we cannot, since that's Haskell 98.+-}+genericSplitAt ::+   (Additive.C i, Ord i, ToInteger.C i, Storable x) =>+   i -> T x -> (T x, T x)+genericSplitAt n0 =+   let recourse n xs0 =+          forcePair $+          maybe+             ([], [])+             (\(x,xs) ->+                if isZero n+                  then ([], xs0)+                  else+                    let m = fromIntegral $ V.length x+                    in  if m<=n+                          then mapFst (x:) $ recourse (n-m) xs+                          else mapPair ((:[]), (:xs)) $+                               V.splitAt (fromInteger $ toInteger n) x)+           $ ListHT.viewL xs0+   in  mapPair (Vector.fromChunks, Vector.fromChunks) .+       recourse n0 . Vector.chunks+++-- cf. Data.StorableVector.Lazy.Pattern.length+lazyLength :: (Ring.C i) =>+   T x -> i+lazyLength =+   List.foldr (+) zero . List.map (fromIntegral . V.length) . Vector.chunks++genericLength :: (Ring.C i) =>+   T x -> i+genericLength =+   sum . List.map (fromIntegral . V.length) . Vector.chunks+++splitAtPad ::+   (Additive.C x, Storable x) =>+   ChunkSize -> Int -> T x -> (T x, T x)+splitAtPad size n =+   mapFst (Vector.pad size Additive.zero n) . Vector.splitAt n+++{-# SPECULATE mixSize :: ChunkSize -> T Double -> T Double -> T Double #-}+{-# SPECULATE mixSize :: ChunkSize -> T Float -> T Float -> T Float #-}+{-# SPECULATE mixSize :: ChunkSize -> T (Double,Double) -> T (Double,Double) -> T (Double,Double) #-}+{-# SPECULATE mixSize :: ChunkSize -> T (Float,Float) -> T (Float,Float) -> T (Float,Float) #-}+{-# INLINE mixSize #-}+mixSize :: (Additive.C x, Storable x) =>+      ChunkSize+   -> T x+   -> T x+   -> T x+mixSize size =+   curry (Vector.unfoldr size mixStep)+++{-# INLINE mixStep #-}+mixStep :: (Additive.C x, Storable x) =>+   (T x, T x) ->+   Maybe (x, (T x, T x))+mixStep (xt,yt) =+   case (Vector.viewL xt, Vector.viewL yt) of+      (Just (x,xs), Just (y,ys)) -> Just (x+y, (xs,ys))+      (Nothing,     Just (y,ys)) -> Just (y,   (xt,ys))+      (Just (x,xs), Nothing)     -> Just (x,   (xs,yt))+      (Nothing,     Nothing)     -> Nothing++++{-# INLINE delay #-}+delay :: (Storable y) =>+   ChunkSize -> y -> Int -> T y -> T y+delay size z n = Vector.append (Vector.replicate size n z)++{-# INLINE delayLoop #-}+delayLoop ::+   (Storable y) =>+      (T y -> T y)+            -- ^ processor that shall be run in a feedback loop+   -> T y   -- ^ prefix of the output, its length determines the delay+   -> T y+delayLoop proc prefix =+   let ys = Vector.append prefix (proc ys)+   in  ys+++{-# INLINE delayLoopOverlap #-}+delayLoopOverlap ::+   (Additive.C y, Storable y) =>+      Int+   -> (T y -> T y)+            {- ^ Processor that shall be run in a feedback loop.+                 It's absolutely necessary that this function preserves the chunk structure+                 and that it does not look a chunk ahead.+                 That's guaranteed for processes that do not look ahead at all,+                 like 'Vector.map', 'Vector.crochetL' and+                 all of type @Causal.Process@. -}+   -> T y   -- ^ input+   -> T y   -- ^ output has the same length as the input+delayLoopOverlap time proc xs =+   let ys = Vector.zipWith (Additive.+) xs+               (delay (Vector.chunkSize time) Additive.zero time (proc ys))+   in  ys++++{-+{-# INLINE zip #-}+zip :: (Storable a, Storable b) =>+   ChunkSize -> (T a -> T b -> T (a,b))+zip size  =  zipWith size (,)++{-# INLINE zipWith3 #-}+zipWith3 :: (Storable a, Storable b, Storable c, Storable d) =>+   ChunkSize -> (a -> b -> c -> d) -> (T a -> T b -> T c -> T d)+zipWith3 size f s0 s1 =+   zipWith size (uncurry f) (zip size s0 s1)++{-# INLINE zipWith4 #-}+zipWith4 :: (Storable a, Storable b, Storable c, Storable d, Storable e) =>+   ChunkSize -> (a -> b -> c -> d -> e) -> (T a -> T b -> T c -> T d -> T e)+zipWith4 size f s0 s1 =+   zipWith3 size (uncurry f) (zip size s0 s1)+++{- * Fusable functions -}++{-# INLINE [0] zipWith #-}+zipWith :: (Storable x, Storable y, Storable z) =>+      ChunkSize+   -> (x -> y -> z)+   -> T x+   -> T y+   -> T z+zipWith size f =+   curry (unfoldr size (\(xt,yt) ->+      liftM2+         (\(x,xs) (y,ys) -> (f x y, (xs,ys)))+         (viewL xt)+         (viewL yt)))++++scanLCrochet :: (Storable a, Storable b) =>+   (a -> b -> a) -> a -> T b -> T a+scanLCrochet f start =+   cons start .+   crochetL (\x acc -> let y = f acc x in Just (y, y)) start++{-# INLINE mapCrochet #-}+mapCrochet :: (Storable a, Storable b) => (a -> b) -> (T a -> T b)+mapCrochet f = crochetL (\x _ -> Just (f x, ())) ()+-}++{-# INLINE takeCrochet #-}+takeCrochet :: Storable a => Int -> T a -> T a+takeCrochet = Vector.crochetL (\x n -> toMaybe (n>0) (x, pred n))++{-+{-# INLINE repeatUnfoldr #-}+repeatUnfoldr :: Storable a => ChunkSize -> a -> T a+repeatUnfoldr size = iterate size id++{-# INLINE replicateCrochet #-}+replicateCrochet :: Storable a => ChunkSize -> Int -> a -> T a+replicateCrochet size n = takeCrochet n . repeat size++++{-+crochetFusionListLGenerate size g b f a =+        unfoldr size (\(a0,b0) ->+            do (y0,a1) <- f a0+               (z0,b1) <- g y0 b0+               Just (z0, (a1,b1))) (a,b) ;++-}+++{-# RULES+  "Storable.crochetFusionListL/crochetL" forall size f g a b x.+     crochetFusionListL size g b (FList.crochetL f a x) =+        crochetFusionListL size (\x0 (a0,b0) ->+            do (y0,a1) <- f x0 a0+               (z0,b1) <- g y0 b0+               Just (z0, (a1,b1))) (a,b) x ;++  "Storable.crochetFusionListL/generate" forall size f g a b.+     crochetFusionListL size g b (FList.generate f a) =+        unfoldr size (\(a0,b0) ->+            do (y0,a1) <- f a0+               (z0,b1) <- g y0 b0+               Just (z0, (a1,b1))) (a,b) ;++{-+  "Storable.fromFusionList/crochetL"+     forall size f a (x :: Storable a => FList.T a) .+     fromFusionList size (FList.crochetL f a x) =+        crochetL f a (fromFusionList size x) ;+-}++  "Storable.fromFusionList/generate" forall size f a.+     fromFusionList size (FList.generate f a) =+        unfoldr size f a ;++  "Storable.fromFusionList/cons" forall size x xs.+     fromFusionList size (FList.cons x xs) =+        cons x (fromFusionList size xs) ;++  "Storable.fromFusionList/empty" forall size.+     fromFusionList size (FList.empty) =+        empty ;++  "Storable.fromFusionList/append" forall size xs ys.+     fromFusionList size (FList.append xs ys) =+        append (fromFusionList size xs) (fromFusionList size ys) ;++  "Storable.fromFusionList/maybe" forall size f x y.+     fromFusionList size (maybe x f y) =+        maybe (fromFusionList size x)+           (fromFusionList size . f) y ;++  "Storable.fromFusionList/fromMaybe" forall size x y.+     fromFusionList size (fromMaybe x y) =+        maybe (fromFusionList size x) (fromFusionList size) y ;+  #-}+++{-+The "fromList/drop" rule is not quite accurate+because the chunk borders are moved.+Maybe 'ChunkSize' better is a list of chunks sizes.+-}++{-# RULEZ+  "fromList/zipWith"+    forall size f (as :: Storable a => [a]) (bs :: Storable a => [a]).+     fromList size (List.zipWith f as bs) =+        zipWith size f (fromList size as) (fromList size bs) ;++  "fromList/drop" forall as n size.+     fromList size (List.drop n as) =+        drop n (fromList size as) ;+  #-}++++{- * Fused functions -}++type Unfoldr s a = (s -> Maybe (a,s), s)++{-# INLINE zipWithUnfoldr2 #-}+zipWithUnfoldr2 :: Storable z =>+      ChunkSize+   -> (x -> y -> z)+   -> Unfoldr a x+   -> Unfoldr b y+   -> T z+zipWithUnfoldr2 size h (f,a) (g,b) =+   unfoldr size+      (\(a0,b0) -> liftM2 (\(x,a1) (y,b1) -> (h x y, (a1,b1))) (f a0) (g b0))+--      (uncurry (liftM2 (\(x,a1) (y,b1) -> (h x y, (a1,b1)))) . (f *** g))+      (a,b)++{- done by takeCrochet+{-# INLINE mapUnfoldr #-}+mapUnfoldr :: (Storable x, Storable y) =>+      ChunkSize+   -> (x -> y)+   -> Unfoldr a x+   -> T y+mapUnfoldr size g (f,a) =+   unfoldr size (fmap (mapFst g) . f) a+-}++{-# INLINE dropUnfoldr #-}+dropUnfoldr :: Storable x =>+      ChunkSize+   -> Int+   -> Unfoldr a x+   -> T x+dropUnfoldr size n (f,a0) =+   maybe+      empty+      (unfoldr size f)+      (nest n (\a -> fmap snd . f =<< a) (Just a0))+++{- done by takeCrochet+{-# INLINE takeUnfoldr #-}+takeUnfoldr :: Storable x =>+      ChunkSize+   -> Int+   -> Unfoldr a x+   -> T x+takeUnfoldr size n0 (f,a0) =+   unfoldr size+      (\(a,n) ->+         do guard (n>0)+            (x,a') <- f a+            return (x, (a', pred n)))+      (a0,n0)+-}+++lengthUnfoldr :: Storable x =>+      Unfoldr a x+   -> Int+lengthUnfoldr (f,a0) =+   let recourse n a =+          maybe n (recourse (succ n) . snd) (f a)+   in  recourse 0 a0+++{-# INLINE zipWithUnfoldr #-}+zipWithUnfoldr ::+   (Storable b, Storable c) =>+      (acc -> Maybe (a, acc))+   -> (a -> b -> c)+   -> acc+   -> T b -> T c+zipWithUnfoldr f h a y =+   crochetL (\y0 a0 ->+       do (x0,a1) <- f a0+          Just (h x0 y0, a1)) a y++{-# INLINE zipWithCrochetL #-}+zipWithCrochetL ::+   (Storable x, Storable b, Storable c) =>+      ChunkSize+   -> (x -> acc -> Maybe (a, acc))+   -> (a -> b -> c)+   -> acc+   -> T x -> T b -> T c+zipWithCrochetL size f h a x y =+   crochetL (\(x0,y0) a0 ->+       do (z0,a1) <- f x0 a0+          Just (h z0 y0, a1))+      a (zip size x y)+++{-# INLINE crochetLCons #-}+crochetLCons ::+   (Storable a, Storable b) =>+      (a -> acc -> Maybe (b, acc))+   -> acc+   -> a -> T a -> T b+crochetLCons f a0 x xs =+   maybe+      empty+      (\(y,a1) -> cons y (crochetL f a1 xs))+      (f x a0)++{-# INLINE reduceLCons #-}+reduceLCons ::+   (Storable a) =>+      (a -> acc -> Maybe acc)+   -> acc+   -> a -> T a -> acc+reduceLCons f a0 x xs =+   maybe a0 (flip (reduceL f) xs) (f x a0)++++++{-# RULES+  "Storable.zipWith/share" forall size (h :: a->a->b) (x :: T a).+     zipWith size h x x = map (\xi -> h xi xi) x ;++--  "Storable.map/zipWith" forall size (f::c->d) (g::a->b->c) (x::T a) (y::T b).+  "Storable.map/zipWith" forall size f g x y.+     map f (zipWith size g x y) =+        zipWith size (\xi yi -> f (g xi yi)) x y ;++  -- this rule lets map run on a different block structure+  "Storable.zipWith/map,*" forall size f g x y.+     zipWith size g (map f x) y =+        zipWith size (\xi yi -> g (f xi) yi) x y ;++  "Storable.zipWith/*,map" forall size f g x y.+     zipWith size g x (map f y) =+        zipWith size (\xi yi -> g xi (f yi)) x y ;+++  "Storable.drop/unfoldr" forall size f a n.+     drop n (unfoldr size f a) =+        dropUnfoldr size n (f,a) ;++  "Storable.take/unfoldr" forall size f a n.+     take n (unfoldr size f a) =+--        takeUnfoldr size n (f,a) ;+        takeCrochet n (unfoldr size f a) ;++  "Storable.length/unfoldr" forall size f a.+     length (unfoldr size f a) = lengthUnfoldr (f,a) ;++  "Storable.map/unfoldr" forall size g f a.+     map g (unfoldr size f a) =+--        mapUnfoldr size g (f,a) ;+        mapCrochet g (unfoldr size f a) ;++  "Storable.map/iterate" forall size g f a.+     map g (iterate size f a) =+        mapCrochet g (iterate size f a) ;++{-+  "Storable.zipWith/unfoldr,unfoldr" forall sizeA sizeB f g h a b n.+     zipWith n h (unfoldr sizeA f a) (unfoldr sizeB g b) =+        zipWithUnfoldr2 n h (f,a) (g,b) ;+-}++  -- block boundaries are changed here, so it changes lazy behaviour+  "Storable.zipWith/unfoldr,*" forall sizeA sizeB f h a y.+     zipWith sizeA h (unfoldr sizeB f a) y =+        zipWithUnfoldr f h a y ;++  -- block boundaries are changed here, so it changes lazy behaviour+  "Storable.zipWith/*,unfoldr" forall sizeA sizeB f h a y.+     zipWith sizeA h y (unfoldr sizeB f a) =+        zipWithUnfoldr f (flip h) a y ;++  "Storable.crochetL/unfoldr" forall size f g a b.+     crochetL g b (unfoldr size f a) =+        unfoldr size (\(a0,b0) ->+            do (y0,a1) <- f a0+               (z0,b1) <- g y0 b0+               Just (z0, (a1,b1))) (a,b) ;++  "Storable.reduceL/unfoldr" forall size f g a b.+     reduceL g b (unfoldr size f a) =+        snd+          (FList.recourse (\(a0,b0) ->+              do (y,a1) <- f a0+                 b1 <- g y b0+                 Just (a1, b1)) (a,b)) ;++  "Storable.crochetL/cons" forall g b x xs.+     crochetL g b (cons x xs) =+        crochetLCons g b x xs ;++  "Storable.reduceL/cons" forall g b x xs.+     reduceL g b (cons x xs) =+        reduceLCons g b x xs ;+++++  "Storable.take/crochetL" forall f a x n.+     take n (crochetL f a x) =+        takeCrochet n (crochetL f a x) ;++  "Storable.length/crochetL" forall f a x.+     length (crochetL f a x) = length x ;++  "Storable.map/crochetL" forall g f a x.+     map g (crochetL f a x) =+        mapCrochet g (crochetL f a x) ;++  "Storable.zipWith/crochetL,*" forall size f h a x y.+     zipWith size h (crochetL f a x) y =+        zipWithCrochetL size f h a x y ;++  "Storable.zipWith/*,crochetL" forall size f h a x y.+     zipWith size h y (crochetL f a x) =+        zipWithCrochetL size f (flip h) a x y ;++  "Storable.crochetL/crochetL" forall f g a b x.+     crochetL g b (crochetL f a x) =+        crochetL (\x0 (a0,b0) ->+            do (y0,a1) <- f x0 a0+               (z0,b1) <- g y0 b0+               Just (z0, (a1,b1))) (a,b) x ;++  "Storable.reduceL/crochetL" forall f g a b x.+     reduceL g b (crochetL f a x) =+        snd+          (reduceL (\x0 (a0,b0) ->+              do (y,a1) <- f x0 a0+                 b1 <- g y b0+                 Just (a1, b1)) (a,b) x) ;+  #-}++++{- * Fusion tests -}+++fromMapList :: (Storable y) => ChunkSize -> (x -> y) -> [x] -> T y+fromMapList size f =+   unfoldr size (fmap (mapFst f) . ListHT.viewL)++{-# RULES+  "Storable.fromList/map" forall size f xs.+     fromList size (List.map f xs) = fromMapList size f xs ;+  #-}+++fromMapFusionList :: (Storable y) =>+   ChunkSize -> (x -> y) -> FList.T x -> T y+fromMapFusionList size f =+   unfoldr size (fmap (mapFst f) . FList.viewL)++{-# RULES+  "Storable.fromFusionList/map" forall size f xs.+     fromFusionList size (FList.map f xs) = fromMapFusionList size f xs ;++  "Storable.fromFusionList/replicate" forall size n x.+     fromFusionList size (FList.replicate n x) = replicate size n x ;+  #-}+++++testLength :: (Storable a, Enum a) => a -> Int+testLength x = length (map succ (fromList (ChunkSize 100) [x,x,x]))++testMapZip :: (Storable a, Enum a, Num a) =>+   ChunkSize -> T a -> T a -> T a+-- testMapZip size x y = map snd (zipWith size (,) x y)+testMapZip size x y = map succ (zipWith size (P.+) x y)++testMapCons :: (Storable a, Enum a) =>+   a -> T a -> T a+testMapCons x xs = map succ (cons x xs)++{-# INLINE testMapIterate #-}+{-# SPECIALISE testMapIterate ::+   ChunkSize -> Char -> T Char #-}+testMapIterate :: (Storable a, Enum a) =>+   ChunkSize -> a -> T a+testMapIterate size y = map pred $ iterate size succ y++testMapIterateInt ::+   ChunkSize -> Int -> T Int+testMapIterateInt = testMapIterate++-}
+ src/Synthesizer/Storage.hs view
@@ -0,0 +1,152 @@+{- |+Rendering sound effects off-line has its virtue,+but really cool is real-time signal generation.+For a long time I thought that it is the compiler's responsibility+to make list based signal processing fast enough.+However, the compiler has to respect correctness first.+That is, it cannot do too fancy optimization,+since the optimized program must still do the same as the unoptimized program.+So, when we write functions that rely on the maximal flexibility,+the compiler cannot turn it to something less flexible.+Actually, a list as in "Synthesizer.Plain.Signal"+is the best representation of a signal+in terms of flexibility:+It allows free choice of the element type, even functions,+it is element-wise lazy, allowing for short feedback,+it allows sharing of computed data.+The drawback is, that it is slow and memory inefficient.+In most cases we don't need this full flexibility,+but the compiler has no chance to find this out automatically.+It can merge several operations on a list+to a single operation by the fusion technique,+however even a single list operation is hard to get in real-time.++How do real-time software synthesizer achieve real-time performance?+They get the popular fast inner loops+by processing signals in chunks of raw data.+This way, they lose flexibility, because they cannot do quick feedback.+We can do the same in Haskell, getting the same restrictions.+Additionally, in order to store raw data+we must restrict the element types+e.g. to the @Storable@ class,+since we use @StorableVector@ in "Synthesizer.Storable.Signal".+With this technique single signal operations are fast,+but their combination cannot be optimized in many cases.+This is so, again, because top priority in optimization is correctness.+Consider @mix x (cons 0 x)@+where @cons 0 x@ means @0:x@ for our chunky signal data.+This expression is a perfect candidate for optimization.+But in this case it must not be applied since the chunk structures of+@x@ and @cons 0 x@ do not match.+In such cases we would not gain anything over SuperCollider and CSound.++Remember that we introduced the chunky signal representation+entirely because of efficiency concerns.+Actually we are not interested in a special chunk structure,+so this should not be a reason for disabling optimization.+Of course, we could ignore the correctness+and write incorrect optimizer rules+that are based on correct ideas.+However, experience shows that wrong optimization+leads to surprise and infelicities sooner or later.+The later the worse,+because the later the more code you have written+relying on invalid optimization.++What we can try is to use list representation,+enjoy the optimization that GHC already provides for it,+and then let fusion rules jump in+that make lists disappear when they are used in connection with chunky sequences.+E.g. @Chunky.fromList (List.oscillator freq)@+could be turned into @Chunky.oscillator freq@.+This approach would be really cool, but works only in theory.+In practice it is hard to predict how GHC transforms various operations.+Additionally to optimizer rule application+it also expands functions to their definitions (known as inlining/unfolding)+or specializes functions to fixed types.+We cannot rely on our optimizer rules being actually applied.+This means however, that in unpredictable cases+the optimization fails and the efficiency drops from real-time to non-real-time.+This is unacceptable.++The solution is a third signal representation,+see "Synthesizer.State.Signal".+(Already got tired?)+It consists of no actual data+but it is a function that generates elements.+Its type is @s -> Maybe (a,s)@ or short @StateT s Maybe a@.+Given a state of type @s@ it produces @Nothing@ when the list terminates+or @Just@ the next element and the updated state.+This can be easily converted from and to lists+while preserving laziness.+We convert to lists by @List.unfoldr@ and from lists using @viewL@.+Actually this signal representation is very close+to the list representation used in the streams package.+The main differences are:+Firstly, we do not use a list storage that is fused away when only used temporarily.+Thus we do not need a fusion rule (that could be skipped by the compiler).+Secondly, we have no notion of 'Skip',+since operations like 'filter' are uncommon in signal processing.+If we write our signal processing in terms of these virtual signals+and then convert the result to regular lists or chunky sequences,+then only one data structure will be built+and GHC does it's best to generate efficient inner loops.++We cannot use these virtual signals for sharing and feedback,+because there is no data structure that stores the data.+If we try to do so anyway, data will be recomputed.+Thus we still need chunky sequences or lists+for sharing of interim results and for feedback.+Actually, an expression like @mix x (reverse x)@+would definitely benefit from interim conversion to a chunky sequence,+but for @mix x (cons 0 x)@ this is overkill.++In order to get processes like the last one efficient+we have a new data type (no, not another one!)+but this time it is not a signal data type+but a signal processor type.+It is the result of thinking about+which processes allow sharing on a per-sample basis at all.+We come to the conclusion that these can be only causal processes,+i.e. processes that depend only on current and past data,+not on data from the future.+So, we already have a good name: "Synthesizer.Causal.Process".+Causal processes are "Control.Arrow"s,+however the higher level variant does no longer fit into the Arrow type class.+This means that there are various combinations+that turn causal processes into larger causal processes.+It needs a bit experience in pointfree coding style+in order to use the arrow combinators,+but there is no way around it,+when you want to use physical dimensions.+GHC's arrow notation does only support types of the Arrow class.+E.g. the expression @mix x (cons 0 x)@+becomes @Causal.mix <<< (Causal.id &&& Causal.cons 0)@.+When you manage this burden+you get processes that are warranted to be causal.+They can not only be used to make something efficient,+but they also allow to process data from the outside world+in a streaming way without 'unsafeInterleaveIO'+as required e.g. in JACK plugins.++For historical reasons there is also "Synthesizer.FusionList.Signal"+which is a wrapper around lists.+I used this data type to disable GHC's default list optimizer rules+and use my own ones.+The fusion is based on @unfoldr@ and @crochetL@+which is quite similar to the @stream-fusion@ package.+The @stream-fusion@ uses internally a @Skip@ constructor,+which, as far as I understand,+is better for the @filter@ function.+We do not need it,+because the @filter@ function is very uncommon in signal processing.+I think, @FusionList@ can be replaced by @stream-fusion@ functions.++We have now a pretty big set of signal storage types+that differ considerably in performance+but not in the set of operations.+This calls for a type class!+You find it in "Synthesizer.Generic.Signal"+and "Synthesizer.Generic.Signal2".+-}+module Synthesizer.Storage where
+ src/Synthesizer/Utility.hs view
@@ -0,0 +1,61 @@+module Synthesizer.Utility where++import qualified Algebra.Module    as Module+import qualified Algebra.RealField as RealField+import qualified Algebra.Field     as Field++import System.Random (Random, RandomGen, randomRs, )++import Prelude ()+import PreludeBase+import NumericPrelude+++{-|+If two values are equal, then return one of them,+otherwise raise an error.+-}+{-# INLINE common #-}+common :: (Eq a) => String -> a -> a -> a+common errorMsg x y =+   if x == y+     then x+     else error errorMsg+++-- * arithmetic+++{-# INLINE fwrap #-}+fwrap :: RealField.C a => (a,a) -> a -> a+fwrap (lo,hi) x = lo + fmod (x-lo) (hi-lo)++{-# INLINE fmod #-}+fmod :: RealField.C a => a -> a -> a+fmod x y = fraction (x/y) * y++{-# INLINE fmodAlt #-}+fmodAlt :: RealField.C a => a -> a -> a+fmodAlt x y = x - fromInteger (floor (x/y)) * y++propFMod :: RealField.C a => a -> a -> Bool+propFMod x y =+--   y /= 0 ==>+   fmod x y == fmodAlt x y++{-# INLINE affineComb #-}+affineComb :: (Module.C t y) => t -> (y,y) -> y+affineComb phase (x0,x1) = x0 + phase *> (x1-x0)++{-# INLINE balanceLevel #-}+balanceLevel :: (Field.C y) =>+   y -> [y] -> [y]+balanceLevel center xs =+   let d = center - sum xs / fromIntegral (length xs)+   in  map (d+) xs++{-# INLINE randomRsBalanced #-}+randomRsBalanced :: (RandomGen g, Random y, Field.C y) =>+   g -> Int -> y -> y -> [y]+randomRsBalanced g n center width =+   balanceLevel center (take n $ randomRs (zero,width) g)
+ src/Test/Main.hs view
@@ -0,0 +1,33 @@+module Main where++import qualified Test.Sound.Synthesizer.Plain.Analysis       as Analysis+import qualified Test.Sound.Synthesizer.Plain.Control        as Control+import qualified Test.Sound.Synthesizer.Plain.Filter         as Filter+import qualified Test.Sound.Synthesizer.Plain.Interpolation  as Interpolation+import qualified Test.Sound.Synthesizer.Plain.Oscillator     as Oscillator+import qualified Test.Sound.Synthesizer.Plain.Wave           as Wave+import qualified Test.Sound.Synthesizer.Basic.ToneModulation as ToneModulation+import qualified Test.Sound.Synthesizer.Plain.ToneModulation as ToneModulationL+import qualified Test.Sound.Synthesizer.Generic.ToneModulation as ToneModulationG++import Data.Tuple.HT (mapFst, )+++prefix :: String -> [(String, IO ())] -> [(String, IO ())]+prefix msg =+   map (mapFst (\str -> msg ++ "." ++ str))++main :: IO ()+main =+   mapM_ (\(msg,io) -> putStr (msg++": ") >> io) $+   concat $+      prefix "Plain.Analysis"       Analysis.tests :+      prefix "Plain.Control"        Control.tests :+      prefix "Plain.Filter"         Filter.tests :+      prefix "Plain.Interpolation"  Interpolation.tests :+      prefix "Plain.Oscillator"     Oscillator.tests :+      prefix "Plain.Wave"           Wave.tests :+      prefix "Basic.ToneModulation" ToneModulation.tests :+      prefix "Plain.ToneModulation" ToneModulationL.tests :+      prefix "Generic.ToneModulation" ToneModulationG.tests :+      []
+ src/Test/Sound/Synthesizer/Basic/ToneModulation.hs view
@@ -0,0 +1,98 @@+module Test.Sound.Synthesizer.Basic.ToneModulation where++import qualified Synthesizer.Interpolation  as Interpolation+import Synthesizer.Interpolation (margin, )++import qualified Synthesizer.Basic.Phase          as Phase+import qualified Synthesizer.Basic.ToneModulation as ToneMod++import qualified Test.Sound.Synthesizer.Plain.Interpolation as InterpolationTest++import Test.QuickCheck (test, Property, (==>), Testable, )+-- import Test.Utility++import qualified Number.NonNegative       as NonNeg+-- import qualified Number.NonNegativeChunky as Chunky++-- import qualified Algebra.RealTranscendental    as RealTrans+-- import qualified Algebra.Module                as Module+import qualified Algebra.RealField             as RealField+import qualified Algebra.Field                 as Field+-- import qualified Algebra.Ring                  as Ring+import qualified Algebra.Additive              as Additive+++import NumericPrelude+import PreludeBase+import Prelude ()+++untangleShapePhase :: (Field.C a, Eq a) =>+   Int -> a -> (a, a) -> Property+untangleShapePhase periodInt period c =+   period /= zero ==>+      ToneMod.untangleShapePhase periodInt period c ==+      ToneMod.untangleShapePhaseAnalytic periodInt period c++flattenShapePhase :: (RealField.C a) =>+   Int -> a -> (a, Phase.T a) -> Property+flattenShapePhase periodInt period c =+   period /= zero ==>+      ToneMod.flattenShapePhase periodInt period c ==+      ToneMod.flattenShapePhaseAnalytic periodInt period c+++-- * auxiliary test functions++{-+Although that looks like a too small value, it is actually right,+because numberLeap counts intervals of size periodInt, not single elements.+So numberLeap=2 like in linear interpolation means 2*periodInt.+-}+minLength ::+   Interpolation.T a v ->+   Interpolation.T a v ->+   Int -> NonNeg.Int -> Int+minLength ipLeap ipStep =+   minLengthMargin (margin ipLeap) (margin ipStep)++minLengthMargin ::+   Interpolation.Margin ->+   Interpolation.Margin ->+   Int -> NonNeg.Int -> Int+minLengthMargin marginLeap marginStep periodInt ext =+   ToneMod.interpolationNumber+      marginLeap marginStep periodInt ++   NonNeg.toNumber ext++++shapeLimits ::+   Interpolation.T a v ->+   Interpolation.T a v ->+   Int -> Int -> (Int, Int)+shapeLimits ipLeap ipStep periodInt len =+   ToneMod.shapeLimits+      (margin ipLeap) (margin ipStep)+      periodInt len++++testRationalLineIp :: Testable test =>+   (InterpolationTest.LinePreserving Rational Rational -> test) -> IO ()+testRationalLineIp f  =  test f++testRationalIp :: Testable test =>+   (InterpolationTest.T Rational Rational -> test) -> IO ()+testRationalIp f  =  test f+++tests :: [(String, IO ())]+tests =+   ("untangleShapePhase",+      test (\periodInt period ->+                untangleShapePhase periodInt (period :: Rational))) :+   ("flattenShapePhase",+      test (\periodInt period ->+                flattenShapePhase periodInt (period :: Rational))) :+   []
+ src/Test/Sound/Synthesizer/Generic/ToneModulation.hs view
@@ -0,0 +1,313 @@+module Test.Sound.Synthesizer.Generic.ToneModulation (tests) where++import Test.Sound.Synthesizer.Basic.ToneModulation (+   minLength,+   minLengthMargin,+--   shapeLimits,+--   testRationalLineIp,+   testRationalIp,+   )++import Test.Sound.Synthesizer.Plain.ToneModulation (+   InfiniteList,+   listFromInfinite,+   )++import qualified Synthesizer.Causal.ToneModulation as ToneModC+import qualified Synthesizer.Generic.Wave as WaveG++import qualified Synthesizer.Plain.Signal         as Sig+import qualified Synthesizer.Plain.Oscillator     as Osci+import qualified Synthesizer.Plain.Interpolation  as Interpolation+import qualified Synthesizer.Plain.ToneModulation as ToneModL+import qualified Synthesizer.Plain.Wave   as WaveL+import Synthesizer.Interpolation (marginNumber, )++import qualified Synthesizer.Causal.Oscillator as OsciC+import qualified Synthesizer.Causal.Process as Causal++import qualified Synthesizer.State.Signal as SigS++import qualified Synthesizer.Basic.Wave           as Wave+import qualified Synthesizer.Basic.Phase          as Phase++import qualified Test.Sound.Synthesizer.Plain.Interpolation as InterpolationTest++import Test.QuickCheck (test, Property, (==>), )+import Test.Utility (ArbChar, )+-- import Debug.Trace (trace, )++import qualified Number.NonNegative       as NonNeg++-- import qualified Algebra.RealTranscendental    as RealTrans+-- import qualified Algebra.Module                as Module+import qualified Algebra.RealField             as RealField+-- import qualified Algebra.Field                 as Field+-- import qualified Algebra.Ring                  as Ring+import qualified Algebra.Additive              as Additive+++import Data.List.HT (viewL, takeWhileJust, )+import Data.Tuple.HT (mapSnd, )+import qualified Data.List as List+++import NumericPrelude+import PreludeBase+import Prelude ()+++limitMinRelativeValues ::+   Int -> Int -> [NonNeg.Int] -> Bool+limitMinRelativeValues xMin x0 xsnn =+   let xs = map NonNeg.toNumber xsnn+       (y0,limiter) = ToneModC.limitMinRelativeValues xMin x0+   in  (y0, Causal.applyGeneric limiter xs) ==+          ToneModL.limitMinRelativeValues xMin x0 xs++integrateFractional :: (RealField.C t) =>+   NonNeg.T t -> t -> Phase.T t -> [NonNeg.T t] -> [t] -> Property+integrateFractional+     periodNN shape0 phase shapesNN freqs =+   let shapes = map NonNeg.toNumber shapesNN+       period    = NonNeg.toNumber periodNN+       (c0, coordinator) =+          ToneModC.integrateFractional+             period (shape0, phase)+       coords =+          ToneModL.integrateFractional+             period (shape0, shapes) (phase, freqs)+   in  period /= zero  ==>+          c0 : Causal.applyGeneric coordinator (zip shapes freqs) ==+          coords++-- oscillatorCellSize :: (Show t, Show v, RealField.C t, Eq v) =>+oscillatorCellSize :: (RealField.C t, Eq v) =>+   Interpolation.Margin ->+   Interpolation.Margin ->+   NonNeg.Int -> NonNeg.T t ->+   NonNeg.Int -> InfiniteList v ->+   t -> t -> [NonNeg.T t] -> [t] ->+   Property+oscillatorCellSize+      marginLeap marginStep periodIntNN periodNN ext+      ixs shape0 phase shapesNN freqs =+   let shapes = map NonNeg.toNumber shapesNN+       period    = NonNeg.toNumber periodNN+       periodInt = NonNeg.toNumber periodIntNN+       len = minLengthMargin marginLeap marginStep periodInt ext+       tone = take len (listFromInfinite ixs)+       resampledTone =+          ToneModC.oscillatorCells+             marginLeap marginStep periodInt period tone+             (shape0, Phase.fromRepresentative phase)+          `Causal.applyGeneric`+          zip shapes freqs+   in  period /= zero  &&+       marginNumber marginLeap > zero &&+       marginNumber marginStep > zero  ==>+       all+          ((\cell ->+              Sig.lengthAtLeast (marginNumber marginLeap) cell &&+              all (Sig.lengthAtLeast (marginNumber marginStep))+                  (take (marginNumber marginLeap) cell))+           . SigS.toList . snd)+          resampledTone++oscillatorSuffixes :: (RealField.C t, Eq v) =>+   Interpolation.Margin ->+   Interpolation.Margin ->+   NonNeg.Int -> NonNeg.T t ->+   NonNeg.Int -> InfiniteList v ->+   t -> t -> [NonNeg.T t] -> [t] ->+   Property+oscillatorSuffixes+      marginLeap marginStep periodIntNN periodNN ext+      ixs shape0 phase shapesNN freqs =+   let shapes = map NonNeg.toNumber shapesNN+       period    = NonNeg.toNumber periodNN+       periodInt = NonNeg.toNumber periodIntNN+       len = minLengthMargin marginLeap marginStep periodInt ext+       tone = take len (listFromInfinite ixs)+       resampledToneA =+          init $+          map (\(sp,cell) ->+             (sp, takeWhileJust . map (fmap fst . viewL) $ cell)) $+          ToneModL.oscillatorSuffixes+             marginLeap marginStep periodInt period tone+             (shape0, shapes) (Phase.fromRepresentative phase, freqs)+       resampledToneB =+          ToneModC.oscillatorSuffixes+             marginLeap marginStep periodInt period tone+             (shape0, Phase.fromRepresentative phase)+          `Causal.applyGeneric`+          zip shapes freqs+   in  period /= zero  &&+       periodInt /= zero  &&+       marginNumber marginLeap > zero &&+       marginNumber marginStep > zero  ==>+          resampledToneA == resampledToneB++oscillatorCells :: (RealField.C t, Eq v) =>+   Interpolation.Margin ->+   Interpolation.Margin ->+   NonNeg.Int -> NonNeg.T t ->+   NonNeg.Int -> InfiniteList v ->+   t -> t -> [NonNeg.T t] -> [t] ->+   Property+oscillatorCells+      marginLeap marginStep periodIntNN periodNN ext+      ixs shape0 phase shapesNN freqs =+   let shapes = map NonNeg.toNumber shapesNN+       period    = NonNeg.toNumber periodNN+       periodInt = NonNeg.toNumber periodIntNN+       len = minLengthMargin marginLeap marginStep periodInt ext+       tone = take len (listFromInfinite ixs)+       resampledToneA =+          init $ map (mapSnd List.transpose) $+          ToneModL.oscillatorCells+             marginLeap marginStep periodInt period tone+             (shape0, shapes) (Phase.fromRepresentative phase, freqs)+       resampledToneB =+          map (mapSnd SigS.toList) $+          ToneModC.oscillatorCells+             marginLeap marginStep periodInt period tone+             (shape0, Phase.fromRepresentative phase)+          `Causal.applyGeneric`+          zip shapes freqs+   in  period /= zero  &&+       periodInt /= zero  &&+       marginNumber marginLeap > zero &&+       marginNumber marginStep > zero  ==>+          resampledToneA == resampledToneB+{-+Margin {marginNumber = 1, marginOffset = 2}+Margin {marginNumber = 5, marginOffset = 5}+3 % 4+0+('\DEL',['~','~','"'])+-2 % 5+2 % 5+[2 % 1,3 % 4]+[-5 % 2,-1 % 2]+-}++{- |+'WaveL.sampledTone' and 'WaveG.sampledTone'+do not only differ in the signal types they process,+but also in the way they order the signal values.+The cells for 'WaveL.sampledTone' are transposed+with respect to 'WaveG.sampledTone'.+-}+sampledTone :: (RealField.C a, Eq v) =>+   InterpolationTest.T a v ->+   InterpolationTest.T a v ->+   NonNeg.T a -> NonNeg.Int -> InfiniteList v ->+   a -> Phase.T a -> Property+sampledTone =+   InterpolationTest.use2 $ \ ipLeap ipStep+         periodNN ext ixs shape phase ->+   let period = NonNeg.toNumber periodNN+       periodInt = round period+       len = minLength ipLeap ipStep periodInt ext+       tone = take len (listFromInfinite ixs)+   in  period /= zero ==>+          WaveG.sampledTone ipLeap ipStep period tone shape `Wave.apply` phase ==+          WaveL.sampledTone ipLeap ipStep period tone shape `Wave.apply` phase++++shapeFreqModFromSampledTone :: (RealField.C t, Eq v) =>+   InterpolationTest.T t v ->+   InterpolationTest.T t v ->+   NonNeg.T t ->+   NonNeg.Int -> InfiniteList v ->+   t -> Phase.T t -> [NonNeg.T t] -> [t] ->+   Property+shapeFreqModFromSampledTone =+   InterpolationTest.use2 $ \ ipLeap ipStep+         periodNN ext ixs shape0 phase shapesNN freqs ->+   let shapes = map NonNeg.toNumber shapesNN+       period = NonNeg.toNumber periodNN+       periodInt = round period+       len = minLength ipLeap ipStep periodInt ext+       tone = take len (listFromInfinite ixs)+       resampledToneA =+          init $+          Osci.shapeFreqModFromSampledTone ipLeap ipStep period tone+             shape0 (Phase.toRepresentative phase) shapes freqs+       resampledToneB =+          OsciC.shapeFreqModFromSampledTone+             ipLeap ipStep period tone shape0 phase+          `Causal.applyGeneric`+          zip shapes freqs+   in  period /= zero  ==>+          resampledToneA == resampledToneB+++{-+We have a problem here with the phase distortion signal,+because frequency and shape modulation control signals+are delayed by one element with respect to the phase distortion.+How can we cope with different lengths of the control signals,+without padding the phase control with zeros?+This one did not work:+   phaseDistorts = pd:pds+   resampledToneA =+      Osci.shapePhaseFreqModFromSampledTone ipLeap ipStep period tone+         shape0 (Phase.toRepresentative phase) shapes (init phaseDistorts) freqs+-}+shapePhaseFreqModFromSampledTone :: (RealField.C t, Eq v) =>+   InterpolationTest.T t v ->+   InterpolationTest.T t v ->+   NonNeg.T t ->+   NonNeg.Int -> InfiniteList v ->+   t -> Phase.T t -> [NonNeg.T t] -> (t,[t]) -> [t] ->+   Property+shapePhaseFreqModFromSampledTone =+   InterpolationTest.use2 $ \ ipLeap ipStep+         periodNN ext ixs shape0 phase shapesNN (pd,pds) freqs ->+   let period = NonNeg.toNumber periodNN+       periodInt = round period+       len = minLength ipLeap ipStep periodInt ext+       tone = take len (listFromInfinite ixs)+       shapes = map NonNeg.toNumber shapesNN+       phaseDistorts = pd:pds ++ repeat zero+       resampledToneA =+          init $+          Osci.shapePhaseFreqModFromSampledTone ipLeap ipStep period tone+             shape0 (Phase.toRepresentative phase) shapes phaseDistorts freqs+       resampledToneB =+          OsciC.shapePhaseFreqModFromSampledTone+             ipLeap ipStep period tone shape0 phase+          `Causal.applyGeneric`+          zip3 shapes phaseDistorts freqs+   in  period /= zero  ==>+          resampledToneA == resampledToneB++++tests :: [(String, IO ())]+tests =+   ("limitMinRelativeValues", test limitMinRelativeValues) :+   ("integrateFractional",+      test (\period -> integrateFractional (period :: NonNeg.Rational))) :+   ("oscillatorCellSize",+      test (\ml ms periodInt period ext ixs ->+               oscillatorCellSize ml ms periodInt (period :: NonNeg.Rational)+                  ext (ixs :: InfiniteList ArbChar))) :+   ("oscillatorSuffixes",+      test (\ml ms periodInt period ext ixs ->+               oscillatorSuffixes ml ms periodInt (period :: NonNeg.Rational)+                  ext (ixs :: InfiniteList ArbChar))) :+   ("oscillatorCells",+      test (\ml ms periodInt period ext ixs ->+               oscillatorCells ml ms periodInt (period :: NonNeg.Rational)+                  ext (ixs :: InfiniteList ArbChar))) :+   ("sampledTone",+      testRationalIp sampledTone) :+   ("shapeFreqModFromSampledTone",+      testRationalIp shapeFreqModFromSampledTone) :+   ("shapePhaseFreqModFromSampledTone",+      testRationalIp shapePhaseFreqModFromSampledTone) :+   []
+ src/Test/Sound/Synthesizer/Plain/Analysis.hs view
@@ -0,0 +1,150 @@+module Test.Sound.Synthesizer.Plain.Analysis (tests) where++import qualified Synthesizer.Plain.Analysis as Analysis++import qualified Algebra.Algebraic             as Algebraic+import qualified Algebra.RealField             as RealField+import qualified Algebra.Field                 as Field+-- import qualified Algebra.Real                  as Real+import qualified Algebra.Ring                  as Ring+import qualified Algebra.Additive              as Additive++import qualified Algebra.NormedSpace.Maximum   as NormedMax+import qualified Algebra.NormedSpace.Euclidean as NormedEuc+import qualified Algebra.NormedSpace.Sum       as NormedSum++import qualified MathObj.LaurentPolynomial as LPoly++-- import Algebra.Module((*>))++import Data.List (genericLength)++import Test.QuickCheck (test, Property, (==>))+import Test.Utility (approxEqual)++-- import qualified Algebra.Ring                  as Ring+-- import qualified Algebra.Additive              as Additive++import NumericPrelude+import PreludeBase+import Prelude ()+++volumeVectorMaximum :: (NormedMax.C y y, Ord y) => [y] -> Bool+volumeVectorMaximum xs =+   Analysis.volumeVectorMaximum xs == Analysis.volumeMaximum xs++volumeVectorEuclidean :: (NormedEuc.C y y, Algebraic.C y) => y -> [y] -> Bool+volumeVectorEuclidean x xs =+   let ys = x:xs+   in  Analysis.volumeVectorEuclidean ys == Analysis.volumeEuclidean ys++volumeVectorEuclideanSqr :: (NormedEuc.Sqr y y, Field.C y) => y -> [y] -> Bool+volumeVectorEuclideanSqr x xs =+   let ys = x:xs+   in  Analysis.volumeVectorEuclideanSqr ys == Analysis.volumeEuclideanSqr ys++volumeVectorSum :: (NormedSum.C y y, Field.C y) => y -> [y] -> Bool+volumeVectorSum x xs =+   let ys = x:xs+   in  Analysis.volumeVectorSum ys == Analysis.volumeSum ys++++bounds :: Ord a => a -> [a] -> Bool+bounds x xs =+   let ys = x:xs+   in  Analysis.bounds ys  ==  (minimum ys, maximum ys)+++spread :: RealField.C a => (a,a) -> Bool+spread b =+   sum (map snd (Analysis.spread b)) == one+++histogramDiscrete :: Int -> [Int] -> Bool+histogramDiscrete x xs =+   let ys = x:xs+   in  Analysis.histogramDiscreteArray ys ==+       Analysis.histogramDiscreteIntMap ys++histogramDiscreteLength :: [Int] -> Bool+histogramDiscreteLength xs =+   sum (snd (Analysis.histogramDiscreteIntMap xs)) == length xs++histogramDiscreteConcat :: [Int] -> [Int] -> Bool+histogramDiscreteConcat xs ys =+   let xHist = Analysis.histogramDiscreteIntMap xs+       yHist = Analysis.histogramDiscreteIntMap ys+       xyHist0 =+          LPoly.add+             (uncurry LPoly.Cons xHist)+             (uncurry LPoly.Cons yHist)+       xyHist1 =+          uncurry LPoly.Cons+             (Analysis.histogramDiscreteIntMap (xs++ys))+   in  if null (LPoly.coeffs xyHist0)+         then LPoly.coeffs xyHist0 == LPoly.coeffs xyHist1+         else xyHist0 == xyHist1+++histogramLinear :: Int -> [Int] -> Bool+histogramLinear x xs =+   let ys = map fromIntegral (x:xs) :: [Double]+   in  Analysis.histogramLinearArray ys ==+       Analysis.histogramLinearIntMap ys+++histogramLinearLength :: Int -> [Int] -> Bool+histogramLinearLength x xs =+   let ys = map fromIntegral (x:xs) :: [Double]+   in  approxEqual 1e-10+          (genericLength ys)+          (sum (snd (Analysis.histogramLinearIntMap ys)) + 1)+{-+With eps = 1e-15++Falsifiable, after 83 tests:+-20+[32,-41,11,-25,-17,-27,32,-36,7,-36,38]++Falsifiable, after 78 tests:+10+[-35,-28,-28,-24,-4,-29,-14,-29,-20,7,33,-2,-14,-4,7,-40,-5,-12]+-}++++centroid :: (Field.C a, Eq a) => [a] -> Property+centroid xs =+   sum xs /= zero ==>+      Analysis.centroid xs == Analysis.centroidAlt xs+-- Test.QuickCheck.test (\xs -> sum xs /= 0 Test.QuickCheck.==> propCentroid (xs::[Rational]))++histogramDCOffset :: Int -> Int -> [Int] -> Property+histogramDCOffset x0 x1 xs =+   let x = x0:x1:xs+       (offset, hist) = Analysis.histogramDiscreteArray x+   in  sum x /= 0 ==>+          fromIntegral offset + Analysis.centroid (map fromIntegral hist) ==+          (Analysis.directCurrentOffset (map fromIntegral x) :: Rational)++++tests :: [(String, IO ())]+tests =+   ("volumeVectorMaximum", test (volumeVectorMaximum :: [Rational] -> Bool)) :+   -- test may fail due to rounding errors, but so far the computation is exactly the same+   ("volumeVectorEuclidean", test (volumeVectorEuclidean :: Double -> [Double] -> Bool)) :+   ("volumeVectorEuclideanSqr", test (volumeVectorEuclideanSqr :: Rational -> [Rational] -> Bool)) :+   ("volumeVectorSum", test (volumeVectorSum :: Rational -> [Rational] -> Bool)) :+   ("bounds", test (bounds :: Rational -> [Rational] -> Bool)) :+   ("spread", test (spread :: (Rational,Rational) -> Bool)) :+   ("histogramDiscrete", test (histogramDiscrete :: Int -> [Int] -> Bool)) :+   ("histogramDiscreteLength", test (histogramDiscreteLength :: [Int] -> Bool)) :+   ("histogramDiscreteConcat", test (histogramDiscreteConcat :: [Int] -> [Int] -> Bool)) :+   ("histogramLinear", test (histogramLinear :: Int -> [Int] -> Bool)) :+   ("histogramLinearLength", test (histogramLinearLength :: Int -> [Int] -> Bool)) :+   ("centroid", test (centroid :: [Rational] -> Property)) :+   ("histogramDCOffset", test (histogramDCOffset :: Int -> Int -> [Int] -> Property)) :+   []
+ src/Test/Sound/Synthesizer/Plain/Control.hs view
@@ -0,0 +1,112 @@+module Test.Sound.Synthesizer.Plain.Control (tests) where++import qualified Synthesizer.Plain.Control as Control++import Test.QuickCheck (test, Property, (==>))+import Test.Utility (equalList, approxEqualListAbs, approxEqualListRel, )++-- import qualified Algebra.Ring                  as Ring+-- import qualified Algebra.Additive              as Additive++import Data.List (transpose)++import NumericPrelude+import PreludeBase+import Prelude ()+++linearRing :: Int -> Int -> Bool+linearRing d y0 =+--   Control.linear d y0  ==  Control.linearMultiscale d y0+   all equalList $ take 100 $ transpose $+      Control.linear d y0 :+      Control.linearMultiscale d y0 :+      Control.linearStable d y0 :+      []++{-+*Synthesizer.Plain.Control> propLinearApprox (-2/3) 2+False++Need a different definition of approximate equality.+-}+linearApprox :: Double -> Double -> Bool+linearApprox d y0 =+   all (approxEqualListAbs (1e-10 * max (abs d) (abs y0))) $+   take 100 $ transpose $+      Control.linear d y0 :+      Control.linearMean d y0 :+      Control.linearMultiscale d y0 :+      Control.linearStable d y0 :+      []++linearExact :: Rational -> Rational -> Bool+linearExact d y0 =+   all equalList $ take 100 $ transpose $+      Control.linear d y0 :+      Control.linearMean d y0 :+      Control.linearMultiscale d y0 :+      Control.linearStable d y0 :+      []++{-+Plain.Control.exponential: Falsifiable, after 88 tests:+-8.333333333333326e-2+3.375++Plain.Control.exponential: Falsifiable, after 69 tests:+9.090909090909083e-2+-10.0++Plain.Control.exponential: Falsifiable, after 73 tests:+-0.125+-1.1428571428571428++Plain.Control.exponential2: Falsifiable, after 33 tests:+-7.692307692307687e-2+9.5+-}+exponential :: Double -> Double -> Bool+exponential time y0 =+   all (approxEqualListRel (1e-10)) $ take 100 $ transpose $+      Control.exponential time y0 :+      Control.exponentialMultiscale time y0 :+      Control.exponentialStable time y0 :+      []++exponential2 :: Double -> Double -> Bool+exponential2 time y0 =+   all (approxEqualListRel (1e-10)) $ take 100 $ transpose $+      Control.exponential2 time y0 :+      Control.exponential2Multiscale time y0 :+      Control.exponential2Stable time y0 :+      []++cosine :: Double -> Double -> Property+cosine t0 t1  =  t0/=t1 ==>+   all (approxEqualListAbs (1e-10)) $+   take 100 $ transpose $+      Control.cosine t0 t1 :+      Control.cosineMultiscale t0 t1 :+      Control.cosineStable t0 t1 :+      []+++cubic :: (Rational, (Rational, Rational)) ->+   (Rational, (Rational, Rational)) -> Property+cubic node0 node1  =  fst node0 /= fst node1 ==>+   take 100 (Control.cubicHermite node0 node1)  ==+   take 100 (Control.cubicHermiteStable node0 node1)++++tests :: [(String, IO ())]+tests =+   ("linearRing", test linearRing) :+   ("linearApprox", test linearApprox) :+   ("linearExact", test linearExact) :+   ("exponential", test exponential) :+   ("exponential2", test exponential2) :+   ("cosine", test cosine) :+   ("cubic", test cubic) :+   []
+ src/Test/Sound/Synthesizer/Plain/Filter.hs view
@@ -0,0 +1,38 @@+module Test.Sound.Synthesizer.Plain.Filter (tests) where++import qualified Synthesizer.Plain.Filter.Recursive.MovingAverage as MA+import qualified Synthesizer.Plain.Filter.NonRecursive as FiltNR+import qualified Synthesizer.Plain.Signal as Sig++import Test.QuickCheck (test, {- Property, (==>) -})+-- import Test.Utility (equalList, approxEqualListAbs, approxEqualListRel, )++-- import qualified Algebra.Module                as Module+-- import qualified Algebra.RealField             as RealField+-- import qualified Algebra.Ring                  as Ring+-- import qualified Algebra.Additive              as Additive++import qualified Number.NonNegative       as NonNeg++import NumericPrelude+import PreludeBase+import Prelude ()+++sums :: NonNeg.Int -> Rational -> Sig.T Rational -> Bool+sums nn x0 xs0 =+   let n = min (length xs) (1 + NonNeg.toNumber nn)+       xs = x0:xs0+       naive   =              FiltNR.sums        n xs+       pyramid =              FiltNR.sumsPyramid n xs+       rec     = drop (n-1) $ MA.sumsStaticInt   n xs+   in  -- this checks only for equal prefixes and can easily go wrong,+       -- if one list is empty+       and $ zipWith3 (\x y z -> x==y && y==z) naive rec pyramid+       -- equalList $ naive : pyramid : rec : []+++tests :: [(String, IO ())]+tests =+   ("sums", test sums) :+   []
+ src/Test/Sound/Synthesizer/Plain/Interpolation.hs view
@@ -0,0 +1,142 @@+module Test.Sound.Synthesizer.Plain.Interpolation (+   T, ip,+   LinePreserving, lpIp,+   tests,+   use, useLP, use2,+   ) where++import qualified Synthesizer.Plain.Interpolation as Interpolation+import qualified Synthesizer.Interpolation.Class as Interpol+import qualified Synthesizer.Interpolation.Custom as ExampleCustom+import qualified Synthesizer.Interpolation.Module as ExampleModule+import qualified Synthesizer.Interpolation as InterpolationCore++import Test.QuickCheck (test, Arbitrary(..), elements, {- Property, (==>), -} Testable, )+-- import Test.Utility++import qualified Algebra.VectorSpace           as VectorSpace+import qualified Algebra.Module                as Module+-- import qualified Algebra.RealField             as RealField+import qualified Algebra.Field                 as Field+-- import qualified Algebra.Ring                  as Ring+-- import qualified Algebra.Additive              as Additive++import Control.Monad (liftM2, )++import Test.Utility (equalList, )+++import NumericPrelude+import PreludeBase+import Prelude ()++++instance Arbitrary InterpolationCore.Margin where+   arbitrary =+      liftM2 InterpolationCore.Margin+         (fmap abs arbitrary)+         (fmap abs arbitrary)+   coarbitrary = undefined+++use ::+   (Interpolation.T a v -> x) ->+   (T a v -> x)+use f ipt =+   f (ip ipt)++useLP ::+   (Interpolation.T a v -> x) ->+   (LinePreserving a v -> x)+useLP f ipt =+   f (lpIp ipt)++use2 ::+   (Interpolation.T a v ->+    Interpolation.T a v -> x) ->+   (T a v ->+    T a v -> x)+use2 f =+   use $ \ ipLeap ->+   use $ \ ipStep ->+      f ipLeap ipStep++++data T a v = Cons {name :: String, ip :: Interpolation.T a v}++instance Show (T a v) where+   show x = name x++instance (Field.C a, Interpol.C a v) => Arbitrary (T a v) where+   arbitrary = elements $+      Cons "constant" ExampleCustom.constant :+      Cons "linear"   ExampleCustom.linear :+      Cons "cubic"    ExampleCustom.cubic :+      []+   coarbitrary = undefined++++data LinePreserving a v =+   LPCons {lpName :: String, lpIp :: Interpolation.T a v}++instance Show (LinePreserving a v) where+   show x = lpName x++instance (Field.C a, Interpol.C a v) => Arbitrary (LinePreserving a v) where+   arbitrary = elements $+      LPCons "linear"   ExampleCustom.linear :+      LPCons "cubic"    ExampleCustom.cubic :+      []+   coarbitrary = undefined++++constant ::+   (Interpol.C a v, Module.C a v, Eq v) =>+   a -> v -> [v] -> Bool+constant t x0 xs =+   equalList $ map ($(x0:xs)) $ map ($t) $+      Interpolation.func ExampleCustom.constant :+      Interpolation.func ExampleCustom.piecewiseConstant :+      Interpolation.func ExampleModule.constant :+      Interpolation.func ExampleModule.piecewiseConstant :+      []++linear ::+   (Interpol.C a v, Module.C a v, Eq v) =>+   a -> v -> v -> [v] -> Bool+linear t x0 x1 xs =+   equalList $ map ($(x0:x1:xs)) $ map ($t) $+      Interpolation.func ExampleCustom.linear :+      Interpolation.func ExampleCustom.piecewiseLinear :+      Interpolation.func ExampleModule.linear :+      Interpolation.func ExampleModule.piecewiseLinear :+      []++cubic ::+   (Interpol.C a v, VectorSpace.C a v, Eq v) =>+   a -> v -> v -> v -> v -> [v] -> Bool+cubic t x0 x1 x2 x3 xs =+   equalList $ map ($(x0:x1:x2:x3:xs)) $ map ($t) $+      Interpolation.func ExampleCustom.cubic :+      Interpolation.func ExampleCustom.piecewiseCubic :+      Interpolation.func ExampleModule.cubic :+      Interpolation.func ExampleModule.cubicAlt :+      Interpolation.func ExampleModule.piecewiseCubic :+      []+++testRational ::+   (Testable t) =>+   (Rational -> Rational -> t) -> IO ()+testRational = test++tests :: [(String, IO ())]+tests =+   ("constant", testRational constant) :+   ("linear",   testRational linear  ) :+   ("cubic",    testRational cubic   ) :+   []
+ src/Test/Sound/Synthesizer/Plain/Oscillator.hs view
@@ -0,0 +1,47 @@+module Test.Sound.Synthesizer.Plain.Oscillator (tests) where++import qualified Synthesizer.Plain.Oscillator as Osci+import qualified Synthesizer.Basic.Wave       as Wave+-- import qualified Synthesizer.Plain.Interpolation as Interpolation++import qualified Test.Sound.Synthesizer.Plain.Wave          as WaveTest+-- import qualified Test.Sound.Synthesizer.Plain.Interpolation as InterpolationTest++import Test.QuickCheck (test, {- Property, (==>), -} )+-- import Test.Utility++-- import qualified Number.NonNegative       as NonNeg++-- import qualified Algebra.RealTranscendental    as RealTrans+-- import qualified Algebra.Module                as Module+import qualified Algebra.RealField             as RealField+-- import qualified Algebra.Field                 as Field+-- import qualified Algebra.Ring                  as Ring+import qualified Algebra.Additive              as Additive+++import NumericPrelude+import PreludeBase+import Prelude ()++++phaseShapeMod :: (RealField.C a, Eq b) => (Wave.T a b) -> a -> [a] -> Bool+phaseShapeMod wave freq phases =+   Osci.phaseMod wave freq phases ==+   Osci.shapeMod (Wave.phaseOffset wave) zero freq phases++phaseShapeModRational ::+   WaveTest.Ring Rational -> Integer -> Integer -> [Integer] -> Bool+phaseShapeModRational w denom0 freq0 phases0 =+   let denom  = 1 + abs denom0+       freq   = freq0 % denom+       phases = map (% denom) phases0+   in  phaseShapeMod (WaveTest.ringWave w) freq phases++++tests :: [(String, IO ())]+tests =+   ("phaseShapeModRational",  test phaseShapeModRational) :+   []
+ src/Test/Sound/Synthesizer/Plain/ToneModulation.hs view
@@ -0,0 +1,504 @@+module Test.Sound.Synthesizer.Plain.ToneModulation (tests,+   listFromInfinite,+   InfiniteList,+   ) where++import Test.Sound.Synthesizer.Basic.ToneModulation (+   minLength,+   minLengthMargin,+   shapeLimits,+   testRationalLineIp,+   testRationalIp,+   )++import qualified Synthesizer.Plain.Oscillator     as Osci+import qualified Synthesizer.Plain.Interpolation  as Interpolation+import qualified Synthesizer.Plain.ToneModulation as ToneModL+import qualified Synthesizer.Plain.Wave           as WaveL+import Synthesizer.Interpolation (marginNumber, )++import qualified Synthesizer.Basic.Wave           as Wave+import qualified Synthesizer.Basic.Phase          as Phase++import qualified Test.Sound.Synthesizer.Plain.Interpolation as InterpolationTest++import Test.QuickCheck (test, Property, (==>), Arbitrary, arbitrary, coarbitrary, )+import Test.Utility (ArbChar, )++import qualified Number.NonNegative       as NonNeg+import qualified Number.NonNegativeChunky as Chunky++import qualified Algebra.RealTranscendental    as RealTrans+import qualified Algebra.Module                as Module+import qualified Algebra.RealField             as RealField+import qualified Algebra.Field                 as Field+import qualified Algebra.Ring                  as Ring+import qualified Algebra.Additive              as Additive++import Control.Monad (liftM2, )+import Data.List.HT (isAscending, )+import Data.Ord.HT (limit, )+import Data.Tuple.HT (mapPair, mapSnd, )+import qualified Data.List as List+++import NumericPrelude+import PreludeBase+import Prelude ()+++{-+Properties that do not hold:+  commutativity of limitRelativeShapes and integrateFractional:+    Does not hold because when you clip the integral skips at the end,+    you would have to clear the fractional part, too.+-}++++data InfiniteList a =+   InfiniteList a [a]++listFromInfinite :: InfiniteList a -> [a]+listFromInfinite (InfiniteList x xs) =+   cycle (x:xs)++instance Functor InfiniteList where+   fmap f (InfiniteList x xs) =+      InfiniteList (f x) (map f xs)++instance Arbitrary a => Arbitrary (InfiniteList a) where+   arbitrary = liftM2 InfiniteList arbitrary arbitrary+   coarbitrary = undefined++instance Show a => Show (InfiniteList a) where+   showsPrec p (InfiniteList x xs) =+      showParen (p >= 10) $+      showString "cycle " .+      showsPrec 11 (x:xs)++++absolutize :: (Additive.C a) => a -> [a] -> [a]+absolutize = scanl (+)++limitMinRelativeValues ::+   Int -> Int -> [NonNeg.Int] -> Bool+limitMinRelativeValues xMin x0 xsnn =+   let xs = map NonNeg.toNumber xsnn+   in  map (max xMin) (absolutize x0 xs) ==+          uncurry absolutize (ToneModL.limitMinRelativeValues xMin x0 xs)++limitMaxRelativeValues ::+   Int -> Int -> [NonNeg.Int] -> Bool+limitMaxRelativeValues xMax x0 xsnn =+   let xs = map NonNeg.toNumber xsnn+   in  map (min xMax) (absolutize x0 xs) ==+          uncurry absolutize (ToneModL.limitMaxRelativeValues xMax x0 xs)++limitMaxRelativeValuesNonNeg ::+   Int -> Int -> [NonNeg.Int] -> Bool+limitMaxRelativeValuesNonNeg xMax x0 xsnn =+   let xs = map NonNeg.toNumber xsnn+   in  map (min xMax) (absolutize x0 xs) ==+          uncurry absolutize (ToneModL.limitMaxRelativeValuesNonNeg xMax x0 xs)++-- chunky type is not necessary here but testing it a little is not wrong+limitMinRelativeValuesIdentity ::+   Chunky.T NonNeg.Int -> [Chunky.T NonNeg.Int] -> Bool+limitMinRelativeValuesIdentity x0 xs =+   (x0,xs) == ToneModL.limitMinRelativeValues 0 x0 xs++limitMaxRelativeValuesIdentity ::+   Chunky.T NonNeg.Int -> [Chunky.T NonNeg.Int] -> Bool+limitMaxRelativeValuesIdentity x0 xs =+   let inf = 1 + inf+   in  (x0,xs) == ToneModL.limitMaxRelativeValues inf x0 xs++limitMaxRelativeValuesNonNegIdentity ::+   Chunky.T NonNeg.Int -> [Chunky.T NonNeg.Int] -> Bool+limitMaxRelativeValuesNonNegIdentity x0 xs =+   let inf = 1 + inf+   in  (x0,xs) == ToneModL.limitMaxRelativeValuesNonNeg inf x0 xs++limitMaxRelativeValuesInfinity ::+   Chunky.T NonNeg.Int -> InfiniteList (Chunky.T NonNeg.Int) -> Bool+limitMaxRelativeValuesInfinity x0 ixs =+   let inf = 1 + inf+       ys = listFromInfinite ixs+       (z0,zs) = ToneModL.limitMaxRelativeValues inf x0 ys+   in  (x0, take 100 ys) == (z0, take 100 zs)++limitMaxRelativeValuesNonNegInfinity ::+   Chunky.T NonNeg.Int -> InfiniteList (Chunky.T NonNeg.Int) -> Bool+limitMaxRelativeValuesNonNegInfinity x0 ixs =+   let inf = 1 + inf+       ys = listFromInfinite ixs+       (z0,zs) = ToneModL.limitMaxRelativeValuesNonNeg inf x0 ys+   in  (x0, take 100 ys) == (z0, take 100 zs)+++dropRem :: Eq a => NonNeg.Int -> [a] -> Bool+dropRem nn xs =+   let n = NonNeg.toNumber nn+   in  map (flip ToneModL.dropRem xs) [0 .. n + length xs] ==+       map ((,) 0) (List.tails xs) ++ map (flip (,) []) [1..n]+++sampledToneSine :: (RealTrans.C a, Module.C a a) =>+   NonNeg.T a -> NonNeg.Int -> a -> a -> a -> Bool+sampledToneSine periodNN ext phase0 shape phase =+   let ipLeap = Interpolation.cubic+       ipStep = Interpolation.cubic+       ten = fromInteger 10+       period = ten + NonNeg.toNumber periodNN+       periodInt = round period+       len = minLength ipLeap ipStep periodInt ext+       tone = take len (Osci.staticSine phase0 (recip period))+   in  abs (WaveL.sampledTone ipLeap ipStep period tone shape `Wave.apply` (Phase.fromRepresentative phase) -+            head (Osci.staticSine (phase0+phase) zero)) < ten ^- (-2)+++sampledToneSineList :: (RealTrans.C a, Module.C a a) =>+   NonNeg.T a -> NonNeg.Int -> a -> a -> [a] -> [a] -> Bool+sampledToneSineList periodNN ext origPhase phase shapes freqs =+   let ipLeap = Interpolation.cubic+       ipStep = Interpolation.cubic+       ten = fromInteger 10+       period = ten + NonNeg.toNumber periodNN+       periodInt = round period+       len = minLength ipLeap ipStep periodInt ext+       tone = take len (Osci.staticSine origPhase (recip period))+   in  all ((< ten ^- (-2)) . abs) $+       zipWith (-)+          (Osci.shapeFreqMod (WaveL.sampledTone ipLeap ipStep period tone)+               phase shapes freqs)+          (Osci.freqModSine (origPhase+phase) freqs)+++sampledToneLinear :: (RealField.C a, Module.C a v, Eq v) =>+   InterpolationTest.LinePreserving a v ->+   InterpolationTest.LinePreserving a v ->+   NonNeg.T a -> NonNeg.Int -> (v,v) -> a -> Phase.T a -> Property+sampledToneLinear =+   InterpolationTest.useLP $ \ ipLeap ->+   InterpolationTest.useLP $ \ ipStep ->+         \ periodNN ext (i,d) shape phase ->+   let period = NonNeg.toNumber periodNN+       periodInt = round period+       len = minLength ipLeap ipStep periodInt ext+       ramp = take len (List.iterate (d+) i)+       limits =+          mapPair (fromIntegral, fromIntegral) $+             shapeLimits ipLeap ipStep periodInt len+   in  period /= zero ==>+          -- should be (fraction phase), right?+          WaveL.sampledTone ipLeap ipStep period ramp shape `Wave.apply` phase ==+             i + limit limits shape *> d+{-+let len=100; period=1/0.06::Double; ip = Interpolation.linear in GNUPlot.plotFuncs [] (GNUPlot.linearScale 1000 (0,fromIntegral len)) [\s -> WaveL.sampledTone ip ip period (take len $ iterate (1+) (0::Double)) s 0, limit (mapPair (fromIntegral, fromIntegral) $ shapeLimits ip ip (round period::Int) len)]+-}++sampledToneStair :: (RealField.C a, Module.C a v, Eq v) =>+   InterpolationTest.LinePreserving a v ->+   NonNeg.Int -> NonNeg.Int -> (v,v) -> a -> Property+sampledToneStair =+   InterpolationTest.useLP $ \ ipLeap+         periodIntNN ext (i,d) shape ->+   let ipStep = Interpolation.constant+       periodInt = NonNeg.toNumber periodIntNN+       period    = fromIntegral periodInt+       len0 = minLength ipLeap ipStep periodInt ext+       (rep,rm) = divMod (negate len0) periodInt+       len   = len0 + rm+       stair =+          concatMap (replicate periodInt) $+          take (negate rep) (List.iterate (period*>d+) i)+       limits =+          mapPair (fromIntegral, fromIntegral) $+             shapeLimits ipLeap ipStep periodInt len+   in  periodInt /= zero ==>+          WaveL.sampledTone ipLeap ipStep period stair shape `Wave.apply` zero ==+             i + limit limits shape *> d+{-+let len=periodInt*rep; rep=10; periodInt = 14::Int; period=fromIntegral periodInt; ipl = Interpolation.linear; ipc = Interpolation.constant in GNUPlot.plotFuncs [] (GNUPlot.linearScale 1000 (-10,10+fromIntegral len)) [\s -> WaveL.sampledTone ipl ipc period (concatMap (replicate periodInt) $ take rep $ iterate (period+) (0::Double)) s 0, limit (mapPair (fromIntegral, fromIntegral) $ shapeLimits ipl ipc periodInt len)]+-}++{-+sampledToneSaw :: (RealField.C a, Module.C a v, Eq v) =>+   InterpolationTest.LinePreserving a v ->+   InterpolationTest.T a v ->+   NonNeg.Int -> NonNeg.Int -> (v,v) -> a -> a -> Property+sampledToneSaw iptLeap iptStep periodIntNN ext (i,d) shape phase =+   let ipLeap = InterpolationTest.lpIp iptLeap+       ipStep = InterpolationTest.ip   iptStep+       periodInt = NonNeg.toNumber periodIntNN+       period    = fromIntegral periodInt+       len0 = minLength ipLeap ipStep periodInt ext+       rep = negate $ div (negate len0) periodInt+       saw =+          concat $ replicate rep $+          take periodInt $ List.iterate (d+) i+   in  periodInt /= zero ==>+          WaveL.sampledTone ipLeap ipStep period saw shape phase ==+             i + fraction phase *> d+-}++sampledToneStatic :: (RealField.C a, Eq v) =>+   InterpolationTest.T a v ->+   InterpolationTest.T a v ->+   NonNeg.Int -> (v,[v]) -> a -> a -> Property+sampledToneStatic =+   InterpolationTest.use2 $ \ ipLeap ipStep+         ext (x,xs) shape phase ->+   let wave = x:xs+       periodInt = length wave+       period    = fromIntegral periodInt+       len = minLength ipLeap ipStep periodInt ext+       rep = negate $ div (negate len) periodInt+       tone = concat $ replicate rep wave+   in  period /= zero ==>+          WaveL.sampledTone ipLeap ipStep period tone shape `Wave.apply` (Phase.fromRepresentative phase) ==+          Interpolation.cyclicPad Interpolation.single ipStep (phase*period) wave+{-+let wave = [1,-1,0.5,-0.5::Double]; period = fromIntegral (length wave) :: Double; ip = Interpolation.linear in GNUPlot.plotFuncs [] (GNUPlot.linearScale 1000 (-1,3)) [WaveL.sampledTone ip ip period (concat $ replicate 3 wave) 0.3, \phase -> Interpolation.cyclicPad Interpolation.single Interpolation.linear (phase*period) wave]+-}++++shapeFreqModFromSampledToneLimitIdentity :: (RealField.C t) =>+   Interpolation.Margin ->+   Interpolation.Margin ->+   NonNeg.Int -> InfiniteList y -> (t, InfiniteList (NonNeg.T t)) -> Bool+shapeFreqModFromSampledToneLimitIdentity+      marginLeap marginStep periodIntNN ixs (shape0,shapesNN) =+   let periodInt = NonNeg.toNumber periodIntNN+       shapes = fmap NonNeg.toNumber shapesNN+       a = snd+          (ToneModL.limitRelativeShapes+             marginLeap marginStep+             periodInt (listFromInfinite ixs)+             (shape0, listFromInfinite shapes)) !! 100+   in  a == a+++oscillatorCoords :: (RealField.C t) =>+   NonNeg.Int -> NonNeg.T t -> t -> Phase.T t -> [NonNeg.T t] -> [t] -> Property+oscillatorCoords+     periodIntNN periodNN shape0 phase shapesNN freqs =+   let shapes = map NonNeg.toNumber shapesNN+       period    = NonNeg.toNumber periodNN+       periodInt = NonNeg.toNumber periodIntNN+       periodRound = fromIntegral periodInt+       coords =+          ToneModL.oscillatorCoords+             periodInt period+             (shape0, shapes) (phase, freqs)+   in  period /= zero  &&  periodInt /= zero  ==>+          all+             (\(skip,(k,(qShape,qWave))) ->+                  skip >= zero &&+                  isAscending [negate periodInt, k, zero] &&+                  isAscending [zero, qShape, one] &&+                  isAscending [zero, qWave, periodRound])+             (tail coords)+++shapeFreqModFromSampledToneCoordsIdentity :: (RealField.C t) =>+   NonNeg.Int -> NonNeg.T t -> (t, [NonNeg.T t]) -> Property+shapeFreqModFromSampledToneCoordsIdentity+      periodIntNN periodNN (shape0,shapesNN) =+   let period    = NonNeg.toNumber periodNN+       periodInt = NonNeg.toNumber periodIntNN+       shapes = map NonNeg.toNumber shapesNN+       phase  = Phase.fromRepresentative $ shape0 / period+       freqs  = map (/period) shapes+   in  period /= zero  ==>+          all+             (isZero . fst . snd . snd)+             (ToneModL.oscillatorCoords+                 periodInt period (shape0, shapes) (phase, freqs))+++shapeFreqModFromSampledTone :: (RealField.C t, Eq v) =>+   InterpolationTest.T t v ->+   InterpolationTest.T t v ->+   NonNeg.T t ->+   NonNeg.Int -> InfiniteList v ->+   t -> t -> [NonNeg.T t] -> [t] ->+   Property+shapeFreqModFromSampledTone =+   InterpolationTest.use2 $ \ ipLeap ipStep+         periodNN ext ixs shape0 phase shapesNN freqs ->+   let shapes = map NonNeg.toNumber shapesNN+       period = NonNeg.toNumber periodNN+       periodInt = round period+       len = minLength ipLeap ipStep periodInt ext+       tone = take len (listFromInfinite ixs)+       resampledToneA =+          Osci.shapeFreqModFromSampledTone ipLeap ipStep period tone+             shape0 phase shapes freqs+       resampledToneB =+          Osci.shapeFreqMod+             (WaveL.sampledTone ipLeap ipStep period tone)+             phase (scanl (+) shape0 shapes) freqs+   in  period /= zero  ==>+          resampledToneA == resampledToneB+{-+let len=100; period=1/0.06::Double; ip = Interpolation.linear; tone = take len $ iterate (1+) (0::Double); shape0=0; shapes = replicate 100 1; in GNUPlot.plotLists [] [Osci.shapeFreqMod (WaveL.sampledTone ip ip period tone) 0 (scanl (+) shape0 shapes) (repeat 0), Osci.shapeFreqModFromSampledTone ip ip period tone shape0 0 shapes (repeat 0)]+*Test.Sound.Synthesizer.Plain.Oscillator> let len=100; period=1/0.06::Double; ip = Interpolation.linear; tone = take len $ iterate (1+) (0::Double); shape0=0; shapes = concat $ replicate 50 [1.5,0.5]; in GNUPlot.plotLists [] [Osci.shapeFreqMod (WaveL.sampledTone ip ip period tone) 0 (scanl (+) shape0 shapes) (repeat 0), Osci.shapeFreqModFromSampledTone ip ip period tone shape0 0 shapes (repeat 0)]+*Test.Sound.Synthesizer.Plain.Oscillator> let len=100; period=1/0.06::Rational; ipLeap = Interpolation.linear; ipStep = Interpolation.constant; tone = take len $ iterate (1+) (0::Rational); shape0=0; shapes = concat $ replicate 50 [1.5,0.5]; in GNUPlot.plotLists [] (map (map (\x -> fromRational' x :: Double)) [Osci.shapeFreqMod (WaveL.sampledTone ipLeap ipStep period tone) 0 (scanl (+) shape0 shapes) (repeat 0), Osci.shapeFreqModFromSampledTone ipLeap ipStep period tone shape0 0 shapes (repeat 0)])+-}+++shapePhaseFreqModFromSampledTone :: (RealField.C t, Eq v) =>+   InterpolationTest.T t v ->+   InterpolationTest.T t v ->+   NonNeg.T t ->+   NonNeg.Int -> InfiniteList v ->+   t -> t -> [NonNeg.T t] -> [t] -> [t] ->+   Property+shapePhaseFreqModFromSampledTone =+   InterpolationTest.use2 $ \ ipLeap ipStep+         periodNN ext ixs shape0 phase shapesNN phaseDistorts freqs ->+   let shapes = map NonNeg.toNumber shapesNN+       period = NonNeg.toNumber periodNN+       periodInt = round period+       len = minLength ipLeap ipStep periodInt ext+       tone = take len (listFromInfinite ixs)+       resampledToneA =+          Osci.shapePhaseFreqModFromSampledTone ipLeap ipStep period tone+             shape0 phase shapes phaseDistorts freqs+       resampledToneB =+          Osci.shapeFreqMod+             (uncurry $+                Wave.phaseOffset .+                WaveL.sampledTone ipLeap ipStep period tone)+             phase (zip (scanl (+) shape0 shapes) phaseDistorts) freqs+   in  period /= zero  ==>+          resampledToneA == resampledToneB+++oscillatorCells :: (RealField.C t, Eq v) =>+   Interpolation.Margin ->+   Interpolation.Margin ->+   NonNeg.Int ->+   NonNeg.T t ->+   NonNeg.Int -> InfiniteList v ->+   t -> t -> [NonNeg.T t] -> [t] ->+   Property+oscillatorCells+      marginLeap marginStep periodIntNN periodNN ext ixs shape0 phase shapesNN freqs =+   let shapes = map NonNeg.toNumber shapesNN+       period    = NonNeg.toNumber periodNN+       periodInt = NonNeg.toNumber periodIntNN+       len = minLengthMargin marginLeap marginStep periodInt ext+       tone = take len (listFromInfinite ixs)+       crop = cropCell marginLeap marginStep+       resampledToneA =+          ToneModL.oscillatorCells+             marginLeap marginStep periodInt period tone+             (shape0, shapes) (Phase.fromRepresentative phase, freqs)+       resampledToneB =+          Osci.shapeFreqMod+             (Wave.Cons . ToneModL.sampledToneCell+                (ToneModL.makePrototype marginLeap marginStep+                    periodInt period tone))+             phase (scanl (+) shape0 shapes) freqs+   in  period /= zero  &&+       periodInt /= zero  &&+       marginNumber marginLeap > zero &&+       marginNumber marginStep > zero  ==>+          map crop resampledToneA == map crop resampledToneB++cropCell ::+   Interpolation.Margin ->+   Interpolation.Margin ->+   ((t,t), ToneModL.Cell v) -> ((t,t), ToneModL.Cell v)+cropCell ipLeap ipStep =+   mapSnd+      (take (marginNumber ipStep) .+       map (take (marginNumber ipLeap)))+++shapeFreqModFromSampledToneIdentity :: (RealField.C t, Eq v) =>+   InterpolationTest.T t v ->+   InterpolationTest.T t v ->+   NonNeg.T t ->+   NonNeg.Int -> InfiniteList v ->+   Property+shapeFreqModFromSampledToneIdentity =+   InterpolationTest.use2 $ \ ipLeap ipStep+          periodNN ext ixs ->+   let period = NonNeg.toNumber periodNN+       periodInt = round period+       len = minLength ipLeap ipStep periodInt ext+       tone = take len (listFromInfinite ixs)+       shape0 = zero+       shapes = repeat one+       phase  = zero+       freqs  = repeat (recip period)+       (n0,n1) =+          shapeLimits ipLeap ipStep periodInt len++       resampledTone =+          Osci.shapeFreqModFromSampledTone ipLeap ipStep period tone+             shape0 phase shapes freqs+   in  period /= zero  ==>+          and (drop n0 (take (succ n1) (zipWith (==) resampledTone tone)))+++tests :: [(String, IO ())]+tests =+   ("limitMinRelativeValues", test limitMinRelativeValues) :+   ("limitMaxRelativeValues", test limitMaxRelativeValues) :+   ("limitMaxRelativeValuesNonNeg",+                              test limitMaxRelativeValuesNonNeg) :+   ("limitMinRelativeValuesIdentity",+                              test limitMinRelativeValuesIdentity) :+   ("limitMaxRelativeValuesIdentity",+                              test limitMaxRelativeValuesIdentity) :+   ("limitMaxRelativeValuesNonNegIdentity",+                              test limitMaxRelativeValuesNonNegIdentity) :+   ("limitMaxRelativeValuesInfinity",+                              test limitMaxRelativeValuesInfinity) :+   ("limitMaxRelativeValuesNonNegInfinity",+                              test limitMaxRelativeValuesNonNegInfinity) :+   ("dropRem",                test (dropRem :: NonNeg.Int -> [ArbChar] -> Bool)) :+   ("sampledToneSine",+      test (\period -> sampledToneSine (period :: NonNeg.Double))) :+   ("sampledToneSineList",+      test (\period -> sampledToneSineList (period :: NonNeg.Double))) :+   ("sampledToneLinear",+      testRationalLineIp sampledToneLinear) :+   ("sampledToneStair",+      testRationalLineIp sampledToneStair) :+{-+   ("sampledToneSaw",+      testRationalLineIp sampledToneSaw) :+-}+   ("sampledToneStatic",+      testRationalIp sampledToneStatic) :+   ("shapeFreqModFromSampledToneLimitIdentity",+      test (\ml ms p ixs (t,ts) ->+          shapeFreqModFromSampledToneLimitIdentity ml ms p+             (ixs::InfiniteList Rational) (t::Rational,ts))) :+   ("oscillatorCoords",+      test (\periodInt period ->+               oscillatorCoords+                  periodInt (period :: NonNeg.Rational))) :+   ("shapeFreqModFromSampledToneCoordsIdentity",+      test (\periodInt period ->+               shapeFreqModFromSampledToneCoordsIdentity+                  periodInt (period :: NonNeg.Rational))) :+   ("shapeFreqModFromSampledTone",+      testRationalIp shapeFreqModFromSampledTone) :+   ("shapePhaseFreqModFromSampledTone",+      testRationalIp shapePhaseFreqModFromSampledTone) :+   ("oscillatorCells",+      test (\ml ms periodInt period ext ixs ->+               oscillatorCells ml ms periodInt (period :: NonNeg.Rational)+                  ext (ixs :: InfiniteList ArbChar))) :+   ("shapeFreqModFromSampledToneIdentity",+      testRationalIp shapeFreqModFromSampledToneIdentity) :+   []
+ src/Test/Sound/Synthesizer/Plain/Wave.hs view
@@ -0,0 +1,81 @@+module Test.Sound.Synthesizer.Plain.Wave (Ring, ringWave, tests) where++import qualified Synthesizer.Basic.Wave       as Wave+import qualified Synthesizer.Basic.Phase      as Phase++import Test.QuickCheck (test, Arbitrary(..), elements, oneof, choose, {- Property, (==>), -} )+-- import Test.Utility++import qualified Number.NonNegative       as NonNeg++import qualified Algebra.RealTranscendental    as RealTrans+-- import qualified Algebra.Module                as Module+-- import qualified Algebra.RealField             as RealField+-- import qualified Algebra.Field                 as Field+import qualified Algebra.Ring                  as Ring+import qualified Algebra.Additive              as Additive++import Control.Monad (liftM, liftM2, )+import System.Random (Random)+++import NumericPrelude+import PreludeBase+import Prelude ()+++++data Ring a = Ring {ringName :: String, ringWave :: Wave.T a a}++instance Show (Ring a) where+   show = ringName++instance (Ord a, Ring.C a) => Arbitrary (Ring a) where+   arbitrary = elements $+      Ring "saw"      Wave.saw :+      Ring "square"   Wave.square :+      Ring "triangle" Wave.triangle :+      []+   coarbitrary = undefined+++++data ZeroDCOffset a = ZeroDCOffset {zdcName :: String, zdcWave :: Wave.T a a}++instance Show (ZeroDCOffset a) where+   show = zdcName++instance (RealTrans.C a, Random a) => Arbitrary (ZeroDCOffset a) where+   arbitrary =+      let cons n w = return (ZeroDCOffset n w)+      in  oneof $+            cons "sine"     Wave.sine :+            cons "saw"      Wave.saw :+            cons "square"   Wave.square :+            cons "triangle" Wave.triangle :+            liftM+               (ZeroDCOffset "squareBalanced" . Wave.squareBalanced)+               (choose (negate one, one)) :+            liftM2+               (\w r -> ZeroDCOffset "trapezoidBalanced" (Wave.trapezoidBalanced w r))+               (choose (zero, one))+               (choose (negate one, one)) :+            []+   coarbitrary = undefined+++zeroDCOffset :: ZeroDCOffset Double -> NonNeg.Int -> Bool+zeroDCOffset w periodIntNN =+   let periodInt = 100 + NonNeg.toNumber periodIntNN+       period    = fromIntegral periodInt+       xs = take periodInt $ map Phase.fromRepresentative $+            map (/period) $ iterate (1+) 0.5+   in  abs (sum (map (Wave.apply (zdcWave w)) xs))  <  period / fromInteger 100+++tests :: [(String, IO ())]+tests =+   ("zeroDCOffset",  test zeroDCOffset) :+   []
+ src/Test/Utility.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE NoImplicitPrelude #-}+module Test.Utility where++import Test.QuickCheck (Arbitrary(..))++import qualified Algebra.Real                  as Real+import qualified Algebra.Ring                  as Ring++import qualified Data.Char as Char++import PreludeBase+import NumericPrelude+++equalList :: Eq a => [a] -> Bool+equalList xs =+   -- 'drop 1' instead of 'take' for suppression of error+   and (zipWith (==) xs (drop 1 xs))+++approxEqual :: (Real.C a) => a -> a -> a -> Bool+approxEqual eps x y =+   2 * abs (x-y) <= eps * (abs x + abs y)++approxEqualListRel :: (Real.C a) => a -> [a] -> Bool+approxEqualListRel eps xs =+   let n = fromIntegral $ length xs+   in  approxEqualListAbs (eps * n * sum (map abs xs)) xs++approxEqualListAbs :: (Real.C a) => a -> [a] -> Bool+approxEqualListAbs eps xs =+   let n = fromIntegral $ length xs+       s = sum xs+   in  sum (map (\x -> abs (n*x-s)) xs)  <=  eps+++-- see event-list++newtype ArbChar = ArbChar Char+   deriving (Eq, Ord)++instance Show ArbChar where+   showsPrec n (ArbChar c) = showsPrec n c++instance Arbitrary ArbChar where+   arbitrary = fmap (ArbChar . Char.chr . (32+) . flip mod 96) arbitrary+   coarbitrary = undefined
+ synthesizer-core.cabal view
@@ -0,0 +1,295 @@+Name:           synthesizer-core+Version:        0.2+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+Synopsis:       Audio signal processing coded in Haskell: Low level part+Description:+   Low level audio signal processing+   used by the other synthesizer packages.+   The routines can be really fast+   due to StorableVector, Stream-like list type and aggressive inlining.+   For an interface to Haskore see <http://darcs.haskell.org/haskore-synthesizer/>.+   For introductory examples see "Synthesizer.Plain.Tutorial"+   and "Synthesizer.Generic.Tutorial".+-- the Overview module does not really fit into one of the part packages+--   For an overview of the organization of the package+--   and the discussion of various design issues see "Synthesizer.Overview".+Stability:      Experimental+Tested-With:    GHC==6.4.1, GHC==6.8.2+Cabal-Version:  >=1.6+Build-Type:     Simple++Extra-Source-Files:+  Makefile+  src-3/Synthesizer/Causal/Process.hs+  src-4/Synthesizer/Causal/Process.hs+  src-4/Synthesizer/Inference/DesignStudy/Applicative.hs+  src-4/Synthesizer/Inference/DesignStudy/Monad.hs+  src-4/Synthesizer/Inference/DesignStudy/Arrow.hs++Flag splitBase+  description: Choose the new smaller, split-up base package.++Flag category+  description: Check whether Arrow class is split into Arrow and Category.++Flag optimizeAdvanced+  description: Enable advanced optimizations. They slow down compilation considerably.+  default:     True++Flag buildProfilers+  description: Build executables for investigating efficiency of code+  default:     False++Flag buildTests+  description: Build test suite+  default:     False+++Source-Repository this+  Tag:         0.2+  Type:        darcs+  Location:    http://code.haskell.org/synthesizer/core/++Source-Repository head+  Type:        darcs+  Location:    http://code.haskell.org/synthesizer/core/++Library+  Build-Depends:+    transformers >=0.0.1 && <0.2,+    event-list >=0.0.8 && <0.1,+    non-negative >=0.0.5 && <0.1,+    numeric-prelude >=0.1.1 && <0.2,+    numeric-quest >= 0.1 && <0.2,+    utility-ht >=0.0.5 && <0.1,+    sox >=0.0 && <0.1,+    filepath >=1.1 && <1.2,+    bytestring >= 0.9 && <0.10,+    binary >=0.1 && <1,+    storablevector >=0.2.3 && <0.3,+    storable-record >=0.0.1 && <0.1,+    QuickCheck >=1 && <2++  If flag(splitBase)+    If flag(category)+      Hs-Source-Dirs: src-4+      Build-Depends: base >= 4 && <5+    Else+      Hs-Source-Dirs: src-3+      Build-Depends: base >= 3 && <4+    Build-Depends:+      array >=0.1 && <0.3,+      containers >=0.1 && <0.3,+      random >=1.0 && <2.0,+      process >=1.0 && <1.1+  Else+    Hs-Source-Dirs: src-3+    Build-Depends:+      base >= 1.0 && < 2,+      special-functors >= 1.0 && <1.1++  GHC-Options:    -Wall+  Hs-source-dirs: src+  Exposed-modules:+    Synthesizer.Storage++    Synthesizer.ApplicativeUtility+    Synthesizer.Format+    Synthesizer.RandomKnuth+    Synthesizer.Piecewise+    Synthesizer.Basic.Binary+    Synthesizer.Basic.Distortion+    Synthesizer.Basic.DistortionControlled+    Synthesizer.Basic.Phase+    Synthesizer.Basic.ToneModulation+    Synthesizer.Basic.Wave+    Synthesizer.Basic.WaveSmoothed+    Synthesizer.Interpolation+    Synthesizer.Interpolation.Class+    Synthesizer.Interpolation.Module+    Synthesizer.Interpolation.Custom+    Synthesizer.Frame.Stereo+    Synthesizer.Plain.Signal+    Synthesizer.Plain.Analysis+    Synthesizer.Plain.Cut+    Synthesizer.Plain.Control+    Synthesizer.Plain.Displacement+    Synthesizer.Plain.Filter.NonRecursive+    Synthesizer.Plain.Filter.Recursive+    Synthesizer.Plain.Filter.Recursive.Allpass+    Synthesizer.Plain.Filter.Recursive.AllpassPoly+    Synthesizer.Plain.Filter.Recursive.Butterworth+    Synthesizer.Plain.Filter.Recursive.Chebyshev+    Synthesizer.Plain.Filter.Recursive.Comb+    Synthesizer.Plain.Filter.Recursive.FirstOrder+    Synthesizer.Plain.Filter.Recursive.FirstOrderComplex+    Synthesizer.Plain.Filter.Recursive.Integration+    Synthesizer.Plain.Filter.Recursive.Moog+    Synthesizer.Plain.Filter.Recursive.MovingAverage+    Synthesizer.Plain.Filter.Recursive.SecondOrder+    Synthesizer.Plain.Filter.Recursive.SecondOrderCascade+    Synthesizer.Plain.Filter.Recursive.Universal+    Synthesizer.Plain.Filter.Recursive.Test+    Synthesizer.Plain.Filter.Delay+    Synthesizer.Plain.Filter.Delay.ST+    Synthesizer.Plain.Filter.Delay.List+    Synthesizer.Plain.Filter.Delay.Block+    Synthesizer.Plain.Filter.LinearPredictive+    Synthesizer.Plain.Interpolation+    Synthesizer.Plain.LorenzAttractor+    Synthesizer.Plain.Modifier+    Synthesizer.Plain.Noise+    Synthesizer.Plain.Oscillator+    Synthesizer.Plain.ToneModulation+    Synthesizer.Plain.Wave+    Synthesizer.Plain.Miscellaneous+    Synthesizer.Plain.Instrument+    Synthesizer.Plain.Effect+    Synthesizer.Plain.Effect.Fly+    Synthesizer.Plain.Effect.Glass+    Synthesizer.Plain.Builder+    Synthesizer.Plain.IO+    Synthesizer.Plain.File+    Synthesizer.Plain.Play+    Synthesizer.FusionList.Control+    Synthesizer.FusionList.Filter.NonRecursive+    Synthesizer.FusionList.Oscillator+    Synthesizer.FusionList.Signal+    Synthesizer.Storable.Cut+    Synthesizer.Storable.Oscillator+    Synthesizer.Storable.Signal+    Synthesizer.State.Analysis+    Synthesizer.State.Control+    Synthesizer.State.Cut+    Synthesizer.State.Displacement+    Synthesizer.State.Filter.NonRecursive+    Synthesizer.State.Filter.Delay+    Synthesizer.State.Filter.Recursive.Comb+    Synthesizer.State.Filter.Recursive.Integration+    Synthesizer.State.Filter.Recursive.MovingAverage+    Synthesizer.State.Interpolation+    Synthesizer.State.Miscellaneous+    Synthesizer.State.Noise+    Synthesizer.State.NoiseCustom+    Synthesizer.State.Oscillator+    Synthesizer.State.Signal+    Synthesizer.State.ToneModulation+    Synthesizer.Causal.Process+    Synthesizer.Causal.Displacement+    Synthesizer.Causal.Interpolation+    Synthesizer.Causal.Oscillator+    Synthesizer.Causal.ToneModulation+    Synthesizer.Generic.Analysis+    Synthesizer.Generic.Cut+    Synthesizer.Generic.Control+    Synthesizer.Generic.Displacement+    Synthesizer.Generic.Filter.NonRecursive+    Synthesizer.Generic.Filter.Delay+    Synthesizer.Generic.Filter.Recursive.Integration+    Synthesizer.Generic.Filter.Recursive.MovingAverage+    Synthesizer.Generic.Filter.Recursive.Comb+    Synthesizer.Generic.Interpolation+    Synthesizer.Generic.Noise+    Synthesizer.Generic.Oscillator+    Synthesizer.Generic.Signal+    Synthesizer.Generic.Signal2+    Synthesizer.Generic.Wave++    -- that's only exposed for Haddock+    Synthesizer.Plain.Tutorial+    Synthesizer.Generic.Tutorial++    -- synthesizer.dimensional:Synthesizer.Dimensional.Causal.Filter import affineComb+    Synthesizer.Utility++  Other-Modules:+    Synthesizer.Filter.Basic+    Synthesizer.Filter.Composition+    Synthesizer.Filter.Example+    Synthesizer.Filter.Fix+    Synthesizer.Filter.Graph+    Synthesizer.Filter.Graphic+    Synthesizer.Filter.MonadFix+    Synthesizer.Filter.OneWay+    Synthesizer.Filter.TwoWay+++Executable test+  If !flag(buildTests)+    Buildable: False+  GHC-Options: -Wall+  Hs-Source-Dirs: src+  If flag(category)+    Hs-Source-Dirs: src-4+  Else+    Hs-Source-Dirs: src-3+  Other-Modules:+    Test.Utility+    Test.Sound.Synthesizer.Plain.Analysis+    Test.Sound.Synthesizer.Plain.Control+    Test.Sound.Synthesizer.Plain.Filter+    Test.Sound.Synthesizer.Plain.Interpolation+    Test.Sound.Synthesizer.Plain.Oscillator+    Test.Sound.Synthesizer.Plain.ToneModulation+    Test.Sound.Synthesizer.Plain.Wave+    Test.Sound.Synthesizer.Basic.ToneModulation+    Test.Sound.Synthesizer.Generic.ToneModulation+  Main-Is: Test/Main.hs++Executable fusiontest+  If !flag(buildProfilers)+    Buildable: False+  GHC-Options: -Wall -fexcess-precision+  If flag(optimizeAdvanced)+    GHC-Options: -ddump-simpl-stats+  Hs-Source-Dirs: speedtest, src+  If flag(category)+    Hs-Source-Dirs: src-4+  Else+    Hs-Source-Dirs: src-3+  Main-Is: FusionTest.hs++Executable speedtest+  If !flag(buildProfilers)+    Buildable: False+  GHC-Options: -Wall -fexcess-precision+  If flag(optimizeAdvanced)+    GHC-Options: -optc-ffast-math -optc-O3+  --  -funfolding-use-threshold=20 -funfolding-creation-threshold=100+  --  -optc-march=pentium4 -optc-mfpmath=sse+  Hs-Source-Dirs: speedtest, src+  If flag(category)+    Hs-Source-Dirs: src-4+  Else+    Hs-Source-Dirs: src-3+  Main-Is: SpeedTest.hs++Executable speedtest-exp+  If !flag(buildProfilers)+    Buildable: False+  GHC-Options: -Wall -fexcess-precision+  Hs-Source-Dirs: speedtest, src+  If flag(category)+    Hs-Source-Dirs: src-4+  Else+    Hs-Source-Dirs: src-3+  Main-Is: SpeedTestExp.hs+  If flag(splitBase)+    Build-Depends:+      old-time >= 1.0 && < 1.1, directory >= 1.0 && < 1.1++Executable speedtest-simple+  If !flag(buildProfilers)+    Buildable: False+  GHC-Options: -Wall+  Hs-Source-Dirs: speedtest, src+  If flag(category)+    Hs-Source-Dirs: src-4+  Else+    Hs-Source-Dirs: src-3+  Main-Is: SpeedTestSimple.hs